{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.CodeGen.Interpreting.PreDeclarations
  ( mapPreDeclarations,
  )
where

import Data.Aeson
  ( FromJSON (parseJSON),
    ToJSON (toJSON),
  )
import Data.Aeson.Types ((.:), (.:?), (.=))
import Data.Morpheus.Client.CodeGen.AST
  ( AesonField,
    ClientDeclaration (..),
    ClientMethod (..),
    ClientPreDeclaration (..),
    DERIVING_MODE (..),
    MValue (..),
    RequestTypeDefinition (..),
    UnionPat (..),
  )
import Data.Morpheus.Client.CodeGen.Internal (invalidConstructorError, omitNulls)
import Data.Morpheus.Client.Fetch.RequestType
  ( RequestType (..),
  )
import Data.Morpheus.CodeGen.Internal.AST
  ( AssociatedType (AssociatedTypeName),
    CodeGenConstructor (..),
    CodeGenField (..),
    CodeGenType (..),
    CodeGenTypeName (typename),
    MethodArgument (..),
    PrintableValue (..),
    TypeClassInstance (..),
    fromTypeName,
    getFullName,
  )
import Data.Morpheus.CodeGen.TH
  ( ToName (toName),
  )
import Data.Morpheus.CodeGen.Utils (camelCaseFieldName)
import Data.Morpheus.Types.GQLScalar
  ( scalarFromJSON,
    scalarToJSON,
  )
import Data.Morpheus.Types.Internal.AST (Msg (..), internal)
import Language.Haskell.TH.Syntax (Name)
import Relude hiding (ToString, Type, toString)

mapPreDeclarations :: MonadFail m => ClientPreDeclaration -> m ClientDeclaration
mapPreDeclarations :: forall (m :: * -> *).
MonadFail m =>
ClientPreDeclaration -> m ClientDeclaration
mapPreDeclarations (FromJSONClass DERIVING_MODE
mode CodeGenType
dec) = DERIVING_MODE
-> TypeClassInstance ClientMethod -> ClientDeclaration
InstanceDeclaration DERIVING_MODE
mode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
DERIVING_MODE -> CodeGenType -> m (TypeClassInstance ClientMethod)
deriveFromJSON DERIVING_MODE
mode CodeGenType
dec
mapPreDeclarations (FromJSONObjectClass CodeGenTypeName
cType CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorFields :: [CodeGenField]
constructorName :: CodeGenTypeName
..}) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DERIVING_MODE
-> TypeClassInstance ClientMethod -> ClientDeclaration
InstanceDeclaration DERIVING_MODE
TYPE_MODE forall a b. (a -> b) -> a -> b
$ forall body. CodeGenTypeName -> body -> TypeClassInstance body
mkFromJSON CodeGenTypeName
cType forall a b. (a -> b) -> a -> b
$ TypeName -> [AesonField] -> ClientMethod
FromJSONObjectMethod (CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
constructorName) (forall a b. (a -> b) -> [a] -> [b]
map CodeGenField -> AesonField
defField [CodeGenField]
constructorFields)
mapPreDeclarations (FromJSONUnionClass CodeGenTypeName
cType [(UnionPat, (CodeGenTypeName, Maybe String))]
constructors) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DERIVING_MODE
-> TypeClassInstance ClientMethod -> ClientDeclaration
InstanceDeclaration DERIVING_MODE
TYPE_MODE forall a b. (a -> b) -> a -> b
$ forall body. CodeGenTypeName -> body -> TypeClassInstance body
mkFromJSON CodeGenTypeName
cType forall a b. (a -> b) -> a -> b
$ [([UnionPat], (Name, Maybe Name))] -> ClientMethod
FromJSONUnionMethod forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}.
(ToName a, ToName a) =>
(UnionPat, (a, Maybe a)) -> ([UnionPat], (Name, Maybe Name))
mkMatch [(UnionPat, (CodeGenTypeName, Maybe String))]
constructors
  where
    mkMatch :: (UnionPat, (a, Maybe a)) -> ([UnionPat], (Name, Maybe Name))
