{-# 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,
    reify,
  )
import qualified Language.Haskell.TH as TH
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 <- Maybe (TypeDefinition ANY CONST) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (TypeDefinition ANY CONST) -> Bool)
-> m (Maybe (TypeDefinition ANY CONST)) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeName -> m (Maybe (TypeDefinition ANY CONST))
forall (m :: * -> *).
CodeGenM m =>
TypeName -> m (Maybe (TypeDefinition ANY CONST))
lookupType TypeName
name
  if Bool
exists
    then () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else Text -> m ()
forall (m :: * -> *). MonadState Flags m => Text -> m ()
requireExternal (TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName TypeName
name)

getFieldTypeName :: (CodeGenM m) => TypeName -> m TypeName
getFieldTypeName :: forall (m :: * -> *). CodeGenM m => TypeName -> m TypeName
getFieldTypeName TypeName
name = TypeName -> m ()
forall (m :: * -> *). CodeGenM m => TypeName -> m ()
checkTypeExistence TypeName
name m () -> TypeName -> m TypeName
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text -> TypeName
forall a (t :: NAME). NamePacking a => a -> Name t
forall (t :: NAME). Text -> 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 :: ServerCodeGenContext -> Bool
hasNamespace :: Bool
hasNamespace, Maybe TypeName
currentTypeName :: ServerCodeGenContext -> Maybe TypeName
currentTypeName :: Maybe TypeName
currentTypeName} <- m ServerCodeGenContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  FieldName -> m FieldName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> m FieldName) -> FieldName -> m FieldName
forall a b. (a -> b) -> a -> b
$
    if Bool
hasNamespace
      then FieldName -> (TypeName -> FieldName) -> Maybe TypeName -> FieldName
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 :: ServerCodeGenContext -> Bool
hasNamespace :: Bool
hasNamespace, Maybe TypeName
currentTypeName :: ServerCodeGenContext -> Maybe TypeName
currentTypeName :: Maybe TypeName
currentTypeName} <- m ServerCodeGenContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  CodeGenTypeName -> m CodeGenTypeName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeGenTypeName -> m CodeGenTypeName)
-> CodeGenTypeName -> m CodeGenTypeName
forall a b. (a -> b) -> a -> b
$
    if Bool
hasNamespace
      then [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName ((TypeName -> FieldName) -> [TypeName] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> FieldName
forall a b. Coercible a b => a -> b
coerce ([TypeName] -> [FieldName]) -> [TypeName] -> [FieldName]
forall a b. (a -> b) -> a -> b
$ Maybe TypeName -> [TypeName]
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 = m Bool -> CodeGenT ctx m Bool
forall (m :: * -> *) a. Monad m => m a -> CodeGenT ctx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> CodeGenT ctx m Bool)
-> (TypeName -> m Bool) -> TypeName -> CodeGenT ctx m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> m Bool
forall (m :: * -> *). CodeGenMonad m => TypeName -> m Bool
isParametrizedType
  printWarnings :: [GQLError] -> CodeGenT ctx m ()
printWarnings = m () -> CodeGenT ctx m ()
forall (m :: * -> *) a. Monad m => m a -> CodeGenT ctx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CodeGenT ctx m ())
-> ([GQLError] -> m ()) -> [GQLError] -> CodeGenT ctx m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GQLError] -> m ()
forall (m :: * -> *). CodeGenMonad m => [GQLError] -> m ()
printWarnings

instance CodeGenMonad Q where
  isParametrizedType :: TypeName -> Q Bool
isParametrizedType TypeName
name = Info -> Bool
isParametrizedHaskellType (Info -> Bool) -> Q Info -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify (TypeName -> Name
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
_ = Bool -> GQLResult Bool
forall a. a -> Result GQLError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  printWarnings :: [GQLError] -> GQLResult ()
printWarnings [GQLError]
_ = () -> GQLResult ()
forall a. a -> Result GQLError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- Utils: is Parametrized type

#if MIN_VERSION_template_haskell(2,21,0)
getTypeVariables :: Dec -> [TH.TyVarBndr TH.BndrVis]
#elif MIN_VERSION_template_haskell(2,17,0)
getTypeVariables :: Dec -> [TH.TyVarBndr ()]
#else
getTypeVariables :: Dec -> [TH.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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [TyVarBndr ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyVarBndr ()] -> Bool) -> [TyVarBndr ()] -> Bool
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]
_ = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Boolean" [TypeDefinition ANY s]
_ = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"String" [TypeDefinition ANY s]
_ = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Int" [TypeDefinition ANY s]
_ = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Float" [TypeDefinition ANY s]
_ = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
name [TypeDefinition ANY s]
lib = case (TypeDefinition ANY s -> TypeName)
-> TypeName
-> [TypeDefinition ANY s]
-> Maybe (TypeDefinition ANY s)
forall k a. Eq k => (a -> k) -> k -> [a] -> Maybe a
lookupWith TypeDefinition ANY s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeName
name [TypeDefinition ANY s]
lib of
  Just TypeDefinition ANY s
