{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- | Decoding using specs. -}
module Data.JsonSpec.Decode (
  StructureFromJSON(..),
  HasJsonDecodingSpec(..),
  eitherDecode,
) where


import Control.Applicative (Alternative((<|>)))
import Data.Aeson.Types
  ( FromJSON(parseJSON), Value(Null, Object), Parser, parseEither, withArray
  , withObject, withScientific, withText
  )
import Data.JsonSpec.Spec
  ( Field(Field), Ref(Ref), Tag(Tag), JSONStructure, JStruct, Specification, sym
  )
import Data.Proxy (Proxy)
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Time (UTCTime)
import GHC.TypeLits (KnownSymbol)
import Prelude
  ( Applicative(pure), Either(Left, Right), Eq((==)), Functor(fmap)
  , Maybe(Just, Nothing), MonadFail(fail), Semigroup((<>))
  , Traversable(traverse), ($), (.), (<$>), Bool, Int, String
  )
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Vector as Vector


{- |
  Types of this class can be JSON decoded according to a type-level
  'Specification'.
-}
class HasJsonDecodingSpec a where
  {- | The decoding 'Specification'. -}
  type DecodingSpec a :: Specification

  {- |
    Given the structural encoding of the JSON data, parse the structure
    into the final type. The reason this returns a @'Parser' a@ instead of
    just a plain @a@ is because there may still be some invariants of the
    JSON data that the 'Specification' language is not able to express,
    and so you may need to fail parsing in those cases. For instance,
    'Specification' is not powerful enough to express "this field must
    contain only prime numbers".
  -}
  fromJSONStructure :: JSONStructure (DecodingSpec a) -> Parser a


{- |
  Analog of 'Data.Aeson.FromJSON', but specialized for decoding our
  "json representations", and closed to the user because the haskell
  representation scheme is fixed and not extensible by the user.

  We can't just use 'Data.Aeson.FromJSON' because the types we are using
  to represent "json data" (i.e. the 'JSONStructure' type family) already
  have 'ToJSON' instances. Even if we were to make a bunch of newtypes
  or whatever to act as the json representation (and therefor also force
  the user to do a lot of wrapping and unwrapping), that still wouldn't
  be sufficient because someone could always write an overlapping (or
  incoherent) 'ToJSON' instance of our newtype! This way we don't have
  to worry about any of that, and the types that the user must deal with
  when implementing 'fromJSONRepr' can be simple tuples and such.
-}
class StructureFromJSON a where
  reprParseJSON :: Value -> Parser a
instance StructureFromJSON Value where
  reprParseJSON :: Value -> Parser Value
reprParseJSON = Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance StructureFromJSON Text where
  reprParseJSON :: Value -> Parser Text
reprParseJSON = String -> (Text -> Parser Text) -> Value -> Parser Text
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"string" Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance StructureFromJSON Scientific where
  reprParseJSON :: Value -> Parser Scientific
reprParseJSON = String
-> (Scientific -> Parser Scientific) -> Value -> Parser Scientific
forall a. String -> (Scientific -> Parser a) -> Value -> Parser a
withScientific String
"number" Scientific -> Parser Scientific
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance StructureFromJSON Int where
  reprParseJSON :: Value -> Parser Int
reprParseJSON = Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON
instance StructureFromJSON () where
  reprParseJSON :: Value -> Parser ()
reprParseJSON =
    String -> (Object -> Parser ()) -> Value -> Parser ()
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"empty object" ((Object -> Parser ()) -> Value -> Parser ())
-> (Object -> Parser ()) -> Value -> Parser ()
forall a b. (a -> b) -> a -> b
$ \Object
_ -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
instance StructureFromJSON Bool where
  reprParseJSON :: Value -> Parser Bool
reprParseJSON = Value -> Parser Bool
forall a. FromJSON a => Value -> Parser a
parseJSON
instance (KnownSymbol key, StructureFromJSON val, StructureFromJSON more) => StructureFromJSON (Field key val, more) where
  reprParseJSON :: Value -> Parser (Field key val, more)
reprParseJSON =
    String
-> (Object -> Parser (Field key val, more))
-> Value
-> Parser (Field key val, more)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"object" ((Object -> Parser (Field key val, more))
 -> Value -> Parser (Field key val, more))
-> (Object -> Parser (Field key val, more))
-> Value
-> Parser (Field key val, more)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      more <- Value -> Parser more
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON (Object -> Value
Object Object
o)
      case KM.lookup (sym @key) o of
        Maybe Value
Nothing -> String -> Parser (Field key val, more)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Field key val, more))
-> String -> Parser (Field key val, more)
forall a b. (a -> b) -> a -> b
$ String
"could not find key: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @key
        Just Value