mkMatch (UnionPat
tag, (a
consName, Maybe a
typeName)) = ([UnionPat
tag, String -> UnionPat
UVar forall a b. (a -> b) -> a -> b
$ if forall a. Maybe a -> Bool
isJust Maybe a
typeName then String
"v" else String
"_"], (forall a. ToName a => a -> Name
toName a
consName, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToName a => a -> Name
toName Maybe a
typeName))
mapPreDeclarations (ToJSONClass DERIVING_MODE
mode CodeGenType
clientDef) = DERIVING_MODE
-> TypeClassInstance ClientMethod -> ClientDeclaration
InstanceDeclaration DERIVING_MODE
mode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
DERIVING_MODE -> CodeGenType -> m (TypeClassInstance ClientMethod)
deriveToJSON DERIVING_MODE
mode CodeGenType
clientDef
mapPreDeclarations (ClientType CodeGenType
c) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CodeGenType -> ClientDeclaration
ClientTypeDeclaration CodeGenType
c
mapPreDeclarations (RequestTypeClass RequestTypeDefinition
req) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DERIVING_MODE
-> TypeClassInstance ClientMethod -> ClientDeclaration
InstanceDeclaration DERIVING_MODE
TYPE_MODE (RequestTypeDefinition -> TypeClassInstance ClientMethod
getRequestInstance RequestTypeDefinition
req)

getRequestInstance :: RequestTypeDefinition -> TypeClassInstance ClientMethod
getRequestInstance :: RequestTypeDefinition -> TypeClassInstance ClientMethod
getRequestInstance RequestTypeDefinition {String
OperationType
TypeName
requestQuery :: RequestTypeDefinition -> String
requestType :: RequestTypeDefinition -> OperationType
requestArgs :: RequestTypeDefinition -> TypeName
requestName :: RequestTypeDefinition -> TypeName
requestQuery :: String
requestType :: OperationType
requestArgs :: TypeName
requestName :: TypeName
..} =
  TypeClassInstance
    { typeClassName :: Name
typeClassName = ''RequestType,
      typeClassContext :: [(Name, Name)]
typeClassContext = [],
      typeClassTarget :: CodeGenTypeName
typeClassTarget = TypeName -> CodeGenTypeName
fromTypeName TypeName
requestName,
      assoc :: [(Name, AssociatedType)]
assoc = [(''RequestArgs, Name -> AssociatedType
AssociatedTypeName forall a b. (a -> b) -> a -> b
$ forall a. ToName a => a -> Name
toName TypeName
requestArgs)],
      [(Name, MethodArgument, ClientMethod)]
typeClassMethods :: [(Name, MethodArgument, ClientMethod)]
typeClassMethods :: [(Name, MethodArgument, ClientMethod)]
typeClassMethods
    }
  where
    typeClassMethods :: [(Name, MethodArgument, ClientMethod)]
typeClassMethods =
      [ ('__name, MethodArgument
ProxyArgument, PrintableValue -> ClientMethod
PrintableMethod forall a b. (a -> b) -> a -> b
$ forall a. (Show a, Lift a) => a -> PrintableValue
PrintableValue TypeName
requestName),
        ('__query, MethodArgument
ProxyArgument, PrintableValue -> ClientMethod
PrintableMethod forall a b. (a -> b) -> a -> b
$ forall a. (Show a, Lift a) => a -> PrintableValue
PrintableValue String
requestQuery),
        ('__type, MethodArgument
ProxyArgument, PrintableValue -> ClientMethod
PrintableMethod forall a b. (a -> b) -> a -> b
$ forall a. (Show a, Lift a) => a -> PrintableValue
PrintableValue OperationType
requestType)
      ]

-- FromJSON
deriveFromJSONMethod :: MonadFail m => DERIVING_MODE -> CodeGenType -> m ClientMethod
deriveFromJSONMethod :: forall (m :: * -> *).
MonadFail m =>
DERIVING_MODE -> CodeGenType -> m ClientMethod
deriveFromJSONMethod DERIVING_MODE
SCALAR_MODE CodeGenType
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> ClientMethod
FunctionNameMethod 'scalarFromJSON
deriveFromJSONMethod DERIVING_MODE
ENUM_MODE CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgTypeName :: CodeGenType -> CodeGenTypeName
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgDerivations :: CodeGenType -> [DerivingClass]
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
..} =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    ValueMatch -> ClientMethod
MatchMethod forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (CodeGenTypeName -> MValue
fromJSONEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenConstructor -> CodeGenTypeName
constructorName) [CodeGenConstructor]
cgConstructors
        forall a. Semigroup a => a -> a -> a
