{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}

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

import Data.Morpheus.Internal.TH
  ( declareTypeRef,
    m',
    nameSpaceField,
    nameSpaceType,
    toName,
    tyConArgs,
  )
import Data.Morpheus.Server.Internal.TH.Types
  ( ServerDec,
    ServerDecContext (..),
    ServerTypeDefinition (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( ArgumentsDefinition (..),
    ConsD (..),
    FieldContent (..),
    FieldDefinition (..),
    FieldName (..),
    TRUE,
    TypeKind (..),
    TypeName (..),
    isOutput,
    isOutputObject,
    isSubscription,
  )
import Data.Morpheus.Types.Internal.Resolving
  ( SubscriptionField,
  )
import Language.Haskell.TH
import Relude hiding (Type)

declareType :: ServerTypeDefinition cat s -> ServerDec [Dec]
declareType :: ServerTypeDefinition cat s -> ServerDec [Dec]
declareType ServerTypeDefinition {tKind :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> TypeKind
tKind = TypeKind
KindScalar} = [Dec] -> ServerDec [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
declareType
  ServerTypeDefinition
    { TypeName
tName :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> TypeName
tName :: TypeName
tName,
      [ConsD cat s]
tCons :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> [ConsD cat s]
tCons :: [ConsD cat s]
tCons,
      TypeKind
tKind :: TypeKind
tKind :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> TypeKind
tKind
    } =
    do
      [Con]
cons <- TypeKind -> TypeName -> [ConsD cat s] -> ServerDec [Con]
forall (cat :: TypeCategory) (s :: Stage).
TypeKind -> TypeName -> [ConsD cat s] -> ServerDec [Con]
declareCons TypeKind
tKind TypeName
tName [ConsD cat s]
tCons
      let vars :: [TyVarBndr]
vars = (String -> TyVarBndr) -> [String] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> TyVarBndr
PlainTV (Name -> TyVarBndr) -> (String -> Name) -> String -> TyVarBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
forall a. ToName a => a -> Name
toName) (TypeKind -> [String]
tyConArgs TypeKind
tKind)
      [Dec] -> ServerDec [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD
            []
            (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
tName)
            [TyVarBndr]
vars
            Maybe Kind
forall a. Maybe a
Nothing
            [Con]
cons
            (TypeKind -> [DerivClause]
derive TypeKind
tKind)
        ]

derive :: TypeKind -> [DerivClause]
derive :: TypeKind -> [DerivClause]
derive TypeKind
tKind = [[Name] -> DerivClause
deriveClasses (''Generic Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
derivingList)]
  where
    derivingList :: [Name]
derivingList
      | TypeKind -> Bool
isOutput TypeKind
tKind = []
      | Bool
otherwise = [''Show]

deriveClasses :: [Name] -> DerivClause
deriveClasses :: [Name] -> DerivClause
deriveClasses [Name]
classNames = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
ConT [Name]
classNames)

declareCons ::
  TypeKind ->
  TypeName ->
  [ConsD cat s] ->
  ServerDec [Con]
declareCons :: TypeKind -> TypeName -> [ConsD cat s] -> ServerDec [Con]
declareCons TypeKind
tKind TypeName
tName = (ConsD cat s -> ReaderT ServerDecContext Identity Con)
-> [ConsD cat s] -> ServerDec [Con]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConsD cat s -> ReaderT ServerDecContext Identity Con
consR
  where
    consR :: ConsD cat s -> ReaderT ServerDecContext Identity Con
consR ConsD {TypeName
cName :: forall (cat :: TypeCategory) (s :: Stage). ConsD cat s -> TypeName
cName :: TypeName
cName, [FieldDefinition cat s]
cFields :: forall (cat :: TypeCategory) (s :: Stage).
ConsD cat s -> [FieldDefinition cat s]
cFields :: [FieldDefinition cat s]
cFields} =
      Name -> [VarBangType] -> Con
RecC
        (Name -> [VarBangType] -> Con)
-> ReaderT ServerDecContext Identity Name
-> ReaderT ServerDecContext Identity ([VarBangType] -> Con)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeKind
-> TypeName -> TypeName -> ReaderT ServerDecContext Identity Name
consName TypeKind
tKind TypeName
tName TypeName
cName
        ReaderT ServerDecContext Identity ([VarBangType] -> Con)
-> ReaderT ServerDecContext Identity [VarBangType]
-> ReaderT ServerDecContext Identity Con
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FieldDefinition cat s
 -> ReaderT ServerDecContext Identity VarBangType)
-> [FieldDefinition cat s]
-> ReaderT ServerDecContext Identity [VarBangType]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (TypeKind
-> TypeName
-> FieldDefinition cat s
-> ReaderT ServerDecContext Identity VarBangType
forall (cat :: TypeCategory) (s :: Stage).
TypeKind
-> TypeName
-> FieldDefinition cat s
-> ReaderT ServerDecContext Identity VarBangType
declareField TypeKind
tKind TypeName
tName) [FieldDefinition cat s]
cFields

consName :: TypeKind -> TypeName -> TypeName -> ServerDec Name
consName :: TypeKind
-> TypeName -> TypeName -> ReaderT ServerDecContext Identity Name
consName TypeKind
KindEnum (TypeName Text
name) TypeName
conName = do
  Bool
namespace' <- (ServerDecContext -> Bool)
-> ReaderT ServerDecContext Identity Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerDecContext -> Bool
namespace
  if Bool
