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

module Data.Morpheus.Client.Printing.TH
  ( printDeclarations,
  )
where

import Data.Aeson
  ( FromJSON (parseJSON),
    KeyValue ((.=)),
    ToJSON (toJSON),
    withObject,
  )
import Data.Morpheus.Client.Fetch.RequestType
  ( RequestType (..),
  )
import Data.Morpheus.Client.Internal.TH
  ( declareIfNotDeclared,
    decodeObjectE,
    deriveIfNotDefined,
    failExp,
    matchWith,
    mkFieldsE,
  )
import Data.Morpheus.Client.Internal.Types
  ( ClientDeclaration (..),
    DERIVING_MODE (..),
    RequestTypeDefinition (..),
  )
import Data.Morpheus.Client.Internal.Utils
  ( emptyTypeError,
    omitNulls,
    takeValueType,
  )
import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConstructor (..),
    CodeGenType (..),
    CodeGenTypeName (..),
    getFullName,
  )
import Data.Morpheus.CodeGen.TH
  ( PrintDec (printDec),
    ToString (..),
    destructConstructor,
    printTypeClass,
    toCon,
    toName,
    toString,
    toVar,
    v',
    _',
  )
import Data.Morpheus.Types.GQLScalar
  ( scalarFromJSON,
    scalarToJSON,
  )
import Data.Morpheus.Types.Internal.AST
  ( TypeName,
  )
import Language.Haskell.TH
  ( Dec,
    DecQ,
    Exp (..),
    ExpQ,
    PatQ,
    Q,
    appE,
    tupP,
  )
import Relude hiding (ToString, toString)

printDeclarations :: [ClientDeclaration] -> Q [Dec]
printDeclarations :: [ClientDeclaration] -> Q [Dec]
printDeclarations [ClientDeclaration]
clientType = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ClientDeclaration -> Q [Dec]
typeDeclarations [ClientDeclaration]
clientType

typeDeclarations :: ClientDeclaration -> Q [Dec]
typeDeclarations :: ClientDeclaration -> Q [Dec]
typeDeclarations (FromJSONClass DERIVING_MODE
mode CodeGenType
clientDef) = (CodeGenType -> Q Dec) -> Name -> CodeGenType -> Q [Dec]
deriveIfNotDefined (DERIVING_MODE -> CodeGenType -> Q Dec
deriveFromJSON DERIVING_MODE
mode) ''FromJSON CodeGenType
clientDef
typeDeclarations (ToJSONClass DERIVING_MODE
mode CodeGenType
clientDef) = (CodeGenType -> Q Dec) -> Name -> CodeGenType -> Q [Dec]
deriveIfNotDefined (DERIVING_MODE -> CodeGenType -> Q Dec
deriveToJSON DERIVING_MODE
mode) ''ToJSON CodeGenType
clientDef
typeDeclarations (ClientType CodeGenType
c) = forall a. (CodeGenType -> a) -> CodeGenType -> Q [a]
declareIfNotDeclared forall a. PrintDec a => a -> Dec
printDec CodeGenType
c
typeDeclarations (RequestTypeClass RequestTypeDefinition {String
OperationType
TypeName
requestQuery :: RequestTypeDefinition -> String
requestType :: RequestTypeDefinition -> OperationType
requestArgs :: RequestTypeDefinition -> TypeName
requestName :: RequestTypeDefinition -> TypeName
requestQuery :: String
requestType :: OperationType
requestArgs :: TypeName
requestName :: TypeName
..}) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
-> Name
-> Q Type
-> [(Name, Type)]
-> [(Name, [PatQ], Q Exp)]
-> Q Dec
printTypeClass [] ''RequestType (forall a b. ToCon a b => a -> b
toCon TypeName
requestName) [(''RequestArgs, forall a b. ToCon a b => a -> b
toCon TypeName
requestArgs)] [(Name, [PatQ], Q Exp)]
methods
  where
    methods :: [(Name, [PatQ], Q Exp)]
