{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.TH.Declare.GQLType
  ( deriveGQLType,
  )
where

import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConfig (..),
    GQLTypeDefinition (..),
    Kind (..),
    ServerConstructorDefinition (constructorName),
    ServerDirectiveUsage (..),
    ServerTypeDefinition (..),
    TypeValue (..),
    unpackName,
  )
import Data.Morpheus.CodeGen.Internal.TH
  ( ToName (..),
    apply,
    applyVars,
    typeInstanceDec,
  )
import Data.Morpheus.Kind
  ( SCALAR,
    TYPE,
  )
import Data.Morpheus.Server.TH.Utils
  ( ServerDec,
    funDProxy,
    mkTypeableConstraints,
    renderTypeVars,
  )
import Data.Morpheus.Server.Types.GQLType
  ( enumDirective,
    fieldDirective,
    typeDirective,
  )
import Data.Morpheus.Server.Types.Internal
  ( dropNamespaceOptions,
  )
import Data.Morpheus.Types
  ( GQLType (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    TypeKind (..),
  )
import qualified Data.Text as T
import Language.Haskell.TH
  ( Dec,
    DecQ,
    ExpQ,
    FieldExp,
    Name,
    Q,
    Type (ConT),
    appE,
    conE,
    instanceD,
    listE,
    litE,
    recConE,
    stringL,
  )
import Relude hiding (toString)

deriveGQLType :: ServerTypeDefinition -> ServerDec [Dec]
deriveGQLType :: ServerTypeDefinition -> ServerDec [Dec]
deriveGQLType
  ServerTypeDefinition
    { Text
tName :: ServerTypeDefinition -> Text
tName :: Text
tName,
      TypeKind
tKind :: ServerTypeDefinition -> TypeKind
tKind :: TypeKind
tKind,
      [Text]
typeParameters :: ServerTypeDefinition -> [Text]
typeParameters :: [Text]
typeParameters,
      Maybe GQLTypeDefinition
typeGQLType :: ServerTypeDefinition -> Maybe GQLTypeDefinition
typeGQLType :: Maybe GQLTypeDefinition
typeGQLType
    } = do
    let typeVars :: [Name]
typeVars = [Text] -> [Name]
renderTypeVars [Text]
typeParameters
    let constrains :: CxtQ
constrains = [Name] -> CxtQ
mkTypeableConstraints [Name]
typeVars
    let typeSignature :: Q Type
typeSignature = forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply ''GQLType [forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
 ToVar var res) =>
con -> [var] -> res
applyVars Text
tName [Name]
typeVars]
    [Q Dec]
methods <- Text
-> TypeKind
-> [Name]
-> Maybe GQLTypeDefinition
-> ServerDec [Q Dec]
defineMethods Text
tName TypeKind
tKind [Name]
typeVars Maybe GQLTypeDefinition
typeGQLType
    Dec
gqlTypeDeclaration <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD CxtQ
constrains Q Type
typeSignature [Q Dec]
methods)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
gqlTypeDeclaration]
deriveGQLType DirectiveTypeDefinition {[DerivingClass]
[DirectiveLocation]
GQLTypeDefinition
ServerConstructorDefinition
directiveConstructor :: ServerTypeDefinition -> ServerConstructorDefinition
directiveDerives :: ServerTypeDefinition -> [DerivingClass]
directiveLocations :: ServerTypeDefinition -> [DirectiveLocation]
directiveGQLType :: ServerTypeDefinition -> GQLTypeDefinition
directiveGQLType :: GQLTypeDefinition
directiveLocations :: [DirectiveLocation]
directiveDerives :: [DerivingClass]
directiveConstructor :: ServerConstructorDefinition
..} = do
  let typeVars :: [Name]
typeVars = [] :: [Name]
  let tName :: Text
tName = forall a (t :: NAME). NamePacking a => Name t -> a
unpackName (ServerConstructorDefinition -> TypeName
constructorName ServerConstructorDefinition
directiveConstructor)
  let constrains :: CxtQ
constrains = [Name] -> CxtQ
mkTypeableConstraints [Name]
typeVars
  let typeSignature :: Q Type
typeSignature = forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply ''GQLType [forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
 ToVar var res) =>
con -> [var] -> res
applyVars Text
tName [Name]
typeVars]
  [Q Dec]
methods <- Text
-> TypeKind
-> [Name]
-> Maybe GQLTypeDefinition
-> ServerDec [Q Dec]
defineMethods Text
tName TypeKind
KindInputObject [Name]
typeVars (forall a. a -> Maybe a
Just GQLTypeDefinition
directiveGQLType)
  Dec
gqlTypeDeclaration <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD CxtQ
constrains Q Type
typeSignature [Q Dec]
methods)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
gqlTypeDeclaration]
deriveGQLType ServerTypeDefinition
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

