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

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

import Data.Morpheus.App.Internal.Resolving
  ( SubscriptionField,
  )
import Data.Morpheus.Internal.TH
  ( apply,
    declareTypeRef,
    nameSpaceField,
    nameSpaceType,
    toCon,
    toName,
  )
import Data.Morpheus.Server.Internal.TH.Types
  ( ServerConsD,
    ServerDec,
    ServerDecContext (..),
    ServerFieldDefinition (..),
    ServerTypeDefinition (..),
  )
import Data.Morpheus.Server.Internal.TH.Utils
  ( isSubscription,
    m',
    tyConArgs,
  )
import Data.Morpheus.Types.Internal.AST
  ( ConsD (..),
    FieldDefinition (..),
    FieldName (..),
    TypeKind (..),
    TypeName (..),
    isResolverType,
  )
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,
      [ServerConsD cat s]
tCons :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> [ServerConsD cat s]
tCons :: [ServerConsD cat s]
tCons,
      TypeKind
tKind :: TypeKind
tKind :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> TypeKind
tKind
    } =
    do
      [Con]
cons <- TypeKind -> TypeName -> [ServerConsD cat s] -> ServerDec [Con]
forall (cat :: TypeCategory) (s :: Stage).
TypeKind -> TypeName -> [ServerConsD cat s] -> ServerDec [Con]
declareCons TypeKind
tKind TypeName
tName [ServerConsD 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
forall t. Strictness t => t -> Bool
isResolverType 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 ->
  [ServerConsD cat s] ->
  ServerDec [Con]
declareCons :: TypeKind -> TypeName -> [ServerConsD cat s] -> ServerDec [Con]
declareCons TypeKind
tKind TypeName
tName = (ServerConsD cat s -> ReaderT ServerDecContext Identity Con)
-> [ServerConsD cat s] -> ServerDec [Con]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ServerConsD cat s -> ReaderT ServerDecContext Identity Con
consR
  where
    consR :: ServerConsD cat s -> ReaderT ServerDecContext Identity Con
consR ConsD {TypeName
cName :: forall f. ConsD f -> TypeName
cName :: TypeName
cName, [ServerFieldDefinition cat s]
cFields :: forall f. ConsD f -> [f]
cFields :: [ServerFieldDefinition 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
<*> (ServerFieldDefinition cat s
 -> ReaderT ServerDecContext Identity VarBangType)
-> [ServerFieldDefinition 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
-> ServerFieldDefinition cat s
-> ReaderT ServerDecContext Identity VarBangType
forall (cat :: TypeCategory) (s :: Stage).
TypeKind
-> TypeName
-> ServerFieldDefinition cat s
-> ReaderT ServerDecContext Identity VarBangType
declareField TypeKind
tKind TypeName
tName) [ServerFieldDefinition 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 ->
  ServerFieldDefinition cat s ->
  ServerDec (Name, Bang, Type)
declareField :: TypeKind
-> TypeName
-> ServerFieldDefinition cat s
-> ReaderT ServerDecContext Identity VarBangType
declareField TypeKind
tKind TypeName
tName ServerFieldDefinition cat s
field = 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 (FieldDefinition cat s -> FieldName
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName (FieldDefinition cat s -> FieldName)
-> FieldDefinition cat s -> FieldName
forall a b. (a -> b) -> a -> b
$ ServerFieldDefinition cat s -> FieldDefinition cat s
forall (cat :: TypeCategory) (s :: Stage).
ServerFieldDefinition cat s -> FieldDefinition cat s
originalField ServerFieldDefinition cat s
field),
      SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,
      TypeKind -> ServerFieldDefinition cat s -> Kind
forall (cat :: TypeCategory) (s :: Stage).
TypeKind -> ServerFieldDefinition cat s -> Kind
renderFieldType TypeKind
tKind ServerFieldDefinition cat s
field
    )

renderFieldType ::
  TypeKind ->
  ServerFieldDefinition cat s ->
  Type
renderFieldType :: TypeKind -> ServerFieldDefinition cat s -> Kind
renderFieldType
  TypeKind
tKind
  ServerFieldDefinition
    { Bool
isParametrized :: forall (cat :: TypeCategory) (s :: Stage).
ServerFieldDefinition cat s -> Bool
isParametrized :: Bool
isParametrized,
      originalField :: forall (cat :: TypeCategory) (s :: Stage).
ServerFieldDefinition cat s -> FieldDefinition cat s
originalField = FieldDefinition {TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType :: TypeRef
fieldType},
      Maybe TypeName
argumentsTypeName :: forall (cat :: TypeCategory) (s :: Stage).
ServerFieldDefinition cat s -> Maybe TypeName
argumentsTypeName :: Maybe TypeName
argumentsTypeName
    } =
    TypeKind -> Maybe TypeName -> Kind -> Kind
withFieldWrappers TypeKind
tKind Maybe TypeName
argumentsTypeName ((TypeName -> Kind) -> TypeRef -> Kind
declareTypeRef TypeName -> Kind
renderTypeName TypeRef
fieldType)
    where
      renderTypeName :: TypeName -> Type
      renderTypeName :: TypeName -> Kind
renderTypeName
        | Bool
isParametrized = (TypeName -> Cxt -> Kind
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
`apply` [Kind
m'])
        | Bool
otherwise = TypeName -> Kind
forall a b. ToCon a b => a -> b
toCon

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 TypeName ->
  Type ->
  Type
withFieldWrappers :: TypeKind -> Maybe TypeName -> Kind -> Kind
withFieldWrappers TypeKind
kind (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 TypeName
_
  | TypeKind -> Bool
forall t. Strictness t => t -> Bool
isResolverType TypeKind
kind Bool -> Bool -> Bool
&& (TypeKind
KindUnion TypeKind -> TypeKind -> Bool
forall a. Eq a => a -> a -> Bool
/= 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