{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.CodeGen.Server.Interpreting.Utils
( CodeGenMonad (..),
CodeGenM,
ServerCodeGenContext (..),
getFieldName,
getEnumName,
isParamResolverType,
lookupFieldType,
isSubscription,
inType,
getFieldTypeName,
checkTypeExistence,
)
where
import Data.Morpheus.CodeGen.Internal.AST
( CodeGenTypeName (CodeGenTypeName),
fromTypeName,
)
import Data.Morpheus.CodeGen.TH
( ToName (toName),
)
import Data.Morpheus.CodeGen.Utils
( CodeGenT,
Flags,
camelCaseFieldName,
requireExternal,
toHaskellTypeName,
)
import Data.Morpheus.Error (gqlWarnings)
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Internal.Utils (selectOr)
import Data.Morpheus.Types.Internal.AST
( ANY,
CONST,
DirectiveDefinition (..),
FieldDefinition (..),
FieldName,
GQLError,
OperationType (..),
TypeContent (..),
TypeDefinition (..),
TypeKind (..),
TypeName,
TypeRef (..),
isResolverType,
lookupWith,
packName,
unpackName,
)
import Language.Haskell.TH
( Dec (..),
Info (..),
Q,
TyVarBndr,
reify,
)
import Relude hiding (ByteString, get)
class (MonadReader ServerCodeGenContext m, Monad m, MonadFail m, CodeGenMonad m, MonadState Flags m) => CodeGenM m
instance CodeGenMonad m => CodeGenM (CodeGenT ServerCodeGenContext m)
data ServerCodeGenContext = ServerCodeGenContext
{ ServerCodeGenContext -> FieldName -> TypeName
toArgsTypeName :: FieldName -> TypeName,
ServerCodeGenContext -> [TypeDefinition ANY CONST]
typeDefinitions :: [TypeDefinition ANY CONST],
ServerCodeGenContext -> [DirectiveDefinition CONST]
directiveDefinitions :: [DirectiveDefinition CONST],
ServerCodeGenContext -> Maybe TypeName
currentTypeName :: Maybe TypeName,
ServerCodeGenContext -> Maybe TypeKind
currentKind :: Maybe TypeKind,
ServerCodeGenContext -> Bool
hasNamespace :: Bool
}
checkTypeExistence :: CodeGenM m => TypeName -> m ()
checkTypeExistence :: forall (m :: * -> *). CodeGenM m => TypeName -> m ()
checkTypeExistence TypeName
name = do
Bool
exists <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
CodeGenM m =>
TypeName -> m (Maybe (TypeDefinition ANY CONST))
lookupType TypeName
name
if Bool
exists
then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else forall (m :: * -> *). MonadState Flags m => Text -> m ()
requireExternal (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
name)
getFieldTypeName :: CodeGenM m => TypeName -> m TypeName
getFieldTypeName :: forall (m :: * -> *). CodeGenM m => TypeName -> m TypeName
getFieldTypeName TypeName
name = forall (m :: * -> *). CodeGenM m => TypeName -> m ()
checkTypeExistence TypeName
name forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a (t :: NAME). NamePacking a => a -> Name t
packName (TypeName -> Text
toHaskellTypeName TypeName
name)
getFieldName :: CodeGenM m => FieldName -> m FieldName
getFieldName :: forall (m :: * -> *). CodeGenM m => FieldName -> m FieldName
getFieldName FieldName
fieldName = do
ServerCodeGenContext {Bool
hasNamespace :: Bool
hasNamespace :: ServerCodeGenContext -> Bool
hasNamespace, Maybe TypeName
currentTypeName :: Maybe TypeName
currentTypeName :: ServerCodeGenContext -> Maybe TypeName
currentTypeName} <- 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
$
if Bool
hasNamespace
then forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldName
fieldName (TypeName -> FieldName -> FieldName
`camelCaseFieldName` FieldName
fieldName) Maybe TypeName
currentTypeName
else FieldName
fieldName
getEnumName :: MonadReader ServerCodeGenContext m => TypeName -> m CodeGenTypeName
getEnumName :: forall (m :: * -> *).
MonadReader ServerCodeGenContext m =>
TypeName -> m CodeGenTypeName
getEnumName TypeName
enumName = do
ServerCodeGenContext {Bool
hasNamespace :: Bool
hasNamespace :: ServerCodeGenContext -> Bool
hasNamespace, Maybe TypeName
currentTypeName :: Maybe TypeName
currentTypeName :: ServerCodeGenContext -> Maybe TypeName
currentTypeName} <- 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
$
if Bool
hasNamespace
then [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName (forall a b. (a -> b) -> [a] -> [b]
map coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList Maybe TypeName
currentTypeName) [] TypeName
enumName
else TypeName -> CodeGenTypeName
fromTypeName TypeName
enumName
class (Monad m, MonadFail m) => CodeGenMonad m where
isParametrizedType :: TypeName -> m Bool
printWarnings :: [GQLError] -> m ()
instance CodeGenMonad m => CodeGenMonad (CodeGenT ctx m) where
isParametrizedType :: TypeName -> CodeGenT ctx m Bool
isParametrizedType = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). CodeGenMonad m => TypeName -> m Bool
isParametrizedType
printWarnings :: [GQLError] -> CodeGenT ctx m ()
printWarnings = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). CodeGenMonad m => [GQLError] -> m ()
printWarnings
instance CodeGenMonad Q where
isParametrizedType :: TypeName -> Q Bool
isParametrizedType TypeName
name = Info -> Bool
isParametrizedHaskellType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify (forall a. ToName a => a -> Name
toName TypeName
name)
printWarnings :: [GQLError] -> Q ()
printWarnings = [GQLError] -> Q ()
gqlWarnings
instance CodeGenMonad GQLResult where
isParametrizedType :: TypeName -> GQLResult Bool
isParametrizedType TypeName
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
printWarnings :: [GQLError] -> GQLResult ()
printWarnings [GQLError]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#if MIN_VERSION_template_haskell(2,17,0)
getTypeVariables :: Dec -> [TyVarBndr ()]
#else
getTypeVariables :: Dec -> [TyVarBndr]
#endif
getTypeVariables :: Dec -> [TyVarBndr ()]
getTypeVariables (DataD Cxt
_ Name
_ [TyVarBndr ()]
args Maybe Kind
_ [Con]
_ [DerivClause]
_) = [TyVarBndr ()]
args
getTypeVariables (NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
args Maybe Kind
_ Con
_ [DerivClause]
_) = [TyVarBndr ()]
args
getTypeVariables (TySynD Name
_ [TyVarBndr ()]
args Kind
_) = [TyVarBndr ()]
args
getTypeVariables Dec
_ = []
isParametrizedHaskellType :: Info -> Bool
isParametrizedHaskellType :: Info -> Bool
isParametrizedHaskellType (TyConI Dec
x) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ Dec -> [TyVarBndr ()]
getTypeVariables Dec
x
isParametrizedHaskellType Info
_ = Bool
False
isParametrizedResolverType :: CodeGenM m => TypeName -> [TypeDefinition ANY s] -> m Bool
isParametrizedResolverType :: forall (m :: * -> *) (s :: Stage).
CodeGenM m =>
TypeName -> [TypeDefinition ANY s] -> m Bool
isParametrizedResolverType TypeName
"__TypeKind" [TypeDefinition ANY s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Boolean" [TypeDefinition ANY s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"String" [TypeDefinition ANY s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Int" [TypeDefinition ANY s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Float" [TypeDefinition ANY s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
name [TypeDefinition ANY s]
lib = case forall k a. Eq k => (a -> k) -> k -> [a] -> Maybe a
lookupWith forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeName
name [TypeDefinition ANY s]
lib of
Just TypeDefinition ANY s
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall t. Strictness t => t -> Bool
isResolverType TypeDefinition ANY s
x)
Maybe (TypeDefinition ANY s)
Nothing -> forall (m :: * -> *). CodeGenMonad m => TypeName -> m Bool
isParametrizedType TypeName
name
isParamResolverType :: CodeGenM m => TypeName -> m Bool
isParamResolverType :: forall (m :: * -> *). CodeGenM m => TypeName -> m Bool
isParamResolverType TypeName
typeConName =
forall (m :: * -> *) (s :: Stage).
CodeGenM m =>
TypeName -> [TypeDefinition ANY s] -> m Bool
isParametrizedResolverType TypeName
typeConName forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerCodeGenContext -> [TypeDefinition ANY CONST]
typeDefinitions
notFoundError :: MonadFail m => String -> String -> m a
notFoundError :: forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFoundError String
name String
at = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"can't found " forall a. Semigroup a => a -> a -> a
<> String
name forall a. Semigroup a => a -> a -> a
<> String
"at " forall a. Semigroup a => a -> a -> a
<> String
at forall a. Semigroup a => a -> a -> a
<> String
"!"
lookupType :: CodeGenM m => TypeName -> m (Maybe (TypeDefinition ANY CONST))
lookupType :: forall (m :: * -> *).
CodeGenM m =>
TypeName -> m (Maybe (TypeDefinition ANY CONST))
lookupType TypeName
name = do
[TypeDefinition ANY CONST]
types <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerCodeGenContext -> [TypeDefinition ANY CONST]
typeDefinitions
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\TypeDefinition ANY CONST
t -> forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition ANY CONST
t forall a. Eq a => a -> a -> Bool
== TypeName
name) [TypeDefinition ANY CONST]
types
lookupFieldType :: CodeGenM m => TypeName -> FieldName -> m TypeRef
lookupFieldType :: forall (m :: * -> *).
CodeGenM m =>
TypeName -> FieldName -> m TypeRef
lookupFieldType TypeName
name FieldName
fieldName = do
TypeDefinition {TypeContent TRUE ANY CONST
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE ANY CONST
typeContent} <- forall (m :: * -> *).
CodeGenM m =>
TypeName -> m (Maybe (TypeDefinition ANY CONST))
lookupType TypeName
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFoundError (forall b a. (Show a, IsString b) => a -> b
show TypeName
name) String
"type definitions") forall (f :: * -> *) a. Applicative f => a -> f a
pure
case TypeContent TRUE ANY CONST
typeContent of
DataInputObject FieldsDefinition IN CONST
fields -> do
FieldDefinition {TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType :: TypeRef
fieldType} <- forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFoundError (forall b a. (Show a, IsString b) => a -> b
show FieldName
fieldName) (forall b a. (Show a, IsString b) => a -> b
show TypeName
name)) forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldName
fieldName FieldsDefinition IN CONST
fields
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeRef
fieldType
TypeContent TRUE ANY CONST
_ -> forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFoundError String
"input object" (forall b a. (Show a, IsString b) => a -> b
show TypeName
name)
isSubscription :: TypeKind -> Bool
isSubscription :: TypeKind -> Bool
isSubscription (KIND_OBJECT (Just OperationType
OPERATION_SUBSCRIPTION)) = Bool
True
isSubscription TypeKind
_ = Bool
False
inType :: MonadReader ServerCodeGenContext m => Maybe TypeName -> m a -> m a
inType :: forall (m :: * -> *) a.
MonadReader ServerCodeGenContext m =>
Maybe TypeName -> m a -> m a
inType Maybe TypeName
name = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ServerCodeGenContext
x -> ServerCodeGenContext
x {currentTypeName :: Maybe TypeName
currentTypeName = Maybe TypeName
name, currentKind :: Maybe TypeKind
currentKind = forall a. Maybe a
Nothing})