{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.TH.Declare.GQLDirective
  ( deriveGQLDirective,
  )
where

import Data.Morpheus.CodeGen.Internal.AST
  ( ServerConstructorDefinition (..),
    ServerTypeDefinition (..),
    TypeName,
  )
import Data.Morpheus.CodeGen.Internal.TH
  ( apply,
    applyVars,
    typeInstanceDec,
  )
import Data.Morpheus.Server.TH.Utils
  ( ServerDec,
    mkTypeableConstraints,
  )
import Data.Morpheus.Server.Types.Directives
  ( GQLDirective (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( DirectiveLocation (..),
  )
import Language.Haskell.TH
  ( Dec,
    Name,
    Q,
    Type (..),
    instanceD,
  )
import Relude hiding (Type, toString)

noVars :: [Name]
noVars :: [Name]
noVars = []

deriveGQLDirective :: ServerTypeDefinition -> ServerDec [Dec]
deriveGQLDirective :: ServerTypeDefinition -> ServerDec [Dec]
deriveGQLDirective 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 constrains :: CxtQ
constrains = [Name] -> CxtQ
mkTypeableConstraints [Name]
noVars
  let tName :: TypeName
tName = ServerConstructorDefinition -> TypeName
constructorName ServerConstructorDefinition
directiveConstructor
  let typeSignature :: Q Type
typeSignature = forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply ''GQLDirective [forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
 ToVar var res) =>
con -> [var] -> res
applyVars TypeName
tName [Name]
noVars]
  [Q Dec]
methods <- TypeName -> [DirectiveLocation] -> ServerDec [Q Dec]
defineMethods (ServerConstructorDefinition -> TypeName
constructorName ServerConstructorDefinition
directiveConstructor) [DirectiveLocation]
directiveLocations
  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]
deriveGQLDirective ServerTypeDefinition
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

defineMethods :: TypeName -> [DirectiveLocation] -> ServerDec [Q Dec]
defineMethods :: TypeName -> [DirectiveLocation] -> ServerDec [Q Dec]
defineMethods TypeName
tName [DirectiveLocation]
locations = do
  let currentType :: Type
currentType = forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
 ToVar var res) =>
con -> [var] -> res
applyVars TypeName
tName [Name]
noVars
  let inst :: Dec
inst = Name -> Type -> Type -> Dec
typeInstanceDec ''DIRECTIVE_LOCATIONS Type
currentType ([DirectiveLocation] -> Type
promotedList [DirectiveLocation]
locations)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
inst]

locationName :: DirectiveLocation -> Name
locationName :: DirectiveLocation -> Name
locationName DirectiveLocation
QUERY = 'QUERY
locationName DirectiveLocation
MUTATION = 'MUTATION
locationName DirectiveLocation
SUBSCRIPTION = 'SUBSCRIPTION
locationName DirectiveLocation
FIELD = 'FIELD
locationName DirectiveLocation
FRAGMENT_DEFINITION = 'FRAGMENT_DEFINITION
locationName DirectiveLocation
FRAGMENT_SPREAD = 'FRAGMENT_SPREAD
locationName DirectiveLocation
INLINE_FRAGMENT = 'INLINE_FRAGMENT
locationName DirectiveLocation
SCHEMA = 'SCHEMA
locationName DirectiveLocation
SCALAR = 'SCALAR
locationName DirectiveLocation
OBJECT = 'OBJECT
locationName DirectiveLocation
FIELD_DEFINITION = 'FIELD_DEFINITION
locationName DirectiveLocation
ARGUMENT_DEFINITION = 'ARGUMENT_DEFINITION
locationName DirectiveLocation
INTERFACE = 'INTERFACE
locationName DirectiveLocation
UNION = 'UNION
locationName DirectiveLocation
ENUM = 'ENUM
locationName DirectiveLocation
ENUM_VALUE = 'ENUM_VALUE
locationName DirectiveLocation
INPUT_OBJECT = 'INPUT_OBJECT
locationName DirectiveLocation
INPUT_FIELD_DEFINITION = 'INPUT_FIELD_DEFINITION

promotedList :: [DirectiveLocation] -> Type
promotedList :: [DirectiveLocation] -> Type
promotedList =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    (Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
PromotedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirectiveLocation -> Name
locationName)
    Type
PromotedNilT