<> [String -> Name -> MValue
MFunction String
"v" 'invalidConstructorError]
deriveFromJSONMethod DERIVING_MODE
_ CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenType -> CodeGenTypeName
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgDerivations :: CodeGenType -> [DerivingClass]
..} = forall (m :: * -> *) a. MonadFail m => CodeGenTypeName -> m a
emptyTypeError CodeGenTypeName
cgTypeName

defField :: CodeGenField -> AesonField
defField :: CodeGenField -> AesonField
defField CodeGenField {Bool
[FIELD_TYPE_WRAPPER]
FieldName
TypeName
fieldName :: CodeGenField -> FieldName
fieldType :: CodeGenField -> TypeName
wrappers :: CodeGenField -> [FIELD_TYPE_WRAPPER]
fieldIsNullable :: CodeGenField -> Bool
fieldIsNullable :: Bool
wrappers :: [FIELD_TYPE_WRAPPER]
fieldType :: TypeName
fieldName :: FieldName
..} = (forall a. ToName a => a -> Name
toName (String
"v" :: String), Bool -> Name
bindField Bool
fieldIsNullable, FieldName
fieldName)

bindField :: Bool -> Name
bindField :: Bool -> Name
bindField Bool
nullable
  | Bool
nullable = '(.:?)
  | Bool
otherwise = '(.:)

deriveToJSONMethod :: MonadFail m => DERIVING_MODE -> CodeGenType -> m (MethodArgument, ClientMethod)
deriveToJSONMethod :: forall (m :: * -> *).
MonadFail m =>
DERIVING_MODE -> CodeGenType -> m (MethodArgument, ClientMethod)
deriveToJSONMethod DERIVING_MODE
SCALAR_MODE CodeGenType
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (MethodArgument
NoArgument, Name -> ClientMethod
FunctionNameMethod 'scalarToJSON)
deriveToJSONMethod DERIVING_MODE
_ CodeGenType {cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgConstructors = [], [DerivingClass]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenType -> CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
..} = forall (m :: * -> *) a. MonadFail m => CodeGenTypeName -> m a
emptyTypeError CodeGenTypeName
cgTypeName
deriveToJSONMethod DERIVING_MODE
ENUM_MODE CodeGenType {[CodeGenConstructor]
cgConstructors :: [CodeGenConstructor]
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgConstructors} =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( MethodArgument
NoArgument,
      ValueMatch -> ClientMethod
MatchMethod forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (CodeGenTypeName -> MValue
toJSONEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenConstructor -> CodeGenTypeName
constructorName) [CodeGenConstructor]
cgConstructors
    )
deriveToJSONMethod DERIVING_MODE
_ CodeGenType {cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgConstructors = [CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorFields :: [CodeGenField]
constructorName :: CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
..}]} =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Name -> [Name] -> MethodArgument
DestructArgument (forall a. ToName a => a -> Name
toName CodeGenTypeName
constructorName) (forall a b. (a -> b) -> [a] -> [b]
map (\(FieldName
_, Name
_, Name
v) -> Name
v) [(FieldName, Name, Name)]
entries),
      Name -> [(FieldName, Name, Name)] -> ClientMethod
ToJSONObjectMethod 'omitNulls [(FieldName, Name, Name)]
entries
    )
  where
    entries :: [(FieldName, Name, Name)]
entries = forall a b. (a -> b) -> [a] -> [b]
map CodeGenField -> (FieldName, Name, Name)
mkEntry [CodeGenField]
constructorFields
    mkEntry :: CodeGenField -> (FieldName, Name, Name)