namespace'
    then Name -> ReaderT ServerDecContext Identity Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> ReaderT ServerDecContext Identity Name)
-> Name -> ReaderT ServerDecContext Identity Name
forall a b. (a -> b) -> a -> b
$ TypeName -> Name
forall a. ToName a => a -> Name
toName (TypeName -> Name) -> TypeName -> Name
forall a b. (a -> b) -> a -> b
$ [FieldName] -> TypeName -> TypeName
nameSpaceType [Text -> FieldName
FieldName Text
name] TypeName
conName
    else Name -> ReaderT ServerDecContext Identity Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
conName)
consName TypeKind
_ TypeName
_ TypeName
conName = Name -> ReaderT ServerDecContext Identity Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
conName)

declareField ::
  TypeKind ->
  TypeName ->
  FieldDefinition cat s ->
  ServerDec (Name, Bang, Type)
declareField :: TypeKind
-> TypeName
-> FieldDefinition cat s
-> ReaderT ServerDecContext Identity VarBangType
declareField TypeKind
tKind TypeName
tName field :: FieldDefinition cat s
field@FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName} = do
  Bool
namespace' <- (ServerDecContext -> Bool)
-> ReaderT ServerDecContext Identity Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerDecContext -> Bool
namespace
  VarBangType -> ReaderT ServerDecContext Identity VarBangType
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Bool -> TypeName -> FieldName -> Name
fieldTypeName Bool
namespace' TypeName
tName FieldName
fieldName,
      SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,
      TypeKind -> FieldDefinition cat s -> Kind
forall (cat :: TypeCategory) (s :: Stage).
TypeKind -> FieldDefinition cat s -> Kind
renderFieldType TypeKind
tKind FieldDefinition cat s
field
    )

renderFieldType ::
  TypeKind ->
  FieldDefinition cat s ->
  Type
renderFieldType :: TypeKind -> FieldDefinition cat s -> Kind
renderFieldType TypeKind
tKind FieldDefinition {Maybe (FieldContent TRUE cat s)
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent :: Maybe (FieldContent TRUE cat s)
fieldContent, TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType :: TypeRef
fieldType} =
  TypeKind -> Maybe (FieldContent TRUE cat s) -> Kind -> Kind
forall (cat :: TypeCategory) (s :: Stage).
TypeKind -> Maybe (FieldContent TRUE cat s) -> Kind -> Kind
withFieldWrappers TypeKind
tKind Maybe (FieldContent TRUE cat s)
fieldContent (TypeRef -> Kind
declareTypeRef TypeRef
fieldType)

fieldTypeName :: Bool -> TypeName -> FieldName -> Name
fieldTypeName :: Bool -> TypeName -> FieldName -> Name
fieldTypeName Bool
namespace TypeName
tName FieldName
fieldName
  | Bool
namespace = FieldName -> Name
forall a. ToName a => a -> Name
toName (TypeName -> FieldName -> FieldName
nameSpaceField TypeName
tName FieldName
fieldName)
  | Bool
otherwise = FieldName -> Name
forall a. ToName a => a -> Name
toName FieldName
fieldName

-- withSubscriptionField: t => SubscriptionField t
withSubscriptionField :: TypeKind -> Type -> Type
withSubscriptionField :: TypeKind -> Kind -> Kind
withSubscriptionField TypeKind
kind Kind
x
  | TypeKind -> Bool
isSubscription TypeKind
kind = Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''SubscriptionField) Kind
x
  | Bool
otherwise = Kind
x

-- withArgs: t => a -> t
withArgs :: TypeName -> Type -> Type
withArgs :: TypeName -> Kind -> Kind
withArgs TypeName
argsTypename = Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
arrowType Kind
argType)
  where
    argType :: Kind
argType = Name -> Kind
ConT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
argsTypename
    arrowType :: Kind
arrowType = Name -> Kind
ConT ''Arrow

-- withMonad: t => m t
withMonad :: Type -> Type
withMonad :: Kind -> Kind
withMonad = Kind -> Kind -> Kind
AppT Kind
m'

type Arrow = (->)

------------------------------------------------
withFieldWrappers ::
  TypeKind ->
  Maybe (FieldContent TRUE cat s) ->
  Type ->
  Type
withFieldWrappers :: TypeKind -> Maybe (FieldContent TRUE cat s) -> Kind -> Kind
withFieldWrappers TypeKind
kind (Just (FieldArgs ArgumentsDefinition {argumentsTypename :: forall (s :: Stage). ArgumentsDefinition s -> Maybe TypeName
argumentsTypename = Just TypeName
argsTypename})) =
  TypeName -> Kind -> Kind
withArgs TypeName
argsTypename
    (Kind -> Kind) -> (Kind -> Kind) -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeKind -> Kind -> Kind
withSubscriptionField TypeKind
kind
    (Kind -> Kind) -> (Kind -> Kind) -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Kind
withMonad
withFieldWrappers TypeKind
kind Maybe (FieldContent TRUE cat s)
_
  | TypeKind -> Bool
isOutputObject TypeKind
kind =
    TypeKind -> Kind -> Kind
withSubscriptionField TypeKind
kind
      (Kind -> Kind) -> (Kind -> Kind) -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Kind
withMonad
  | Bool
otherwise = Kind -> Kind
forall a. a -> a
id