x -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition ANY s -> Bool
forall t. Strictness t => t -> Bool
isResolverType TypeDefinition ANY s
x)
  Maybe (TypeDefinition ANY s)
Nothing -> TypeName -> m Bool
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 =
  TypeName -> [TypeDefinition ANY CONST] -> m Bool
forall (m :: * -> *) (s :: Stage).
CodeGenM m =>
TypeName -> [TypeDefinition ANY s] -> m Bool
isParametrizedResolverType TypeName
typeConName ([TypeDefinition ANY CONST] -> m Bool)
-> m [TypeDefinition ANY CONST] -> m Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ServerCodeGenContext -> [TypeDefinition ANY CONST])
-> m [TypeDefinition ANY CONST]
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 = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"can't found " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
at String -> String -> String
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 <- (ServerCodeGenContext -> [TypeDefinition ANY CONST])
-> m [TypeDefinition ANY CONST]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerCodeGenContext -> [TypeDefinition ANY CONST]
typeDefinitions
  Maybe (TypeDefinition ANY CONST)
-> m (Maybe (TypeDefinition ANY CONST))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TypeDefinition ANY CONST)
 -> m (Maybe (TypeDefinition ANY CONST)))
-> Maybe (TypeDefinition ANY CONST)
-> m (Maybe (TypeDefinition ANY CONST))
forall a b. (a -> b) -> a -> b
$ (TypeDefinition ANY CONST -> Bool)
-> [TypeDefinition ANY CONST] -> Maybe (TypeDefinition ANY CONST)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\TypeDefinition ANY CONST
t -> TypeDefinition ANY CONST -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition ANY CONST
t TypeName -> TypeName -> Bool
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 :: TypeContent TRUE ANY CONST
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent} <- TypeName -> m (Maybe (TypeDefinition ANY CONST))
forall (m :: * -> *).
CodeGenM m =>
TypeName -> m (Maybe (TypeDefinition ANY CONST))
lookupType TypeName
name m (Maybe (TypeDefinition ANY CONST))
-> (Maybe (TypeDefinition ANY CONST)
    -> m (TypeDefinition ANY CONST))
-> m (TypeDefinition ANY CONST)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (TypeDefinition ANY CONST)
-> (TypeDefinition ANY CONST -> m (TypeDefinition ANY CONST))
-> Maybe (TypeDefinition ANY CONST)
-> m (TypeDefinition ANY CONST)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> String -> m (TypeDefinition ANY CONST)
forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFoundError (TypeName -> String
forall b a. (Show a, IsString b) => a -> b
show TypeName
name) String
"type definitions") TypeDefinition ANY CONST -> m (TypeDefinition ANY CONST)
forall a. a -> m a
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 :: TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType} <- m (FieldDefinition IN CONST)
-> (FieldDefinition IN CONST -> m (FieldDefinition IN CONST))
-> FieldName
-> FieldsDefinition IN CONST
-> m (FieldDefinition IN CONST)
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (String -> String -> m (FieldDefinition IN CONST)
forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFoundError (FieldName -> String
forall b a. (Show a, IsString b) => a -> b
show FieldName
fieldName) (TypeName -> String
forall b a. (Show a, IsString b) => a -> b
show TypeName
name)) FieldDefinition IN CONST -> m (FieldDefinition IN CONST)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldName
fieldName FieldsDefinition IN CONST
fields
      TypeRef -> m TypeRef
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeRef
fieldType
    TypeContent TRUE ANY CONST
_ -> String -> String -> m TypeRef
forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFoundError String
"input object" (TypeName -> String
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 = (ServerCodeGenContext -> ServerCodeGenContext) -> m a -> m a
forall a.
(ServerCodeGenContext -> ServerCodeGenContext) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ServerCodeGenContext
x -> ServerCodeGenContext
x {currentTypeName = name, currentKind = Nothing})