{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.CodeGen.Interpreting.Core
  ( Converter (..),
    compileError,
    getType,
    typeFrom,
    deprecationWarning,
    toCodeGenField,
    toClientDeclarations,
  )
where

import Control.Monad.Except (MonadError)
import Data.Morpheus.Client.CodeGen.AST
  ( ClientPreDeclaration (..),
    ClientTypeDefinition (..),
    DERIVING_MODE (..),
  )
import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenField (..),
    CodeGenType (..),
    DerivingClass (..),
    FIELD_TYPE_WRAPPER (..),
  )
import Data.Morpheus.CodeGen.Utils (camelCaseTypeName)
import Data.Morpheus.Error
  ( deprecatedField,
  )
import Data.Morpheus.Internal.Ext
  ( GQLResult,
    Result (..),
  )
import Data.Morpheus.Internal.Utils
  ( selectBy,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    Directives,
    FieldDefinition (..),
    FieldName,
    GQLError,
    RAW,
    Ref (..),
    Schema (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeKind (..),
    TypeName,
    TypeRef (..),
    VALID,
    VariableDefinitions,
    internal,
    isNullable,
    isResolverType,
    lookupDeprecated,
    lookupDeprecatedReason,
    msg,
    typeDefinitions,
  )
import Relude

type Env = (Schema VALID, VariableDefinitions RAW)

newtype Converter a = Converter
  { forall a. Converter a -> ReaderT Env GQLResult a
runConverter ::
      ReaderT
        Env
        GQLResult
        a
  }
  deriving
    ( forall a b. a -> Converter b -> Converter a
forall a b. (a -> b) -> Converter a -> Converter b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Converter b -> Converter a
$c<$ :: forall a b. a -> Converter b -> Converter a
fmap :: forall a b. (a -> b) -> Converter a -> Converter b
$cfmap :: forall a b. (a -> b) -> Converter a -> Converter b
Functor,
      Functor Converter
forall a. a -> Converter a
forall a b. Converter a -> Converter b -> Converter a
forall a b. Converter a -> Converter b -> Converter b
forall a b. Converter (a -> b) -> Converter a -> Converter b
forall a b c.
(a -> b -> c) -> Converter a -> Converter b -> Converter c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Converter a -> Converter b -> Converter a
$c<* :: forall a b. Converter a -> Converter b -> Converter a
*> :: forall a b. Converter a -> Converter b -> Converter b
$c*> :: forall a b. Converter a -> Converter b -> Converter b
liftA2 :: forall a b c.
(a -> b -> c) -> Converter a -> Converter b -> Converter c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Converter a -> Converter b -> Converter c
<*> :: forall a b. Converter (a -> b) -> Converter a -> Converter b
$c<*> :: forall a b. Converter (a -> b) -> Converter a -> Converter b
pure :: forall a. a -> Converter a
$cpure :: forall a. a -> Converter a
Applicative,
      Applicative Converter
forall a. a -> Converter a
forall a b. Converter a -> Converter b -> Converter b
forall a b. Converter a -> (a -> Converter b) -> Converter b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Converter a
$creturn :: forall a. a -> Converter a
>> :: forall a b. Converter a -> Converter b -> Converter b
$c>> :: forall a b. Converter a -> Converter b -> Converter b
>>= :: forall a b. Converter a -> (a -> Converter b) -> Converter b
$c>>= :: forall a b. Converter a -> (a -> Converter b) -> Converter b
Monad,
      MonadReader Env,
      MonadError GQLError
    )

compileError :: GQLError -> GQLError
compileError :: GQLError -> GQLError
compileError GQLError
x = GQLError -> GQLError
internal forall a b. (a -> b) -> a -> b
$ GQLError
"Unhandled Compile Time Error: \"" forall a. Semigroup a => a -> a -> a
<> GQLError
x forall a. Semigroup a => a -> a -> a
<> GQLError
"\" ;"

getType :: TypeName -> Converter (TypeDefinition ANY VALID)
getType :: TypeName -> Converter (TypeDefinition ANY VALID)
getType TypeName
typename =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (s :: Stage).
Schema s -> HashMap TypeName (TypeDefinition ANY s)
typeDefinitions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy (GQLError -> GQLError
compileError forall a b. (a -> b) -> a -> b
$ GQLError
" can't find Type" forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
typename) TypeName
typename

typeFrom :: [FieldName] -> TypeDefinition a VALID -> TypeName
typeFrom :: forall (a :: TypeCategory).
[FieldName] -> TypeDefinition a VALID -> TypeName
typeFrom [FieldName]
path TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName, TypeContent TRUE a VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE a VALID
typeContent} = TypeContent TRUE a VALID -> TypeName
__typeFrom TypeContent TRUE a VALID
typeContent
  where
    __typeFrom :: TypeContent TRUE a VALID -> TypeName
__typeFrom DataObject {} = forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
path TypeName
typeName
    __typeFrom DataInterface {} = forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
path TypeName
typeName
    __typeFrom DataUnion {} = forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
path TypeName
typeName
    __typeFrom TypeContent TRUE a VALID
_ = TypeName
typeName

deprecationWarning :: Directives VALID -> (FieldName, Ref FieldName) -> Converter ()
deprecationWarning :: Directives VALID -> (FieldName, Ref FieldName) -> Converter ()
deprecationWarning Directives VALID
dirs (FieldName
typename, Ref FieldName
ref) = case forall (s :: Stage). Directives s -> Maybe (Directive s)
lookupDeprecated Directives VALID
dirs of
  Just Directive VALID
deprecation -> forall a. ReaderT Env GQLResult a -> Converter a
Converter forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Success {result :: ()
result = (), [GQLError]
warnings :: [GQLError]
warnings :: [GQLError]
warnings}
    where
      warnings :: [GQLError]
warnings =
        [ FieldName -> Ref FieldName -> Maybe Description -> GQLError
deprecatedField
            FieldName
typename
            Ref FieldName
ref
            (forall (s :: Stage). Directive s -> Maybe Description
lookupDeprecatedReason Directive VALID
deprecation)
        ]
  Maybe (Directive VALID)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

toCodeGenField :: FieldDefinition a b -> CodeGenField
toCodeGenField :: forall (a :: TypeCategory) (b :: Stage).
FieldDefinition a b -> CodeGenField
toCodeGenField FieldDefinition {fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = field :: TypeRef
field@TypeRef {TypeWrapper
TypeName
typeConName :: TypeRef -> TypeName
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
typeConName :: TypeName
..}, Maybe Description
Maybe (FieldContent TRUE a b)
FieldName
Directives b
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Description
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Directives s
fieldDirectives :: Directives b
fieldContent :: Maybe (FieldContent TRUE a b)
fieldName :: FieldName
fieldDescription :: Maybe Description
..} =
  CodeGenField
    { FieldName
fieldName :: FieldName
fieldName :: FieldName
fieldName,
      fieldType :: TypeName
fieldType = TypeName
typeConName,
      wrappers :: [FIELD_TYPE_WRAPPER]
wrappers = [TypeWrapper -> FIELD_TYPE_WRAPPER
GQL_WRAPPER TypeWrapper
typeWrappers],
      fieldIsNullable :: Bool
fieldIsNullable = forall a. Nullable a => a -> Bool
isNullable TypeRef
field
    }

toClientDeclarations :: ClientTypeDefinition -> [ClientPreDeclaration]
toClientDeclarations :: ClientTypeDefinition -> [ClientPreDeclaration]
toClientDeclarations def :: ClientTypeDefinition
def@ClientTypeDefinition {TypeKind
clientKind :: ClientTypeDefinition -> TypeKind
clientKind :: TypeKind
clientKind}
  | TypeKind
KindScalar forall a. Eq a => a -> a -> Bool
== TypeKind
clientKind = [DERIVING_MODE -> CodeGenType -> ClientPreDeclaration
FromJSONClass DERIVING_MODE
SCALAR_MODE CodeGenType
cgType, DERIVING_MODE -> CodeGenType -> ClientPreDeclaration
ToJSONClass DERIVING_MODE
SCALAR_MODE CodeGenType
cgType]
  | TypeKind
KindEnum forall a. Eq a => a -> a -> Bool
== TypeKind
clientKind = [CodeGenType -> ClientPreDeclaration
ClientType CodeGenType
cgType, DERIVING_MODE -> CodeGenType -> ClientPreDeclaration
FromJSONClass DERIVING_MODE
ENUM_MODE CodeGenType
cgType, DERIVING_MODE -> CodeGenType -> ClientPreDeclaration
ToJSONClass DERIVING_MODE
ENUM_MODE CodeGenType
cgType]
  | forall t. Strictness t => t -> Bool
isResolverType TypeKind
clientKind = [CodeGenType -> ClientPreDeclaration
ClientType CodeGenType
cgType, DERIVING_MODE -> CodeGenType -> ClientPreDeclaration
FromJSONClass DERIVING_MODE
TYPE_MODE CodeGenType
cgType]
  | Bool
otherwise = [CodeGenType -> ClientPreDeclaration
ClientType CodeGenType
cgType, DERIVING_MODE -> CodeGenType -> ClientPreDeclaration
ToJSONClass DERIVING_MODE
TYPE_MODE CodeGenType
cgType]
  where
    cgType :: CodeGenType
cgType = ClientTypeDefinition -> CodeGenType
printClientType ClientTypeDefinition
def

printClientType :: ClientTypeDefinition -> CodeGenType
printClientType :: ClientTypeDefinition -> CodeGenType
printClientType ClientTypeDefinition {[CodeGenConstructor]
CodeGenTypeName
TypeKind
clientCons :: ClientTypeDefinition -> [CodeGenConstructor]
clientTypeName :: ClientTypeDefinition -> CodeGenTypeName
clientKind :: TypeKind
clientCons :: [CodeGenConstructor]
clientTypeName :: CodeGenTypeName
clientKind :: ClientTypeDefinition -> TypeKind
..} =
  CodeGenType
    { cgTypeName :: CodeGenTypeName
cgTypeName = CodeGenTypeName
clientTypeName,
      cgConstructors :: [CodeGenConstructor]
cgConstructors = [CodeGenConstructor]
clientCons,
      cgDerivations :: [DerivingClass]
cgDerivations = [DerivingClass
GENERIC, DerivingClass
SHOW, DerivingClass
CLASS_EQ]
    }