methods =
      [ ('__name, [PatQ
_'], [|requestName|]),
        ('__query, [PatQ
_'], [|requestQuery|]),
        ('__type, [PatQ
_'], [|requestType|])
      ]

-- UTILS

mkFromJSON :: CodeGenTypeName -> ExpQ -> DecQ
mkFromJSON :: CodeGenTypeName -> Q Exp -> Q Dec
mkFromJSON CodeGenTypeName
name Q Exp
expr = [(Name, Name)]
-> Name
-> Q Type
-> [(Name, Type)]
-> [(Name, [PatQ], Q Exp)]
-> Q Dec
printTypeClass [] ''FromJSON (forall a b. ToCon a b => a -> b
toCon (forall a. ToName a => a -> Name
toName CodeGenTypeName
name)) [] [('parseJSON, [], Q Exp
expr)]

mkToJSON :: CodeGenTypeName -> [PatQ] -> ExpQ -> DecQ
mkToJSON :: CodeGenTypeName -> [PatQ] -> Q Exp -> Q Dec
mkToJSON CodeGenTypeName
name [PatQ]
args Q Exp
expr = [(Name, Name)]
-> Name
-> Q Type
-> [(Name, Type)]
-> [(Name, [PatQ], Q Exp)]
-> Q Dec
printTypeClass [] ''ToJSON (forall a b. ToCon a b => a -> b
toCon forall a b. (a -> b) -> a -> b
$ forall a. ToName a => a -> Name
toName CodeGenTypeName
name) [] [('toJSON, [PatQ]
args, Q Exp
expr)]

originalLit :: ToString TypeName a => CodeGenTypeName -> Q a
originalLit :: forall a. ToString TypeName a => CodeGenTypeName -> Q a
originalLit = forall a b. ToString a b => a -> b
toString forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenTypeName -> TypeName
typename

-- FromJSON
deriveFromJSON :: DERIVING_MODE -> CodeGenType -> DecQ
deriveFromJSON :: DERIVING_MODE -> CodeGenType -> Q Dec
deriveFromJSON DERIVING_MODE
SCALAR_MODE CodeGenType {CodeGenTypeName
cgTypeName :: CodeGenType -> CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName} = CodeGenTypeName -> Q Exp -> Q Dec
mkFromJSON CodeGenTypeName
cgTypeName [|scalarFromJSON|]
deriveFromJSON DERIVING_MODE
_ CodeGenType {cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgConstructors = [], [DerivingClass]
CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenType -> CodeGenTypeName
..} = forall (m :: * -> *) a. MonadFail m => CodeGenTypeName -> m a
emptyTypeError CodeGenTypeName
cgTypeName
deriveFromJSON DERIVING_MODE
ENUM_MODE CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgTypeName :: CodeGenType -> CodeGenTypeName
..} =
  CodeGenTypeName -> Q Exp -> Q Dec
mkFromJSON CodeGenTypeName
cgTypeName (forall t.
Maybe (PatQ, Q Exp) -> (t -> (PatQ, Q Exp)) -> [t] -> Q Exp
matchWith (forall a. a -> Maybe a
Just (forall a. ToVar Name a => a
v', Q Exp
failExp)) CodeGenConstructor -> (PatQ, Q Exp)
fromJSONEnum [CodeGenConstructor]
cgConstructors)
deriveFromJSON DERIVING_MODE
_ CodeGenType {cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgConstructors = [CodeGenConstructor
cons], [DerivingClass]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgTypeName :: CodeGenType -> CodeGenTypeName
..} =
  CodeGenTypeName -> Q Exp -> Q Dec
mkFromJSON CodeGenTypeName
cgTypeName (CodeGenConstructor -> Q Exp
fromJSONObject CodeGenConstructor
cons)
deriveFromJSON DERIVING_MODE
_ typeD :: CodeGenType
typeD@CodeGenType {CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenType -> CodeGenTypeName
cgTypeName} =
  CodeGenTypeName -> Q Exp -> Q Dec
mkFromJSON CodeGenTypeName
cgTypeName (CodeGenType -> Q Exp
fromJSONUnion CodeGenType
typeD)

fromJSONEnum :: CodeGenConstructor -> (PatQ, ExpQ)
fromJSONEnum :: CodeGenConstructor -> (PatQ, Q Exp)
fromJSONEnum CodeGenConstructor {CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName} = (forall a. ToString TypeName a => CodeGenTypeName -> Q a
originalLit CodeGenTypeName
constructorName, forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall a b. ToVar a b => a -> b
toVar 'pure) (forall a b. ToCon a b => a -> b
toCon CodeGenTypeName
constructorName))

fromJSONObject :: CodeGenConstructor -> ExpQ
fromJSONObject :: CodeGenConstructor -> Q Exp
fromJSONObject con :: CodeGenConstructor
con@CodeGenConstructor {CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorName} = Exp -> Exp
withBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeGenConstructor -> Q Exp
decodeObjectE CodeGenConstructor
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 (CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
constructorName)

fromJSONUnion :: CodeGenType -> ExpQ
fromJSONUnion :: CodeGenType -> Q Exp
fromJSONUnion CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgTypeName :: CodeGenType -> CodeGenTypeName
..} = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall a b. ToVar a b => a -> b
toVar 'takeValueType) (forall t.
Maybe (PatQ, Q Exp) -> (t -> (PatQ, Q Exp)) -> [t] -> Q Exp
matchWith Maybe (PatQ, Q Exp)
elseCondition CodeGenConstructor -> (PatQ, Q Exp)
f [CodeGenConstructor]
cgConstructors)
  where
    elseCondition :: Maybe (PatQ, Q Exp)
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
. CodeGenConstructor -> Q Exp
decodeObjectE
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
    f :: CodeGenConstructor -> (PatQ, Q Exp)
