{-# 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 (..),
    Printable (..),
    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 (..),
    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) = TypeClassInstance ClientMethod -> ClientDeclaration
InstanceDeclaration 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 (ToJSONClass DERIVING_MODE
mode CodeGenType
clientDef) = TypeClassInstance ClientMethod -> ClientDeclaration
InstanceDeclaration 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
$ TypeClassInstance ClientMethod -> ClientDeclaration
InstanceDeclaration (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, Printable -> ClientMethod
PrintableMethod forall a b. (a -> b) -> a -> b
$ forall a. (Show a, Lift a) => a -> Printable
Printable TypeName
requestName),
        ('__query, MethodArgument
ProxyArgument, Printable -> ClientMethod
PrintableMethod forall a b. (a -> b) -> a -> b
$ forall a. (Show a, Lift a) => a -> Printable
Printable String
requestQuery),
        ('__type, MethodArgument
ProxyArgument, Printable -> ClientMethod
PrintableMethod forall a b. (a -> b) -> a -> b
$ forall a. (Show a, Lift a) => a -> Printable
Printable 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
_ CodeGenType {cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgConstructors = [], [DerivingClass]
CodeGenTypeName
cgTypeName :: CodeGenType -> CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenTypeName
..} = forall (m :: * -> *) a. MonadFail m => CodeGenTypeName -> m a
emptyTypeError CodeGenTypeName
cgTypeName
deriveFromJSONMethod DERIVING_MODE
ENUM_MODE CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenType -> CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgConstructors :: CodeGenType -> [CodeGenConstructor]
..} =
  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 {cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgConstructors = [CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorFields :: [CodeGenField]
constructorName :: CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
..}]} = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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)
deriveFromJSONMethod DERIVING_MODE
_ CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenType -> CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgConstructors :: CodeGenType -> [CodeGenConstructor]
..} = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [([UnionPat], (Name, [AesonField]))] -> ClientMethod
FromJSONUnionMethod forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map CodeGenConstructor -> ([UnionPat], (Name, [AesonField]))
f [CodeGenConstructor]
cgConstructors forall a. Semigroup a => a -> a -> a
<> [([UnionPat], (Name, [AesonField]))]
elseCondition
  where
    interfaceConstructor :: [(Name, [AesonField])]
interfaceConstructor = forall a b. (a -> b) -> [a] -> [b]
map CodeGenConstructor -> (Name, [AesonField])
genObj (forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((CodeGenTypeName -> TypeName
typename CodeGenTypeName
cgTypeName forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenTypeName -> TypeName
typename forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenConstructor -> CodeGenTypeName
constructorName) [CodeGenConstructor]
cgConstructors)
    elseCondition :: [([UnionPat], (Name, [AesonField]))]
elseCondition = forall a b. (a -> b) -> [a] -> [b]
map ([String -> UnionPat
UVar String
"_", String -> UnionPat
UVar String
"v"],) [(Name, [AesonField])]
interfaceConstructor
    f :: CodeGenConstructor -> ([UnionPat], (Name, [AesonField]))
f cons :: CodeGenConstructor
cons@CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorFields :: [CodeGenField]
constructorName :: CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorName :: CodeGenConstructor -> CodeGenTypeName
..} = ([TypeName -> UnionPat
UString forall a b. (a -> b) -> a -> b
$ CodeGenTypeName -> TypeName
typename CodeGenTypeName
constructorName, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CodeGenField]
constructorFields then String -> UnionPat
UVar String
"_" else String -> UnionPat
UVar String
"v"], CodeGenConstructor -> (Name, [AesonField])
genObj CodeGenConstructor
cons)

genObj :: CodeGenConstructor -> (Name, [AesonField])
genObj :: CodeGenConstructor -> (Name, [AesonField])
genObj CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorFields :: [CodeGenField]
constructorName :: CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorName :: CodeGenConstructor -> CodeGenTypeName
..} = (forall a. ToName a => a -> Name
toName CodeGenTypeName
constructorName, forall a b. (a -> b) -> [a] -> [b]
map CodeGenField -> AesonField
defField [CodeGenField]
constructorFields)

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
constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorName :: CodeGenConstructor -> CodeGenTypeName
..}]} =
  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)]
      }

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 = do
  ClientMethod
expr <- forall (m :: * -> *).
MonadFail m =>
DERIVING_MODE -> CodeGenType -> m ClientMethod
deriveFromJSONMethod DERIVING_MODE
mode CodeGenType
cType
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    TypeClassInstance
      { typeClassName :: Name
typeClassName = ''FromJSON,
        typeClassContext :: [(Name, Name)]
typeClassContext = [],
        typeClassTarget :: CodeGenTypeName
typeClassTarget = CodeGenType -> CodeGenTypeName
cgTypeName CodeGenType
cType,
        assoc :: [(Name, AssociatedType)]
assoc = [],
        typeClassMethods :: [(Name, MethodArgument, ClientMethod)]
typeClassMethods = [('parseJSON, MethodArgument
NoArgument, ClientMethod
expr)]
      }

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")