rawVal -> do
          val <- Value -> Parser val
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
rawVal
          pure (Field val, more)
instance (KnownSymbol key, StructureFromJSON val, StructureFromJSON more) => StructureFromJSON (Maybe (Field key val), more) where
  reprParseJSON :: Value -> Parser (Maybe (Field key val), more)
reprParseJSON =
    String
-> (Object -> Parser (Maybe (Field key val), more))
-> Value
-> Parser (Maybe (Field key val), more)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"object" ((Object -> Parser (Maybe (Field key val), more))
 -> Value -> Parser (Maybe (Field key val), more))
-> (Object -> Parser (Maybe (Field key val), more))
-> Value
-> Parser (Maybe (Field key val), more)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      more <- Value -> Parser more
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON (Object -> Value
Object Object
o)
      case KM.lookup (sym @key) o of
        Maybe Value
Nothing ->
          (Maybe (Field key val), more)
-> Parser (Maybe (Field key val), more)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Field key val)
forall a. Maybe a
Nothing, more
more)
        Just Value
rawVal -> do
          val <- Value -> Parser val
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
rawVal
          pure (Just (Field val), more)
instance (StructureFromJSON left, StructureFromJSON right) => StructureFromJSON (Either left right) where
  reprParseJSON :: Value -> Parser (Either left right)
reprParseJSON Value
v =
    (left -> Either left right
forall a b. a -> Either a b
Left (left -> Either left right)
-> Parser left -> Parser (Either left right)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser left
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
v)
    Parser (Either left right)
-> Parser (Either left right) -> Parser (Either left right)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (right -> Either left right
forall a b. b -> Either a b
Right (right -> Either left right)
-> Parser right -> Parser (Either left right)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser right
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
v)
instance (KnownSymbol const) => StructureFromJSON (Tag const) where
  reprParseJSON :: Value -> Parser (Tag const)
reprParseJSON =
    String
-> (Text -> Parser (Tag const)) -> Value -> Parser (Tag const)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"constant" ((Text -> Parser (Tag const)) -> Value -> Parser (Tag const))
-> (Text -> Parser (Tag const)) -> Value -> Parser (Tag const)
forall a b. (a -> b) -> a -> b
$ \Text
c ->
      if Text
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @const then Tag const -> Parser (Tag const)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tag const
forall (a :: Symbol). Tag a
Tag
      else String -> Parser (Tag const)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected constant value"
instance (StructureFromJSON a) => StructureFromJSON [a] where
  reprParseJSON :: Value -> Parser [a]
reprParseJSON =
    String -> (Array -> Parser [a]) -> Value -> Parser [a]
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray
      String
"list"
      ((Vector a -> [a]) -> Parser (Vector a) -> Parser [a]
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector a -> [a]
forall a. Vector a -> [a]
Vector.toList (Parser (Vector a) -> Parser [a])
-> (Array -> Parser (Vector a)) -> Array -> Parser [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser a) -> Array -> Parser (Vector a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse Value -> Parser a
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON)
instance StructureFromJSON UTCTime where
  reprParseJSON :: Value -> Parser UTCTime
reprParseJSON = Value -> Parser UTCTime
forall a. FromJSON a => Value -> Parser a
parseJSON
instance (StructureFromJSON a) => StructureFromJSON (Maybe a) where
  reprParseJSON :: Value -> Parser (Maybe a)
reprParseJSON Value
val = do
    case Value
val of
      Value
Null -> Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      Value
_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
val
instance
    (StructureFromJSON (JStruct env spec))
  =>
    StructureFromJSON (Ref env spec)
  where
  reprParseJSON :: Value -> Parser (Ref env spec)
reprParseJSON Value
val =
    JStruct env spec -> Ref env spec
forall (env :: Env) (spec :: Specification).
JStruct env spec -> Ref env spec
Ref (JStruct env spec -> Ref env spec)
-> Parser (JStruct env spec) -> Parser (Ref env spec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (JStruct env spec)
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
val


{-|
  Directly decode some JSON accoring to a spec without going through
  any To/FromJSON instances.
-}
eitherDecode
  :: forall spec.
     (StructureFromJSON (JSONStructure spec))
   => Proxy (spec :: Specification)
  -> Value
  -> Either String (JSONStructure spec)
eitherDecode :: forall (spec :: Specification).
StructureFromJSON (JSONStructure spec) =>
Proxy spec -> Value -> Either String (JSONStructure spec)
eitherDecode Proxy spec
_spec =
  (Value -> Parser (JStruct '[] spec))
-> Value -> Either String (JStruct '[] spec)
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser (JStruct '[] spec)
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON