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

module Data.Morpheus.Client.CodeGen.Interpreting.Core
  ( LocalM,
    compileError,
    getType,
    typeFrom,
    deprecationWarning,
    printClientType,
    defaultDerivations,
    warning,
    LocalContext (..),
    withPosition,
    getNameByPath,
    registerFragment,
    existFragment,
    removeDuplicates,
    clientConfig,
    lookupField,
    lookupType,
  )
where

import Control.Monad.Except (MonadError (..))
import Data.Morpheus.Client.CodeGen.AST
  ( ClientDeclaration (..),
    ClientTypeDefinition (..),
  )
import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenType (..),
    CodeGenTypeName (..),
    DerivingClass (..),
    TypeClassInstance (..),
    fromTypeName,
  )
import Data.Morpheus.CodeGen.Utils
  ( CodeGenT,
  )
import Data.Morpheus.Core (Config (..), VALIDATION_MODE (WITHOUT_VARIABLES))
import Data.Morpheus.Internal.Ext
  ( Result (..),
  )
import Data.Morpheus.Internal.Utils
  ( empty,
    selectBy,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    Description,
    Directives,
    FieldDefinition (..),
    FieldName,
    FragmentName,
    GQLError,
    Msg,
    OUT,
    Position,
    RAW,
    Schema (..),
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    VALID,
    VariableDefinitions,
    internal,
    lookupDataType,
    lookupDeprecated,
    lookupDeprecatedReason,
    mkTypeRef,
    msg,
  )
import Data.Set (insert, member)
import Relude hiding (empty)

clientConfig :: Config
clientConfig :: Config
clientConfig =
  Config
    { debug :: Bool
debug = Bool
False,
      introspection :: Bool
introspection = Bool
True,
      validationMode :: VALIDATION_MODE
validationMode = VALIDATION_MODE
WITHOUT_VARIABLES
    }

data LocalContext = LocalContext
  { LocalContext -> Schema VALID
ctxSchema :: Schema VALID,
    LocalContext -> VariableDefinitions RAW
ctxVariables :: VariableDefinitions RAW,
    LocalContext -> Maybe Position
ctxPosition :: Maybe Position,
    LocalContext -> Set FragmentName
ctxFragments :: Set FragmentName
  }

getKey :: ClientDeclaration -> String
getKey :: ClientDeclaration -> String
getKey (InstanceDeclaration DERIVING_MODE
_ TypeClassInstance ClientMethod
x) = Name -> String
forall b a. (Show a, IsString b) => a -> b
show (TypeClassInstance ClientMethod -> Name
forall body. TypeClassInstance body -> Name
typeClassName TypeClassInstance ClientMethod
x) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CodeGenTypeName -> String
forall b a. (Show a, IsString b) => a -> b
show (TypeClassInstance ClientMethod -> CodeGenTypeName
forall body. TypeClassInstance body -> CodeGenTypeName
typeClassTarget TypeClassInstance ClientMethod
x)
getKey (ClientTypeDeclaration CodeGenType
x) = CodeGenType -> String
forall b a. (Show a, IsString b) => a -> b
show CodeGenType
x

removeDuplicates :: [ClientDeclaration] -> [ClientDeclaration]
removeDuplicates :: [ClientDeclaration] -> [ClientDeclaration]
removeDuplicates = [ClientDeclaration] -> [ClientDeclaration] -> [ClientDeclaration]
collect []
  where
    collect :: [ClientDeclaration] -> [ClientDeclaration] -> [ClientDeclaration]
collect [ClientDeclaration]
seen [] = [ClientDeclaration]
seen
    collect [ClientDeclaration]
seen (ClientDeclaration
x : [ClientDeclaration]
xs)
      | ClientDeclaration -> String
getKey ClientDeclaration
x String -> [String] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (ClientDeclaration -> String) -> [ClientDeclaration] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ClientDeclaration -> String
getKey [ClientDeclaration]
seen = [ClientDeclaration] -> [ClientDeclaration] -> [ClientDeclaration]
collect [ClientDeclaration]
seen [ClientDeclaration]
xs
      | Bool
otherwise = [ClientDeclaration] -> [ClientDeclaration] -> [ClientDeclaration]
collect ([ClientDeclaration]
seen [ClientDeclaration] -> [ClientDeclaration] -> [ClientDeclaration]
forall a. Semigroup a => a -> a -> a
<> [ClientDeclaration
x]) [ClientDeclaration]
xs

registerFragment :: FragmentName -> LocalM a -> LocalM a
registerFragment :: forall a. FragmentName -> LocalM a -> LocalM a
registerFragment FragmentName
name = (LocalContext -> LocalContext)
-> CodeGenT LocalContext (Result GQLError) a
-> CodeGenT LocalContext (Result GQLError) a
forall a.
(LocalContext -> LocalContext)
-> CodeGenT LocalContext (Result GQLError) a
-> CodeGenT LocalContext (Result GQLError) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\LocalContext
ctx -> LocalContext
ctx {ctxFragments = insert name (ctxFragments ctx)})