defineTypeOptions :: Text -> TypeKind -> ServerDec [DecQ]
defineTypeOptions :: Text -> TypeKind -> ServerDec [Q Dec]
defineTypeOptions Text
tName TypeKind
kind = do
  CodeGenConfig {Bool
namespace :: CodeGenConfig -> Bool
namespace :: Bool
namespace} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(Name, ExpQ)] -> [Q Dec]
funDProxy [('typeOptions, [|dropNamespaceOptions kind tName|]) | Bool
namespace]

defineMethods ::
  Text ->
  TypeKind ->
  [Name] ->
  Maybe GQLTypeDefinition ->
  ServerDec [Q Dec]
defineMethods :: Text
-> TypeKind
-> [Name]
-> Maybe GQLTypeDefinition
-> ServerDec [Q Dec]
defineMethods Text
tName TypeKind
kind [Name]
_ Maybe GQLTypeDefinition
Nothing = Text -> TypeKind -> ServerDec [Q Dec]
defineTypeOptions Text
tName TypeKind
kind
defineMethods
  Text
tName
  TypeKind
kind
  [Name]
typeParameters
  ( Just
      GQLTypeDefinition
        { Maybe Text
gqlTypeDescription :: GQLTypeDefinition -> Maybe Text
gqlTypeDescription :: Maybe Text
gqlTypeDescription,
          Map Text Text
gqlTypeDescriptions :: GQLTypeDefinition -> Map Text Text
gqlTypeDescriptions :: Map Text Text
gqlTypeDescriptions,
          Map Text (Value CONST)
gqlTypeDefaultValues :: GQLTypeDefinition -> Map Text (Value CONST)
gqlTypeDefaultValues :: Map Text (Value CONST)
gqlTypeDefaultValues,
          [ServerDirectiveUsage]
gqlTypeDirectiveUses :: GQLTypeDefinition -> [ServerDirectiveUsage]
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses,
          Kind
gqlKind :: GQLTypeDefinition -> Kind
gqlKind :: Kind
gqlKind
        }
    ) = do
    [Q Dec]
options <- Text -> TypeKind -> ServerDec [Q Dec]
defineTypeOptions Text
tName TypeKind
kind
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Q Dec
typeFamilies forall a. a -> [a] -> [a]
: [Q Dec]
functions forall a. Semigroup a => a -> a -> a
<> [Q Dec]
options)
    where
      functions :: [Q Dec]
functions =
        [(Name, ExpQ)] -> [Q Dec]
funDProxy
          [ ('description, [|gqlTypeDescription|]),
            ('getDescriptions, [|gqlTypeDescriptions|]),
            ('defaultValues, [|gqlTypeDefaultValues|]),
            ('directives, [ServerDirectiveUsage] -> ExpQ
renderDirectiveUsages [ServerDirectiveUsage]
gqlTypeDirectiveUses)
          ]

      typeFamilies :: Q Dec
typeFamilies = do
        Type
currentType <- forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
 ToVar var res) =>
con -> [var] -> res
applyVars Text
tName [Name]
typeParameters
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type -> Type -> Dec
typeInstanceDec ''KIND Type
currentType (Name -> Type
ConT (Kind -> Name
kindName Kind
gqlKind))

kindName :: Kind -> Name
kindName :: Kind -> Name
kindName Kind
Scalar = ''SCALAR
kindName Kind
Type = ''TYPE

renderDirectiveUsages :: [ServerDirectiveUsage] -> ExpQ
renderDirectiveUsages :: [ServerDirectiveUsage] -> ExpQ
renderDirectiveUsages =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|(<>)|] forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerDirectiveUsage -> ExpQ
renderDirectiveUsage)
    [|mempty|]

renderDirectiveUsage :: ServerDirectiveUsage -> ExpQ
renderDirectiveUsage :: ServerDirectiveUsage -> ExpQ
renderDirectiveUsage (TypeDirectiveUsage TypeValue
x) = [|typeDirective $(renderValue x)|]
renderDirectiveUsage (FieldDirectiveUsage FieldName
field TypeValue
x) = [|fieldDirective field $(renderValue x)|]
renderDirectiveUsage (EnumDirectiveUsage TypeName
enum TypeValue
x) = [|enumDirective enum $(renderValue x)|]

renderField :: (FieldName, TypeValue) -> Q FieldExp
renderField :: (FieldName, TypeValue) -> Q FieldExp
renderField (FieldName
fName, TypeValue
fValue) = do
  Exp
v <- TypeValue -> ExpQ
renderValue TypeValue
fValue
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. ToName a => a -> Name
toName FieldName
fName, Exp
v)

renderValue :: TypeValue -> ExpQ
renderValue :: TypeValue -> ExpQ
renderValue (TypeValueObject TypeName
name [(FieldName, TypeValue)]
xs) = forall (m :: * -> *). Quote m => Name -> [m FieldExp] -> m Exp
recConE (forall a. ToName a => a -> Name
toName TypeName
name) (forall a b. (a -> b) -> [a] -> [b]
map (FieldName, TypeValue) -> Q FieldExp
renderField [(FieldName, TypeValue)]
xs)
renderValue (TypeValueNumber Double
x) = [|x|]
renderValue (TypeValueString Text
x) = forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL (Text -> String
T.unpack Text
x))
renderValue (TypeValueBool Bool
_) = [|x|]
renderValue (TypedValueMaybe (Just TypeValue
x)) = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Just) (TypeValue -> ExpQ
renderValue TypeValue
x)
renderValue (TypedValueMaybe Maybe TypeValue
Nothing) = forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Nothing
renderValue (TypeValueList [TypeValue]
xs) = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TypeValue -> ExpQ
renderValue [TypeValue]
xs