{-# 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,
matchWith,
mkFieldsE,
)
import Data.Morpheus.Client.Internal.Types
( ClientConstructorDefinition (..),
ClientTypeDefinition (..),
TypeNameTH (..),
)
import Data.Morpheus.Client.Internal.Utils
( isEnum,
)
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 Relude hiding (toString)
aesonDeclarations :: TypeKind -> [ClientTypeDefinition -> DecQ]
aesonDeclarations :: TypeKind -> [ClientTypeDefinition -> DecQ]
aesonDeclarations TypeKind
KindEnum = [ClientTypeDefinition -> DecQ
deriveFromJSON, ClientTypeDefinition -> DecQ
deriveToJSON]
aesonDeclarations TypeKind
KindScalar = [ClientTypeDefinition -> DecQ]
deriveScalarJSON
aesonDeclarations TypeKind
kind
| TypeKind -> Bool
forall t. Strictness t => t -> Bool
isResolverType TypeKind
kind = [ClientTypeDefinition -> DecQ
deriveFromJSON]
| Bool
otherwise = [ClientTypeDefinition -> DecQ
deriveToJSON]
failure :: GQLError -> Q a
failure :: GQLError -> Q a
failure = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> (GQLError -> String) -> GQLError -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> String
forall b a. (Show a, IsString b) => a -> b
show
deriveScalarJSON :: [ClientTypeDefinition -> DecQ]
deriveScalarJSON :: [ClientTypeDefinition -> DecQ]
deriveScalarJSON = [ClientTypeDefinition -> DecQ
deriveScalarFromJSON, ClientTypeDefinition -> DecQ
deriveScalarToJSON]
deriveScalarFromJSON :: ClientTypeDefinition -> DecQ
deriveScalarFromJSON :: ClientTypeDefinition -> DecQ
deriveScalarFromJSON ClientTypeDefinition {TypeNameTH
clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName :: TypeNameTH
clientTypeName} =
TypeNameTH -> ExpQ -> DecQ
defineFromJSON TypeNameTH
clientTypeName [|scalarFromJSON|]
deriveScalarToJSON :: ClientTypeDefinition -> DecQ
deriveScalarToJSON :: ClientTypeDefinition -> DecQ
deriveScalarToJSON
ClientTypeDefinition
{ clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName = TypeNameTH {TypeName
typename :: TypeNameTH -> TypeName
typename :: TypeName
typename}
} = CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) TypeQ
typeDef [DecQ]
body
where
typeDef :: TypeQ
typeDef = Name -> [TypeName] -> TypeQ
forall con cons.
(ToName con, ToName cons) =>
con -> [cons] -> TypeQ
applyCons ''ToJSON [TypeName
typename]
body :: [DecQ]
body = [Name -> [PatQ] -> ExpQ -> DecQ
funDSimple 'toJSON [] [|scalarToJSON|]]
deriveFromJSON :: ClientTypeDefinition -> DecQ
deriveFromJSON :: ClientTypeDefinition -> DecQ
deriveFromJSON ClientTypeDefinition {clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons = [], TypeNameTH
clientTypeName :: TypeNameTH
clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName} =
GQLError -> DecQ
forall a. GQLError -> Q a
failure
(GQLError -> DecQ) -> GQLError -> DecQ
forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
internal
(GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
"Type "
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg (TypeNameTH -> TypeName
typename TypeNameTH
clientTypeName)
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" Should Have at least one Constructor"
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 -> DecQ
defineFromJSON TypeNameTH
clientTypeName (ExpQ -> DecQ) -> ExpQ -> DecQ
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, [ClientConstructorDefinition]
clientCons :: [ClientConstructorDefinition]
clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons}
| [ClientConstructorDefinition] -> Bool
isEnum [ClientConstructorDefinition]
clientCons =
TypeNameTH -> ExpQ -> DecQ
defineFromJSON TypeNameTH
clientTypeName (ExpQ -> DecQ) -> ExpQ -> DecQ
forall a b. (a -> b) -> a -> b
$
TypeNameTH -> [ClientConstructorDefinition] -> ExpQ
aesonFromJSONEnumBody TypeNameTH
clientTypeName [ClientConstructorDefinition]
clientCons
| Bool
otherwise =
TypeNameTH -> ExpQ -> DecQ
defineFromJSON TypeNameTH
clientTypeName (ExpQ -> DecQ) -> ExpQ -> DecQ
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
(Exp -> Exp) -> ExpQ -> ExpQ
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 [Pat
forall a. ToVar Name a => a
v'] Exp
body)
name :: Exp
name :: Exp
name = TypeName -> Exp
forall a b. ToString a b => a -> b
toString ([FieldName] -> TypeName -> TypeName
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} =
(Bool -> Name) -> TypeName -> [FieldDefinition ANY VALID] -> ExpQ
forall (cat :: TypeCategory) (s :: Stage).
(Bool -> Name) -> TypeName -> [FieldDefinition cat s] -> ExpQ
decodeObjectE
Bool -> Name
entry
([FieldName] -> TypeName -> TypeName
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}
} =
ExpQ -> ExpQ -> ExpQ
appE [|takeValueType|] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
Maybe (PatQ, ExpQ)
-> (ClientConstructorDefinition -> (PatQ, ExpQ))
-> [ClientConstructorDefinition]
-> ExpQ
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 =
([PatQ] -> PatQ
tupP [PatQ
_', PatQ
forall a. ToVar Name a => a
v'],)
(ExpQ -> (PatQ, ExpQ))
-> (ClientConstructorDefinition -> ExpQ)
-> ClientConstructorDefinition
-> (PatQ, ExpQ)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FieldName] -> ClientConstructorDefinition -> ExpQ
aesonObjectBody
[FieldName]
namespace
(ClientConstructorDefinition -> (PatQ, ExpQ))
-> Maybe ClientConstructorDefinition -> Maybe (PatQ, ExpQ)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClientConstructorDefinition -> Bool)
-> [ClientConstructorDefinition]
-> Maybe ClientConstructorDefinition
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((TypeName
typename TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
==) (TypeName -> Bool)
-> (ClientConstructorDefinition -> TypeName)
-> ClientConstructorDefinition
-> 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} =
( [PatQ] -> PatQ
tupP [TypeName -> PatQ
forall a b. ToString a b => a -> b
toString TypeName
cName, if [FieldDefinition ANY VALID] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldDefinition ANY VALID]
cFields then PatQ
_' else PatQ
forall a. ToVar Name a => a
v'],
[FieldName] -> ClientConstructorDefinition -> ExpQ
aesonObjectBody [FieldName]
namespace ClientConstructorDefinition
cons
)
takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a
takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a
takeValueType (String, Object) -> Parser a
f (Object Object
hMap) = case Key -> Object -> Maybe Value
forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a
lookup Key
"__typename" Object
hMap of
Maybe Value
Nothing -> String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"key \"__typename\" not found on object"
Just (String Text
x) -> (String, Object) -> Parser (String, Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
T.unpack Text
x, Object
hMap) Parser (String, Object)
-> ((String, Object) -> Parser a) -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String, Object) -> Parser a
f
Just Value
val ->
String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"key \"__typename\" should be string but found: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall b a. (Show a, IsString b) => a -> b
show Value
val
takeValueType (String, Object) -> Parser a
_ Value
_ = String -> Parser a
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} =
[FieldName] -> TypeName -> TypeName
forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
namespace TypeName
typename
defineFromJSON :: TypeNameTH -> ExpQ -> DecQ
defineFromJSON :: TypeNameTH -> ExpQ -> DecQ
defineFromJSON TypeNameTH
name ExpQ
expr = CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) TypeQ
typeDef [DecQ]
body
where
typeDef :: TypeQ
typeDef = Name -> [TypeName] -> TypeQ
forall con cons.
(ToName con, ToName cons) =>
con -> [cons] -> TypeQ
applyCons ''FromJSON [TypeNameTH -> TypeName
namespaced TypeNameTH
name]
body :: [DecQ]
body = [Name -> [PatQ] -> ExpQ -> DecQ
funDSimple 'parseJSON [] ExpQ
expr]
aesonFromJSONEnumBody :: TypeNameTH -> [ClientConstructorDefinition] -> ExpQ
aesonFromJSONEnumBody :: TypeNameTH -> [ClientConstructorDefinition] -> ExpQ
aesonFromJSONEnumBody TypeNameTH {TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename} = Maybe (PatQ, ExpQ)
-> (ClientConstructorDefinition -> (PatQ, ExpQ))
-> [ClientConstructorDefinition]
-> ExpQ
forall t. Maybe (PatQ, ExpQ) -> (t -> (PatQ, ExpQ)) -> [t] -> ExpQ
matchWith ((PatQ, ExpQ) -> Maybe (PatQ, ExpQ)
forall a. a -> Maybe a
Just (PatQ
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} =
( TypeName -> PatQ
forall a b. ToString a b => a -> b
toString TypeName
cName,
ExpQ -> ExpQ -> ExpQ
appE [|pure|] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ TypeName -> ExpQ
forall a b. ToCon a b => a -> b
toCon (TypeName -> ExpQ) -> TypeName -> ExpQ
forall a b. (a -> b) -> a -> b
$ [TypeName] -> TypeName -> TypeName
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} = Maybe (PatQ, ExpQ)
-> (ClientConstructorDefinition -> (PatQ, ExpQ))
-> [ClientConstructorDefinition]
-> ExpQ
forall t. Maybe (PatQ, ExpQ) -> (t -> (PatQ, ExpQ)) -> [t] -> ExpQ
matchWith Maybe (PatQ, ExpQ)
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} =
( Name -> [PatQ] -> PatQ
conP (TypeName -> Name
forall a. ToName a => a -> Name
toName (TypeName -> Name) -> TypeName -> Name
forall a b. (a -> b) -> a -> b
$ [TypeName] -> TypeName -> TypeName
forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [TypeName
typename] TypeName
cName) [],
TypeName -> ExpQ
forall a b. ToString a b => a -> b
toString TypeName
cName
)
deriveToJSON :: ClientTypeDefinition -> DecQ
deriveToJSON :: ClientTypeDefinition -> DecQ
deriveToJSON
ClientTypeDefinition
{ clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons = []
} =
String -> DecQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Type Should Have at least one Constructor"
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}]
} =
CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) TypeQ
appHead [DecQ]
methods
where
appHead :: TypeQ
appHead = Name -> [TypeName] -> TypeQ
forall con cons.
(ToName con, ToName cons) =>
con -> [cons] -> TypeQ
applyCons ''ToJSON [TypeName
typename]
methods :: [DecQ]
methods = [Name -> [PatQ] -> ExpQ -> DecQ
funDSimple 'toJSON [PatQ]
args ExpQ
body]
where
args :: [PatQ]
args = [TypeName -> [FieldDefinition ANY VALID] -> PatQ
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> [FieldDefinition cat s] -> PatQ
destructRecord TypeName
typename [FieldDefinition ANY VALID]
cFields]
body :: ExpQ
body =
Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$
Exp -> Exp -> Exp
AppE
(Name -> Exp
VarE 'object)
(TypeName -> Name -> [FieldDefinition ANY VALID] -> Exp
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> Name -> [FieldDefinition cat s] -> Exp
mkFieldsE TypeName
typename '(.=) [FieldDefinition ANY VALID]
cFields)
deriveToJSON
ClientTypeDefinition
{ clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName = clientTypeName :: TypeNameTH
clientTypeName@TypeNameTH {TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename},
[ClientConstructorDefinition]
clientCons :: [ClientConstructorDefinition]
clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons
}
| [ClientConstructorDefinition] -> Bool
isEnum [ClientConstructorDefinition]
clientCons = CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) TypeQ
typeDef [DecQ]
body
| Bool
otherwise = String -> DecQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Input Unions are not yet supported"
where
typeDef :: TypeQ
typeDef = Name -> [TypeName] -> TypeQ
forall con cons.
(ToName con, ToName cons) =>
con -> [cons] -> TypeQ
applyCons ''ToJSON [TypeName
typename]
body :: [DecQ]
body = [Name -> [PatQ] -> ExpQ -> DecQ
funDSimple 'toJSON [] (TypeNameTH -> [ClientConstructorDefinition] -> ExpQ
aesonToJSONEnumBody TypeNameTH
clientTypeName [ClientConstructorDefinition]
clientCons)]