existFragment :: FragmentName -> LocalM Bool
existFragment :: FragmentName -> LocalM Bool
existFragment FragmentName
name = (FragmentName
name FragmentName -> Set FragmentName -> Bool
forall a. Ord a => a -> Set a -> Bool
`member`) (Set FragmentName -> Bool)
-> CodeGenT LocalContext (Result GQLError) (Set FragmentName)
-> LocalM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LocalContext -> Set FragmentName)
-> CodeGenT LocalContext (Result GQLError) (Set FragmentName)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks LocalContext -> Set FragmentName
ctxFragments

withPosition :: Position -> LocalM a -> LocalM a
withPosition :: forall a. Position -> LocalM a -> LocalM a
withPosition Position
pos = (LocalContext -> LocalContext)
-> CodeGenT LocalContext (Result GQLError) a
-> CodeGenT LocalContext (Result GQLError) a
forall a.
(LocalContext -> LocalContext)
-> CodeGenT LocalContext (Result GQLError) a
-> CodeGenT LocalContext (Result GQLError) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\LocalContext
ctx -> LocalContext
ctx {ctxPosition = Just pos})

type LocalM a = CodeGenT LocalContext (Result GQLError) a

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

lookupType :: TypeName -> LocalM (Maybe (TypeDefinition ANY VALID))
lookupType :: TypeName -> LocalM (Maybe (TypeDefinition ANY VALID))
lookupType TypeName
name = (LocalContext -> Maybe (TypeDefinition ANY VALID))
-> LocalM (Maybe (TypeDefinition ANY VALID))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TypeName -> Schema VALID -> Maybe (TypeDefinition ANY VALID)
forall (s :: Stage).
TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
lookupDataType TypeName
name (Schema VALID -> Maybe (TypeDefinition ANY VALID))
-> (LocalContext -> Schema VALID)
-> LocalContext
-> Maybe (TypeDefinition ANY VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalContext -> Schema VALID
ctxSchema)

getType :: TypeName -> LocalM (TypeDefinition ANY VALID)
getType :: TypeName -> LocalM (TypeDefinition ANY VALID)
getType TypeName
name = do
  Maybe (TypeDefinition ANY VALID)
x <- TypeName -> LocalM (Maybe (TypeDefinition ANY VALID))
lookupType TypeName
name
  LocalM (TypeDefinition ANY VALID)
-> (TypeDefinition ANY VALID -> LocalM (TypeDefinition ANY VALID))
-> Maybe (TypeDefinition ANY VALID)
-> LocalM (TypeDefinition ANY VALID)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GQLError -> LocalM (TypeDefinition ANY VALID)
forall a. GQLError -> CodeGenT LocalContext (Result GQLError) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> LocalM (TypeDefinition ANY VALID))
-> GQLError -> LocalM (TypeDefinition ANY VALID)
forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
compileError (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
" can't find Type" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
name) TypeDefinition ANY VALID -> LocalM (TypeDefinition ANY VALID)
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TypeDefinition ANY VALID)
x

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

getNameByPath :: [FieldName] -> TypeName -> CodeGenTypeName
getNameByPath :: [FieldName] -> TypeName -> CodeGenTypeName
getNameByPath [FieldName]
path TypeName
tName = case [FieldName] -> [FieldName]
forall a. [a] -> [a]
reverse [FieldName]
path of
  (FieldName
p : [FieldName]
ps) -> CodeGenTypeName {namespace :: [FieldName]
namespace = [FieldName] -> [FieldName]
forall a. [a] -> [a]
reverse [FieldName]
ps, typeParameters :: [Text]
typeParameters = [], typename :: TypeName
typename = FieldName -> TypeName
forall a b. Coercible a b => a -> b
coerce FieldName
p}
  [] -> CodeGenTypeName {namespace :: [FieldName]
namespace = [], typeParameters :: [Text]
typeParameters = [], typename :: TypeName
typename = TypeName
tName}

