{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Client.Declare.Aeson
( aesonDeclarations,
)
where
import Data.Aeson
import Data.Aeson.Types
import Data.Morpheus.Client.Internal.TH
( decodeObjectE,
destructRecord,
failExp,
hasInstance,
isTypeDeclared,
matchWith,
mkFieldsE,
)
import Data.Morpheus.Client.Internal.Types
( ClientConstructorDefinition (..),
ClientTypeDefinition (..),
TypeNameTH (..),
)
import Data.Morpheus.CodeGen.Internal.TH
( applyCons,
camelCaseTypeName,
funDSimple,
toCon,
toName,
toString,
v',
_',
)
import Data.Morpheus.Internal.Utils (IsMap (lookup))
import Data.Morpheus.Types.GQLScalar
( scalarFromJSON,
scalarToJSON,
)
import Data.Morpheus.Types.Internal.AST
( FieldName,
GQLError,
Msg (msg),
TypeKind (..),
TypeName,
internal,
isResolverType,
)
import qualified Data.Text as T
import Language.Haskell.TH
( DecQ,
Exp (..),
ExpQ,
Name,
PatQ,
Q,
appE,
conP,
cxt,
instanceD,
tupP,
)
import Language.Haskell.TH.Syntax (Dec)
import Relude hiding (toString)
aesonDeclarations :: TypeKind -> ClientTypeDefinition -> Q [Dec]
aesonDeclarations :: TypeKind -> ClientTypeDefinition -> Q [Dec]
aesonDeclarations TypeKind
KindEnum ClientTypeDefinition
clientDef = do
[Dec]
a <- (ClientTypeDefinition -> Q Dec)
-> Name -> ClientTypeDefinition -> Q [Dec]
deriveIfNotDefined ClientTypeDefinition -> Q Dec
deriveFromJSON ''FromJSON ClientTypeDefinition
clientDef
[Dec]
b <- (ClientTypeDefinition -> Q Dec)
-> Name -> ClientTypeDefinition -> Q [Dec]
deriveIfNotDefined ClientTypeDefinition -> Q Dec
deriveToJSON ''ToJSON ClientTypeDefinition
clientDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
a forall a. Semigroup a => a -> a -> a
<> [Dec]
b)
aesonDeclarations TypeKind
KindScalar ClientTypeDefinition
clientDef = ClientTypeDefinition -> Q [Dec]
deriveScalarJSON ClientTypeDefinition
clientDef
aesonDeclarations TypeKind
kind ClientTypeDefinition
clientDef
| forall t. Strictness t => t -> Bool
isResolverType TypeKind
kind = (ClientTypeDefinition -> Q Dec)
-> Name -> ClientTypeDefinition -> Q [Dec]
deriveIfNotDefined ClientTypeDefinition -> Q Dec
deriveFromJSON ''FromJSON ClientTypeDefinition
clientDef
| Bool
otherwise = (ClientTypeDefinition -> Q Dec)
-> Name -> ClientTypeDefinition -> Q [Dec]
deriveIfNotDefined ClientTypeDefinition -> Q Dec
deriveToJSON ''ToJSON ClientTypeDefinition
clientDef
deriveIfNotDefined :: (ClientTypeDefinition -> Q Dec) -> Name -> ClientTypeDefinition -> Q [Dec]
deriveIfNotDefined :: (ClientTypeDefinition -> Q Dec)
-> Name -> ClientTypeDefinition -> Q [Dec]
deriveIfNotDefined ClientTypeDefinition -> Q Dec
derivation Name
typeClass ClientTypeDefinition
clientDef = do
Bool
exists <- ClientTypeDefinition -> Q Bool
isTypeDeclared ClientTypeDefinition
clientDef
if Bool
exists
then do
Bool
has <- Name -> ClientTypeDefinition -> Q Bool
hasInstance Name
typeClass ClientTypeDefinition
clientDef
if Bool
has
then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else Q [Dec]
mkDerivation
else Q [Dec]
mkDerivation
where
mkDerivation :: Q [Dec]
mkDerivation :: Q [Dec]
mkDerivation = do
Dec
derived <- ClientTypeDefinition -> Q Dec
derivation ClientTypeDefinition
clientDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
derived]
failure :: GQLError -> Q a
failure :: forall a. GQLError -> Q a
failure = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show
deriveScalarJSON :: ClientTypeDefinition -> Q [Dec]
deriveScalarJSON :: ClientTypeDefinition -> Q [Dec]
deriveScalarJSON ClientTypeDefinition
clientDef = do
[Dec]
a <- (ClientTypeDefinition -> Q Dec)
-> Name -> ClientTypeDefinition -> Q [Dec]
deriveIfNotDefined ClientTypeDefinition -> Q Dec
deriveScalarFromJSON ''FromJSON ClientTypeDefinition
clientDef
[Dec]
b <- (ClientTypeDefinition -> Q Dec)
-> Name -> ClientTypeDefinition -> Q [Dec]
deriveIfNotDefined ClientTypeDefinition -> Q Dec
deriveScalarToJSON ''ToJSON ClientTypeDefinition
clientDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
a forall a. Semigroup a => a -> a -> a
<> [Dec]
b)
deriveScalarFromJSON :: ClientTypeDefinition -> DecQ
deriveScalarFromJSON :: ClientTypeDefinition -> Q Dec
deriveScalarFromJSON ClientTypeDefinition {TypeNameTH
clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName :: TypeNameTH
clientTypeName} =
TypeNameTH -> ExpQ -> Q Dec
defineFromJSON TypeNameTH
clientTypeName [|scalarFromJSON|]
deriveScalarToJSON :: ClientTypeDefinition -> DecQ
deriveScalarToJSON :: ClientTypeDefinition -> Q Dec
deriveScalarToJSON
ClientTypeDefinition
{ clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName = TypeNameTH {TypeName
typename :: TypeNameTH -> TypeName
typename :: TypeName
typename}
} = forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) Q Type
typeDef [Q Dec]
body
where
typeDef :: Q Type
typeDef = forall con cons.
(ToName con, ToName cons) =>
con -> [cons] -> Q Type
applyCons ''ToJSON [TypeName
typename]
body :: [Q Dec]
body = [Name -> [PatQ] -> ExpQ -> Q Dec
funDSimple 'toJSON [] [|scalarToJSON|]]
deriveFromJSON :: ClientTypeDefinition -> DecQ
deriveFromJSON :: ClientTypeDefinition -> Q Dec
deriveFromJSON ClientTypeDefinition {clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons = [], TypeNameTH
clientTypeName :: TypeNameTH
clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName} =
forall a. GQLError -> Q a
failure forall a b. (a -> b) -> a -> b
$
GQLError -> GQLError
internal forall a b. (a -> b) -> a -> b
$
GQLError
"Type "
forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg (TypeNameTH -> TypeName
typename TypeNameTH
clientTypeName)
forall a. Semigroup a => a -> a -> a
<> GQLError
" Should Have at least one Constructor"
deriveFromJSON ClientTypeDefinition {TypeNameTH
clientTypeName :: TypeNameTH
clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName, [ClientConstructorDefinition]
clientCons :: [ClientConstructorDefinition]
clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons, clientKind :: ClientTypeDefinition -> TypeKind
clientKind = TypeKind
KindEnum} =
TypeNameTH -> ExpQ -> Q Dec
defineFromJSON TypeNameTH
clientTypeName forall a b. (a -> b) -> a -> b
$
TypeNameTH -> [ClientConstructorDefinition] -> ExpQ
aesonFromJSONEnumBody TypeNameTH
clientTypeName [ClientConstructorDefinition]
clientCons
deriveFromJSON
ClientTypeDefinition
{ clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName = clientTypeName :: TypeNameTH
clientTypeName@TypeNameTH {[FieldName]
namespace :: TypeNameTH -> [FieldName]
namespace :: [FieldName]
namespace},
clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons = [ClientConstructorDefinition
cons]
} =
TypeNameTH -> ExpQ -> Q Dec
defineFromJSON TypeNameTH
clientTypeName forall a b. (a -> b) -> a -> b
$
[FieldName] -> ClientConstructorDefinition -> ExpQ
aesonObject [FieldName]
namespace ClientConstructorDefinition
cons
deriveFromJSON typeD :: ClientTypeDefinition
typeD@ClientTypeDefinition {TypeNameTH
clientTypeName :: TypeNameTH
clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName} =
TypeNameTH -> ExpQ -> Q Dec
defineFromJSON TypeNameTH
clientTypeName forall a b. (a -> b) -> a -> b
$
ClientTypeDefinition -> ExpQ
aesonUnionObject ClientTypeDefinition
typeD
aesonObject :: [FieldName] -> ClientConstructorDefinition -> ExpQ
aesonObject :: [FieldName] -> ClientConstructorDefinition -> ExpQ
aesonObject [FieldName]
tNamespace con :: ClientConstructorDefinition
con@ClientConstructorDefinition {TypeName
cName :: ClientConstructorDefinition -> TypeName
cName :: TypeName
cName} =
Exp -> Exp
withBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldName] -> ClientConstructorDefinition -> ExpQ
aesonObjectBody [FieldName]
tNamespace ClientConstructorDefinition
con
where
withBody :: Exp -> Exp
withBody Exp
body =
Exp -> Exp -> Exp
AppE
(Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'withObject) Exp
name)
([Pat] -> Exp -> Exp
LamE [forall a. ToVar Name a => a
v'] Exp
body)
name :: Exp
name :: Exp
name = forall a b. ToString a b => a -> b
toString (forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
tNamespace TypeName
cName)
aesonObjectBody :: [FieldName] -> ClientConstructorDefinition -> ExpQ
aesonObjectBody :: [FieldName] -> ClientConstructorDefinition -> ExpQ
aesonObjectBody [FieldName]
namespace ClientConstructorDefinition {TypeName
cName :: TypeName
cName :: ClientConstructorDefinition -> TypeName
cName, [FieldDefinition ANY VALID]
cFields :: ClientConstructorDefinition -> [FieldDefinition ANY VALID]
cFields :: [FieldDefinition ANY VALID]
cFields} =
forall (cat :: TypeCategory) (s :: Stage).
(Bool -> Name) -> TypeName -> [FieldDefinition cat s] -> ExpQ
decodeObjectE
Bool -> Name
entry
(forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
namespace TypeName
cName)
[FieldDefinition ANY VALID]
cFields
entry :: Bool -> Name
entry :: Bool -> Name
entry Bool
nullable
| Bool
nullable = '(.:?)
| Bool
otherwise = '(.:)
aesonUnionObject :: ClientTypeDefinition -> ExpQ
aesonUnionObject :: ClientTypeDefinition -> ExpQ
aesonUnionObject
ClientTypeDefinition
{ [ClientConstructorDefinition]
clientCons :: [ClientConstructorDefinition]
clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons,
clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName = TypeNameTH {[FieldName]
namespace :: [FieldName]
namespace :: TypeNameTH -> [FieldName]
namespace, TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename}
} =
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|takeValueType|] forall a b. (a -> b) -> a -> b
$
forall t. Maybe (PatQ, ExpQ) -> (t -> (PatQ, ExpQ)) -> [t] -> ExpQ
matchWith Maybe (PatQ, ExpQ)
elseCondition ClientConstructorDefinition -> (PatQ, ExpQ)
f [ClientConstructorDefinition]
clientCons
where
elseCondition :: Maybe (PatQ, ExpQ)
elseCondition =
(forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [PatQ
_', forall a. ToVar Name a => a
v'],)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FieldName] -> ClientConstructorDefinition -> ExpQ
aesonObjectBody
[FieldName]
namespace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((TypeName
typename forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientConstructorDefinition -> TypeName
cName) [ClientConstructorDefinition]
clientCons
f :: ClientConstructorDefinition -> (PatQ, ExpQ)
f cons :: ClientConstructorDefinition
cons@ClientConstructorDefinition {TypeName
cName :: TypeName
cName :: ClientConstructorDefinition -> TypeName
cName, [FieldDefinition ANY VALID]
cFields :: [FieldDefinition ANY VALID]
cFields :: ClientConstructorDefinition -> [FieldDefinition ANY VALID]
cFields} =
( forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [forall a b. ToString a b => a -> b
toString TypeName
cName, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldDefinition ANY VALID]
cFields then PatQ
_' else forall a. ToVar Name a => a
v'],
[FieldName] -> ClientConstructorDefinition -> ExpQ
aesonObjectBody [FieldName]
namespace ClientConstructorDefinition
cons
)
takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a
takeValueType :: forall a. ((String, Object) -> Parser a) -> Value -> Parser a
takeValueType (String, Object) -> Parser a
f (Object Object
hMap) = case forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a
lookup Key
"__typename" Object
hMap of
Maybe Value
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"key \"__typename\" not found on object"
Just (String Text
x) -> (String, Object) -> Parser a
f (Text -> String
T.unpack Text
x, Object
hMap)
Just Value
val ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"key \"__typename\" should be string but found: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Value
val
takeValueType (String, Object) -> Parser a
_ Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Object"
namespaced :: TypeNameTH -> TypeName
namespaced :: TypeNameTH -> TypeName
namespaced TypeNameTH {[FieldName]
namespace :: [FieldName]
namespace :: TypeNameTH -> [FieldName]
namespace, TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename} =
forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
namespace TypeName
typename
defineFromJSON :: TypeNameTH -> ExpQ -> DecQ
defineFromJSON :: TypeNameTH -> ExpQ -> Q Dec
defineFromJSON TypeNameTH
name ExpQ
expr = forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) Q Type
typeDef [Q Dec]
body
where
typeDef :: Q Type
typeDef = forall con cons.
(ToName con, ToName cons) =>
con -> [cons] -> Q Type
applyCons ''FromJSON [TypeNameTH -> TypeName
namespaced TypeNameTH
name]
body :: [Q Dec]
body = [Name -> [PatQ] -> ExpQ -> Q Dec
funDSimple 'parseJSON [] ExpQ
expr]
aesonFromJSONEnumBody :: TypeNameTH -> [ClientConstructorDefinition] -> ExpQ
aesonFromJSONEnumBody :: TypeNameTH -> [ClientConstructorDefinition] -> ExpQ
aesonFromJSONEnumBody TypeNameTH {TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename} = forall t. Maybe (PatQ, ExpQ) -> (t -> (PatQ, ExpQ)) -> [t] -> ExpQ
matchWith (forall a. a -> Maybe a
Just (forall a. ToVar Name a => a
v', ExpQ
failExp)) ClientConstructorDefinition -> (PatQ, ExpQ)
f
where
f :: ClientConstructorDefinition -> (PatQ, ExpQ)
f :: ClientConstructorDefinition -> (PatQ, ExpQ)
f ClientConstructorDefinition {TypeName
cName :: TypeName
cName :: ClientConstructorDefinition -> TypeName
cName} =
( forall a b. ToString a b => a -> b
toString TypeName
cName,
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|pure|] forall a b. (a -> b) -> a -> b
$ forall a b. ToCon a b => a -> b
toCon forall a b. (a -> b) -> a -> b
$ forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [TypeName
typename] TypeName
cName
)
aesonToJSONEnumBody :: TypeNameTH -> [ClientConstructorDefinition] -> ExpQ
aesonToJSONEnumBody :: TypeNameTH -> [ClientConstructorDefinition] -> ExpQ
aesonToJSONEnumBody TypeNameTH {TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename} = forall t. Maybe (PatQ, ExpQ) -> (t -> (PatQ, ExpQ)) -> [t] -> ExpQ
matchWith forall a. Maybe a
Nothing ClientConstructorDefinition -> (PatQ, ExpQ)
f
where
f :: ClientConstructorDefinition -> (PatQ, ExpQ)
f :: ClientConstructorDefinition -> (PatQ, ExpQ)
f ClientConstructorDefinition {TypeName
cName :: TypeName
cName :: ClientConstructorDefinition -> TypeName
cName} =
( forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (forall a. ToName a => a -> Name
toName forall a b. (a -> b) -> a -> b
$ forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [TypeName
typename] TypeName
cName) [],
forall a b. ToString a b => a -> b
toString TypeName
cName
)
deriveToJSON :: ClientTypeDefinition -> DecQ
deriveToJSON :: ClientTypeDefinition -> Q Dec
deriveToJSON
ClientTypeDefinition
{ clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons = []
} =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Type Should Have at least one Constructor"
deriveToJSON
ClientTypeDefinition
{ clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName = clientTypeName :: TypeNameTH
clientTypeName@TypeNameTH {TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename},
[ClientConstructorDefinition]
clientCons :: [ClientConstructorDefinition]
clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons,
clientKind :: ClientTypeDefinition -> TypeKind
clientKind = TypeKind
KindEnum
} = forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) Q Type
typeDef [Q Dec]
body
where
typeDef :: Q Type
typeDef = forall con cons.
(ToName con, ToName cons) =>
con -> [cons] -> Q Type
applyCons ''ToJSON [TypeName
typename]
body :: [Q Dec]
body = [Name -> [PatQ] -> ExpQ -> Q Dec
funDSimple 'toJSON [] (TypeNameTH -> [ClientConstructorDefinition] -> ExpQ
aesonToJSONEnumBody TypeNameTH
clientTypeName [ClientConstructorDefinition]
clientCons)]
deriveToJSON
ClientTypeDefinition
{ clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName = TypeNameTH {TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename},
clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons = [ClientConstructorDefinition {[FieldDefinition ANY VALID]
cFields :: [FieldDefinition ANY VALID]
cFields :: ClientConstructorDefinition -> [FieldDefinition ANY VALID]
cFields}]
} =
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) Q Type
appHead [Q Dec]
methods
where
appHead :: Q Type
appHead = forall con cons.
(ToName con, ToName cons) =>
con -> [cons] -> Q Type
applyCons ''ToJSON [TypeName
typename]
methods :: [Q Dec]
methods = [Name -> [PatQ] -> ExpQ -> Q Dec
funDSimple 'toJSON [PatQ]
args ExpQ
body]
where
args :: [PatQ]
args = [forall (cat :: TypeCategory) (s :: Stage).
TypeName -> [FieldDefinition cat s] -> PatQ
destructRecord TypeName
typename [FieldDefinition ANY VALID]
cFields]
body :: ExpQ
body =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Exp -> Exp -> Exp
AppE
(Name -> Exp
VarE 'omitNulls)
(forall (cat :: TypeCategory) (s :: Stage).
TypeName -> Name -> [FieldDefinition cat s] -> Exp
mkFieldsE TypeName
typename '(.=) [FieldDefinition ANY VALID]
cFields)
deriveToJSON ClientTypeDefinition
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Input Unions are not yet supported"
omitNulls :: [Pair] -> Value
omitNulls :: [Pair] -> Value
omitNulls = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall {a}. (a, Value) -> Bool
notNull
where
notNull :: (a, Value) -> Bool
notNull (a
_, Value
Null) = Bool
False
notNull (a, Value)
_ = Bool
True