{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.TH.Declare.Type
  ( declareType,
  )
where

import Data.Morpheus.CodeGen.Internal.AST
  ( DerivingClass (..),
    FIELD_TYPE_WRAPPER (..),
    ServerConstructorDefinition (..),
    ServerFieldDefinition (..),
    ServerTypeDefinition (..),
    unpackName,
  )
import Data.Morpheus.CodeGen.Internal.TH
  ( apply,
    declareTypeRef,
    toCon,
    toName,
    wrappedType,
  )
import Data.Morpheus.Server.TH.Utils
  ( m',
    m_,
    renderTypeVars,
  )
import Data.Morpheus.Types
  ( Arg,
    SubscriptionField,
    TypeGuard,
  )
import Data.Morpheus.Types.Internal.AST
  ( TypeKind (..),
  )
import qualified Data.Text as T
import Language.Haskell.TH
import Relude hiding (Type)

declareType :: ServerTypeDefinition -> [Dec]
declareType :: ServerTypeDefinition -> [Dec]
declareType (ServerInterfaceDefinition TypeName
name TypeName
interfaceName TypeName
unionName) =
  [ Name -> [TyVarBndr ()] -> Type -> Dec
TySynD
      (forall a. ToName a => a -> Name
toName TypeName
name)
#if MIN_VERSION_template_haskell(2,17,0)
      [forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
m_ ()]
#else
      [PlainTV m_]
#endif
      (forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply ''TypeGuard [forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply TypeName
interfaceName [Type
m'], forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply TypeName
unionName [Type
m']])
  ]
declareType ServerTypeDefinition {tKind :: ServerTypeDefinition -> TypeKind
tKind = TypeKind
KindScalar} = []
declareType
  ServerTypeDefinition
    { Text
tName :: ServerTypeDefinition -> Text
tName :: Text
tName,
      [ServerConstructorDefinition]
tCons :: ServerTypeDefinition -> [ServerConstructorDefinition]
tCons :: [ServerConstructorDefinition]
tCons,
      [DerivingClass]
derives :: ServerTypeDefinition -> [DerivingClass]
derives :: [DerivingClass]
derives,
      [Text]
typeParameters :: ServerTypeDefinition -> [Text]
typeParameters :: [Text]
typeParameters
    } = [[Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] (forall a. ToName a => a -> Name
toName Text
tName) [TyVarBndr ()]
vars forall a. Maybe a
Nothing [Con]
cons [DerivClause
derivingClause]]
    where
      derivingClause :: DerivClause
derivingClause = Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause forall a. Maybe a
Nothing (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
ConT forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivingClass -> Name
genName) [DerivingClass]
derives)
      cons :: [Con]
cons = forall a b. (a -> b) -> [a] -> [b]
map ServerConstructorDefinition -> Con
declareCons [ServerConstructorDefinition]
tCons

#if MIN_VERSION_template_haskell(2,17,0)
      vars :: [TyVarBndr ()]
vars = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall flag. Name -> flag -> TyVarBndr flag
PlainTV ()) ([Text] -> [Name]
renderTypeVars [Text]
typeParameters)
#else
      vars = map PlainTV (renderTypeVars typeParameters)
#endif

genName :: DerivingClass -> Name
genName :: DerivingClass -> Name
genName DerivingClass
GENERIC = ''Generic
genName DerivingClass
SHOW = ''Show

declareCons :: ServerConstructorDefinition -> Con
declareCons :: ServerConstructorDefinition -> Con
declareCons ServerConstructorDefinition {TypeName
constructorName :: ServerConstructorDefinition -> TypeName
constructorName :: TypeName
constructorName, [ServerFieldDefinition]
constructorFields :: ServerConstructorDefinition -> [ServerFieldDefinition]
constructorFields :: [ServerFieldDefinition]
constructorFields} =
  Name -> [VarBangType] -> Con
RecC
    (forall a. ToName a => a -> Name
toName TypeName
constructorName)
    (forall a b. (a -> b) -> [a] -> [b]
map ServerFieldDefinition -> VarBangType
declareField [ServerFieldDefinition]
constructorFields)

declareField :: ServerFieldDefinition -> (Name, Bang, Type)
declareField :: ServerFieldDefinition -> VarBangType
declareField
  ServerFieldDefinition
    { FieldName
fieldName :: ServerFieldDefinition -> FieldName
fieldName :: FieldName
fieldName,
      Text
fieldType :: ServerFieldDefinition -> Text
fieldType :: Text
fieldType,
      [FIELD_TYPE_WRAPPER]
wrappers :: ServerFieldDefinition -> [FIELD_TYPE_WRAPPER]
wrappers :: [FIELD_TYPE_WRAPPER]
wrappers
    } =
    ( forall a. ToName a => a -> Name
toName FieldName
fieldName,
      SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,
      forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FIELD_TYPE_WRAPPER -> Type -> Type
applyWrapper (forall a b. ToCon a b => a -> b
toCon Text
fieldType) [FIELD_TYPE_WRAPPER]
wrappers
    )

applyWrapper :: FIELD_TYPE_WRAPPER -> Type -> Type
applyWrapper :: FIELD_TYPE_WRAPPER -> Type -> Type
applyWrapper FIELD_TYPE_WRAPPER
PARAMETRIZED = (Type -> Type -> Type
`AppT` Type
m')
applyWrapper FIELD_TYPE_WRAPPER
MONAD = Type -> Type -> Type
AppT Type
m'
applyWrapper FIELD_TYPE_WRAPPER
SUBSCRIPTION = Type -> Type -> Type
AppT (Name -> Type
ConT ''SubscriptionField)
applyWrapper (ARG TypeName
typeName) = Type -> Name -> Type -> Type
InfixT (Name -> Type
ConT (forall a. ToName a => a -> Name
toName TypeName
typeName)) ''Function
applyWrapper (GQL_WRAPPER TypeWrapper
wrappers) = TypeWrapper -> Type -> Type
wrappedType TypeWrapper
wrappers
applyWrapper (TAGGED_ARG FieldName
fieldName TypeRef
typeRef) = Type -> Name -> Type -> Type
InfixT Type
arg ''Function
  where
    arg :: Type
arg =
      Type -> Type -> Type
AppT
        ( Type -> Type -> Type
AppT
            (Name -> Type
ConT ''Arg)
            (TyLit -> Type
LitT forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fieldName)
        )
        ((TypeName -> Type) -> TypeRef -> Type
declareTypeRef forall a b. ToCon a b => a -> b
toCon TypeRef
typeRef)

type Function = (->)