deprecationWarning :: (Maybe Description -> GQLError) -> Directives s -> LocalM ()
deprecationWarning :: forall (s :: Stage).
(Maybe Text -> GQLError) -> Directives s -> LocalM ()
deprecationWarning Maybe Text -> GQLError
f = (GQLError -> LocalM ()) -> [GQLError] -> LocalM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ GQLError -> LocalM ()
warning ([GQLError] -> LocalM ())
-> (Directives s -> [GQLError]) -> Directives s -> LocalM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GQLError -> [GQLError]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe GQLError -> [GQLError])
-> (Directives s -> Maybe GQLError) -> Directives s -> [GQLError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Directive s -> GQLError) -> Maybe (Directive s) -> Maybe GQLError
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Text -> GQLError
f (Maybe Text -> GQLError)
-> (Directive s -> Maybe Text) -> Directive s -> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directive s -> Maybe Text
forall (s :: Stage). Directive s -> Maybe Text
lookupDeprecatedReason) (Maybe (Directive s) -> Maybe GQLError)
-> (Directives s -> Maybe (Directive s))
-> Directives s
-> Maybe GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directives s -> Maybe (Directive s)
forall (s :: Stage). Directives s -> Maybe (Directive s)
lookupDeprecated

warning :: GQLError -> LocalM ()
warning :: GQLError -> LocalM ()
warning GQLError
w = Result GQLError () -> LocalM ()
forall (m :: * -> *) a. Monad m => m a -> CodeGenT LocalContext m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Result GQLError () -> LocalM ())
-> Result GQLError () -> LocalM ()
forall a b. (a -> b) -> a -> b
$ Success {result :: ()
result = (), warnings :: [GQLError]
warnings = [GQLError
w]}

defaultDerivations :: [DerivingClass]
defaultDerivations :: [DerivingClass]
defaultDerivations = [DerivingClass
GENERIC, DerivingClass
SHOW, DerivingClass
CLASS_EQ]

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

lookupField :: FieldName -> TypeContent TRUE ANY VALID -> LocalM (FieldDefinition OUT VALID)
lookupField :: FieldName
-> TypeContent TRUE ANY VALID -> LocalM (FieldDefinition OUT VALID)
lookupField FieldName
selectionName TypeContent TRUE ANY VALID
_
  | FieldName
selectionName FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
"__typename" =
      FieldDefinition OUT VALID -> LocalM (FieldDefinition OUT VALID)
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        FieldDefinition
          { fieldName :: FieldName
fieldName = FieldName
"__typename",
            fieldDescription :: Maybe Text
fieldDescription = Maybe Text
forall a. Maybe a
Nothing,
            fieldType :: TypeRef
fieldType = TypeName -> TypeRef
mkTypeRef TypeName
"String",
            fieldDirectives :: Directives VALID
fieldDirectives = Directives VALID
forall coll. Empty coll => coll
empty,
            fieldContent :: Maybe (FieldContent TRUE OUT VALID)
fieldContent = Maybe (FieldContent TRUE OUT VALID)
forall a. Maybe a
Nothing
          }
lookupField FieldName
selectionName x :: TypeContent TRUE ANY VALID
x@DataObject {FieldsDefinition OUT VALID
objectFields :: FieldsDefinition OUT VALID
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields} = GQLError
-> FieldName
-> FieldsDefinition OUT VALID
-> LocalM (FieldDefinition OUT VALID)
forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy (FieldName -> TypeContent TRUE ANY VALID -> GQLError
forall a b. (Msg a, Show b) => a -> b -> GQLError
selError FieldName
selectionName TypeContent TRUE ANY VALID
x) FieldName
selectionName FieldsDefinition OUT VALID
objectFields
lookupField FieldName
selectionName x :: TypeContent TRUE ANY VALID
x@DataInterface {FieldsDefinition OUT VALID
interfaceFields :: FieldsDefinition OUT VALID
interfaceFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields} = GQLError
-> FieldName
-> FieldsDefinition OUT VALID
-> LocalM (FieldDefinition OUT VALID)
forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy (FieldName -> TypeContent TRUE ANY VALID -> GQLError
forall a b. (Msg a, Show b) => a -> b -> GQLError
selError FieldName
selectionName TypeContent TRUE ANY VALID
x) FieldName
selectionName FieldsDefinition OUT VALID
interfaceFields
lookupField FieldName
_ TypeContent TRUE ANY VALID
dt = GQLError -> LocalM (FieldDefinition OUT VALID)
forall a. GQLError -> CodeGenT LocalContext (Result GQLError) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
compileError (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
"Type should be output Object \"" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> String -> GQLError
forall a. Msg a => a -> GQLError
msg (TypeContent TRUE ANY VALID -> String
forall b a. (Show a, IsString b) => a -> b
show TypeContent TRUE ANY VALID
dt :: String))

selError :: (Msg a, Show b) => a -> b -> GQLError
selError :: forall a b. (Msg a, Show b) => a -> b -> GQLError
selError a
selectionName b
con = GQLError -> GQLError
compileError (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
"can't find field " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> a -> GQLError
forall a. Msg a => a -> GQLError
msg a
selectionName GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" on type: " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> String -> GQLError
forall a. Msg a => a -> GQLError
msg (b -> String
forall b a. (Show a, IsString b) => a -> b
show b
con :: String)