mkEntry CodeGenField {FieldName
fieldName :: FieldName
fieldName :: CodeGenField -> FieldName
fieldName} =
      ( FieldName
fieldName,
        '(.=),
        forall a. ToName a => a -> Name
toName forall a b. (a -> b) -> a -> b
$ TypeName -> FieldName -> FieldName
camelCaseFieldName (CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
constructorName) FieldName
fieldName
      )
deriveToJSONMethod DERIVING_MODE
_ CodeGenType
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Input Unions are not yet supported"

toJSONEnum :: CodeGenTypeName -> MValue
toJSONEnum :: CodeGenTypeName -> MValue
toJSONEnum CodeGenTypeName
name = TypeName -> TypeName -> MValue
MTo (CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
name) (CodeGenTypeName -> TypeName
typename CodeGenTypeName
name)

fromJSONEnum :: CodeGenTypeName -> MValue
fromJSONEnum :: CodeGenTypeName -> MValue
fromJSONEnum CodeGenTypeName
name = TypeName -> TypeName -> MValue
MFrom (CodeGenTypeName -> TypeName
typename CodeGenTypeName
name) (CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
name)

deriveToJSON :: MonadFail m => DERIVING_MODE -> CodeGenType -> m (TypeClassInstance ClientMethod)
deriveToJSON :: forall (m :: * -> *).
MonadFail m =>
DERIVING_MODE -> CodeGenType -> m (TypeClassInstance ClientMethod)
deriveToJSON DERIVING_MODE
mode CodeGenType
cType = do
  (MethodArgument
args, ClientMethod
expr) <- forall (m :: * -> *).
MonadFail m =>
DERIVING_MODE -> CodeGenType -> m (MethodArgument, ClientMethod)
deriveToJSONMethod DERIVING_MODE
mode CodeGenType
cType
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    TypeClassInstance
      { typeClassName :: Name
typeClassName = ''ToJSON,
        typeClassContext :: [(Name, Name)]
typeClassContext = [],
        typeClassTarget :: CodeGenTypeName
typeClassTarget = CodeGenType -> CodeGenTypeName
cgTypeName CodeGenType
cType,
        assoc :: [(Name, AssociatedType)]
assoc = [],
        typeClassMethods :: [(Name, MethodArgument, ClientMethod)]
typeClassMethods = [('toJSON, MethodArgument
args, ClientMethod
expr)]
      }

mkFromJSON :: CodeGenTypeName -> body -> TypeClassInstance body
mkFromJSON :: forall body. CodeGenTypeName -> body -> TypeClassInstance body
mkFromJSON CodeGenTypeName
typeClassTarget body
expr =
  TypeClassInstance
    { typeClassName :: Name
typeClassName = ''FromJSON,
      typeClassContext :: [(Name, Name)]
typeClassContext = [],
      typeClassTarget :: CodeGenTypeName
typeClassTarget = CodeGenTypeName
typeClassTarget,
      assoc :: [(Name, AssociatedType)]
assoc = [],
      typeClassMethods :: [(Name, MethodArgument, body)]
typeClassMethods = [('parseJSON, MethodArgument
NoArgument, body
expr)]
    }

deriveFromJSON :: MonadFail m => DERIVING_MODE -> CodeGenType -> m (TypeClassInstance ClientMethod)
deriveFromJSON :: forall (m :: * -> *).
MonadFail m =>
DERIVING_MODE -> CodeGenType -> m (TypeClassInstance ClientMethod)
deriveFromJSON DERIVING_MODE
mode CodeGenType
cType = forall body. CodeGenTypeName -> body -> TypeClassInstance body
mkFromJSON (CodeGenType -> CodeGenTypeName
cgTypeName CodeGenType
cType) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
DERIVING_MODE -> CodeGenType -> m ClientMethod
deriveFromJSONMethod DERIVING_MODE
mode CodeGenType
cType

emptyTypeError :: MonadFail m => CodeGenTypeName -> m a
emptyTypeError :: forall (m :: * -> *) a. MonadFail m => CodeGenTypeName -> m a
emptyTypeError CodeGenTypeName
name = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall b a. (Show a, IsString b) => a -> b
show forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
internal (GQLError
"Type " forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg (CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
name) forall a. Semigroup a => a -> a -> a
<> GQLError
" Should Have at least one Constructor")