{-# 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, 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) = forall b a. (Show a, IsString b) => a -> b
show (forall body. TypeClassInstance body -> Name
typeClassName TypeClassInstance ClientMethod
x) forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (forall body. TypeClassInstance body -> CodeGenTypeName
typeClassTarget TypeClassInstance ClientMethod
x)
getKey (ClientTypeDeclaration CodeGenType
x) = 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 forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` 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 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 = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\LocalContext
ctx -> LocalContext
ctx {ctxFragments :: Set FragmentName
ctxFragments = forall a. Ord a => a -> Set a -> Set a
insert FragmentName
name (LocalContext -> Set FragmentName
ctxFragments LocalContext
ctx)})

existFragment :: FragmentName -> LocalM Bool
existFragment :: FragmentName -> LocalM Bool
existFragment FragmentName
name = (FragmentName
name forall a. Ord a => a -> Set a -> Bool
`member`) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\LocalContext
ctx -> LocalContext
ctx {ctxPosition :: Maybe Position
ctxPosition = forall a. a -> Maybe a
Just Position
pos})

type LocalM a = CodeGenT LocalContext (Result GQLError) a

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
"\" ;"

lookupType :: TypeName -> LocalM (Maybe (TypeDefinition ANY VALID))
lookupType :: TypeName -> LocalM (Maybe (TypeDefinition ANY VALID))
lookupType TypeName
name = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (s :: Stage).
TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
lookupDataType TypeName
name 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
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ 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
name) 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 :: 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 -> 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 forall a. [a] -> [a]
reverse [FieldName]
path of
  (FieldName
p : [FieldName]
ps) -> CodeGenTypeName {namespace :: [FieldName]
namespace = forall a. [a] -> [a]
reverse [FieldName]
ps, typeParameters :: [Text]
typeParameters = [], typename :: TypeName
typename = coerce :: 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 = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ GQLError -> LocalM ()
warning forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Text -> GQLError
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). Directive s -> Maybe Text
lookupDeprecatedReason) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). Directives s -> Maybe (Directive s)
lookupDeprecated

warning :: GQLError -> LocalM ()
warning :: GQLError -> LocalM ()
warning GQLError
w = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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
clientKind :: ClientTypeDefinition -> TypeKind
clientCons :: ClientTypeDefinition -> [CodeGenConstructor]
clientTypeName :: ClientTypeDefinition -> CodeGenTypeName
clientKind :: TypeKind
clientCons :: [CodeGenConstructor]
clientTypeName :: CodeGenTypeName
..} =
  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 forall a. Eq a => a -> a -> Bool
== FieldName
"__typename" =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        FieldDefinition
          { fieldName :: FieldName
fieldName = FieldName
"__typename",
            fieldDescription :: Maybe Text
fieldDescription = forall a. Maybe a
Nothing,
            fieldType :: TypeRef
fieldType = TypeName -> TypeRef
mkTypeRef TypeName
"String",
            fieldDirectives :: Directives VALID
fieldDirectives = forall coll. Empty coll => coll
empty,
            fieldContent :: Maybe (FieldContent TRUE OUT VALID)
fieldContent = forall a. Maybe a
Nothing
          }
lookupField FieldName
selectionName x :: TypeContent TRUE ANY VALID
x@DataObject {FieldsDefinition OUT VALID
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT VALID
objectFields} = forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy (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 :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT VALID
interfaceFields} = forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy (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 = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
compileError forall a b. (a -> b) -> a -> b
$ GQLError
"Type should be output Object \"" forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg (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 forall a b. (a -> b) -> a -> b
$ GQLError
"can't find field " forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg a
selectionName forall a. Semigroup a => a -> a -> a
<> GQLError
" on type: " forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg (forall b a. (Show a, IsString b) => a -> b
show b
con :: String)