{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.CodeGen.Server.Interpreting.Utils
  ( CodeGenMonad (..),
    TypeContext (..),
    CodeGenT,
    getFieldName,
    getEnumName,
    isParamResolverType,
    lookupFieldType,
    isSubscription,
    inType,
  )
where

import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenTypeName (CodeGenTypeName),
    fromTypeName,
  )
import Data.Morpheus.CodeGen.TH
  ( ToName (toName),
  )
import Data.Morpheus.CodeGen.Utils
  ( camelCaseFieldName,
  )
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,
  )
import Language.Haskell.TH
  ( Dec (..),
    Info (..),
    Q,
    TyVarBndr,
    reify,
  )
import Relude hiding (ByteString, get)

type CodeGenT m = ReaderT (TypeContext CONST) m

data TypeContext s = TypeContext
  { forall (s :: Stage). TypeContext s -> FieldName -> TypeName
toArgsTypeName :: FieldName -> TypeName,
    forall (s :: Stage). TypeContext s -> [TypeDefinition ANY s]
typeDefinitions :: [TypeDefinition ANY s],
    forall (s :: Stage). TypeContext s -> [DirectiveDefinition s]
directiveDefinitions :: [DirectiveDefinition s],
    forall (s :: Stage). TypeContext s -> Maybe TypeName
currentTypeName :: Maybe TypeName,
    forall (s :: Stage). TypeContext s -> Maybe TypeKind
currentKind :: Maybe TypeKind,
    forall (s :: Stage). TypeContext s -> Bool
hasNamespace :: Bool
  }

getFieldName :: Monad m => FieldName -> CodeGenT m FieldName
getFieldName :: forall (m :: * -> *). Monad m => FieldName -> CodeGenT m FieldName
getFieldName FieldName
fieldName = do
  TypeContext {Bool
hasNamespace :: Bool
hasNamespace :: forall (s :: Stage). TypeContext s -> Bool
hasNamespace, Maybe TypeName
currentTypeName :: Maybe TypeName
currentTypeName :: forall (s :: Stage). TypeContext s -> 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 (TypeContext s) m => TypeName -> m CodeGenTypeName
getEnumName :: forall (s :: Stage) (m :: * -> *).
MonadReader (TypeContext s) m =>
TypeName -> m CodeGenTypeName
getEnumName TypeName
enumName = do
  TypeContext {Bool
hasNamespace :: Bool
hasNamespace :: forall (s :: Stage). TypeContext s -> Bool
hasNamespace, Maybe TypeName
currentTypeName :: Maybe TypeName
currentTypeName :: forall (s :: Stage). TypeContext s -> 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 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 :: CodeGenMonad m => TypeName -> [TypeDefinition ANY s] -> CodeGenT m Bool
isParametrizedResolverType :: forall (m :: * -> *) (s :: Stage).
CodeGenMonad m =>
TypeName -> [TypeDefinition ANY s] -> CodeGenT 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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *). CodeGenMonad m => TypeName -> m Bool
isParametrizedType TypeName
name)

isParamResolverType :: CodeGenMonad m => TypeName -> ReaderT (TypeContext CONST) m Bool
isParamResolverType :: forall (m :: * -> *).
CodeGenMonad m =>
TypeName -> ReaderT (TypeContext CONST) m Bool
isParamResolverType TypeName
typeConName =
  forall (m :: * -> *) (s :: Stage).
CodeGenMonad m =>
TypeName -> [TypeDefinition ANY s] -> CodeGenT 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 forall (s :: Stage). TypeContext s -> [TypeDefinition ANY s]
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 :: MonadFail m => TypeName -> CodeGenT m (TypeDefinition ANY CONST)
lookupType :: forall (m :: * -> *).
MonadFail m =>
TypeName -> CodeGenT m (TypeDefinition ANY CONST)
lookupType TypeName
name = do
  [TypeDefinition ANY CONST]
types <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage). TypeContext s -> [TypeDefinition ANY s]
typeDefinitions
  case 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 of
    Just TypeDefinition ANY CONST
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition ANY CONST
x
    Maybe (TypeDefinition ANY CONST)
Nothing -> 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"

lookupFieldType :: MonadFail m => TypeName -> FieldName -> CodeGenT m TypeRef
lookupFieldType :: forall (m :: * -> *).
MonadFail m =>
TypeName -> FieldName -> CodeGenT 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 :: * -> *).
MonadFail m =>
TypeName -> CodeGenT m (TypeDefinition ANY CONST)
lookupType TypeName
name
  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 (KindObject (Just OperationType
Subscription)) = Bool
True
isSubscription TypeKind
_ = Bool
False

inType :: MonadReader (TypeContext s) m => Maybe TypeName -> m a -> m a
inType :: forall (s :: Stage) (m :: * -> *) a.
MonadReader (TypeContext s) 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 (\TypeContext s
x -> TypeContext s
x {currentTypeName :: Maybe TypeName
currentTypeName = Maybe TypeName
name, currentKind :: Maybe TypeKind
currentKind = forall a. Maybe a
Nothing})