{-# 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 ()

-- Utils: is Parametrized type

#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})