f cons :: CodeGenConstructor
cons@CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorFields :: [CodeGenField]
constructorName :: CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
..} =
      ( forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [forall a. ToString TypeName a => CodeGenTypeName -> Q a
originalLit CodeGenTypeName
constructorName, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CodeGenField]
constructorFields then PatQ
_' else forall a. ToVar Name a => a
v'],
        CodeGenConstructor -> Q Exp
decodeObjectE CodeGenConstructor
cons
      )

-- ToJSON
deriveToJSON :: DERIVING_MODE -> CodeGenType -> DecQ
deriveToJSON :: DERIVING_MODE -> CodeGenType -> Q Dec
deriveToJSON DERIVING_MODE
SCALAR_MODE CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgTypeName :: CodeGenType -> CodeGenTypeName
..} = CodeGenTypeName -> [PatQ] -> Q Exp -> Q Dec
mkToJSON CodeGenTypeName
cgTypeName [] [|scalarToJSON|]
deriveToJSON DERIVING_MODE
_ CodeGenType {cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgConstructors = [], [DerivingClass]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgTypeName :: CodeGenType -> CodeGenTypeName
..} = forall (m :: * -> *) a. MonadFail m => CodeGenTypeName -> m a
emptyTypeError CodeGenTypeName
cgTypeName
deriveToJSON DERIVING_MODE
ENUM_MODE CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgTypeName :: CodeGenType -> CodeGenTypeName
..} =
  CodeGenTypeName -> [PatQ] -> Q Exp -> Q Dec
mkToJSON CodeGenTypeName
cgTypeName [] (forall t.
Maybe (PatQ, Q Exp) -> (t -> (PatQ, Q Exp)) -> [t] -> Q Exp
matchWith forall a. Maybe a
Nothing CodeGenConstructor -> (PatQ, Q Exp)
toJSONEnum [CodeGenConstructor]
cgConstructors)
deriveToJSON DERIVING_MODE
_ CodeGenType {cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgConstructors = [CodeGenConstructor
cons], [DerivingClass]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgTypeName :: CodeGenType -> CodeGenTypeName
..} =
  CodeGenTypeName -> [PatQ] -> Q Exp -> Q Dec
mkToJSON CodeGenTypeName
cgTypeName [CodeGenConstructor -> PatQ
destructConstructor CodeGenConstructor
cons] (CodeGenConstructor -> Q Exp
toJSONObject CodeGenConstructor
cons)
deriveToJSON DERIVING_MODE
_ CodeGenType
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Input Unions are not yet supported"

toJSONEnum :: CodeGenConstructor -> (PatQ, ExpQ)
toJSONEnum :: CodeGenConstructor -> (PatQ, Q Exp)
toJSONEnum CodeGenConstructor {CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorName} = (forall a b. ToCon a b => a -> b
toCon CodeGenTypeName
constructorName, forall a. ToString TypeName a => CodeGenTypeName -> Q a
originalLit CodeGenTypeName
constructorName)

toJSONObject :: CodeGenConstructor -> ExpQ
toJSONObject :: CodeGenConstructor -> Q Exp
toJSONObject CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorFields :: [CodeGenField]
constructorName :: CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorName :: CodeGenConstructor -> CodeGenTypeName
..} = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'omitNulls) (CodeGenTypeName -> Name -> [CodeGenField] -> Exp
mkFieldsE CodeGenTypeName
constructorName '(.=) [CodeGenField]
constructorFields)