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

module Data.Morpheus.Client.Transform.Local
  ( toLocalDefinitions,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.Client.Internal.Types
  ( ClientConstructorDefinition (..),
    ClientTypeDefinition (..),
    FetchDefinition (..),
    TypeNameTH (..),
  )
import Data.Morpheus.Client.Transform.Core (Converter (..), compileError, deprecationWarning, getType, typeFrom)
import Data.Morpheus.Client.Transform.Global (toArgumentsType)
import Data.Morpheus.Core (Config (..), VALIDATION_MODE (WITHOUT_VARIABLES), validateRequest)
import Data.Morpheus.Internal.Ext
  ( GQLResult,
  )
import Data.Morpheus.Internal.Utils
  ( empty,
    keyOf,
    selectBy,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    ExecutableDocument (..),
    FieldDefinition (..),
    FieldName,
    OUT,
    Operation (..),
    Ref (..),
    Schema (..),
    Selection (..),
    SelectionContent (..),
    SelectionSet,
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeKind (..),
    TypeName,
    TypeRef (..),
    UnionTag (..),
    VALID,
    getOperationDataType,
    getOperationName,
    mkTypeRef,
    msg,
    toAny,
  )
import Relude hiding (empty, show)
import Prelude (show)

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

toLocalDefinitions ::
  ExecutableDocument ->
  Schema VALID ->
  GQLResult
    ( FetchDefinition,
      [ClientTypeDefinition]
    )
toLocalDefinitions :: ExecutableDocument
-> Schema VALID
-> GQLResult (FetchDefinition, [ClientTypeDefinition])
toLocalDefinitions ExecutableDocument
request Schema VALID
schema = do
  Operation VALID
validOperation <- Config
-> Schema VALID
-> ExecutableDocument
-> GQLResult (Operation VALID)
validateRequest Config
clientConfig Schema VALID
schema ExecutableDocument
request
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Schema VALID
schema, forall (s :: Stage). Operation s -> VariableDefinitions s
operationArguments forall a b. (a -> b) -> a -> b
$ ExecutableDocument -> Operation RAW
operation ExecutableDocument
request) forall a b. (a -> b) -> a -> b
$
    forall a.
Converter a
-> ReaderT
     (Schema VALID, VariableDefinitions RAW) (Result GQLError) a
runConverter forall a b. (a -> b) -> a -> b
$
      Operation VALID
-> Converter (FetchDefinition, [ClientTypeDefinition])
genOperation Operation VALID
validOperation

genOperation :: Operation VALID -> Converter (FetchDefinition, [ClientTypeDefinition])
genOperation :: Operation VALID
-> Converter (FetchDefinition, [ClientTypeDefinition])
genOperation op :: Operation VALID
op@Operation {Maybe FieldName
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationName :: Maybe FieldName
operationName, SelectionSet VALID
operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s
operationSelection :: SelectionSet VALID
operationSelection, OperationType
operationType :: forall (s :: Stage). Operation s -> OperationType
operationType :: OperationType
operationType} = do
  (Schema VALID
schema, VariableDefinitions RAW
varDefs) <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. a -> a
id
  TypeDefinition OBJECT VALID
datatype <- forall (m :: * -> *) (s :: Stage).
MonadError GQLError m =>
Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)
getOperationDataType Operation VALID
op Schema VALID
schema
  let argumentsType :: Maybe ClientTypeDefinition
argumentsType = TypeName -> VariableDefinitions RAW -> Maybe ClientTypeDefinition
toArgumentsType (Maybe FieldName -> TypeName
getOperationName Maybe FieldName
operationName forall a. Semigroup a => a -> a -> a
<> TypeName
"Args") VariableDefinitions RAW
varDefs
  (ClientTypeDefinition
rootType :| [ClientTypeDefinition]
localTypes) <-
    [FieldName]
-> TypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> Converter (NonEmpty ClientTypeDefinition)
genLocalTypes
      []
      (Maybe FieldName -> TypeName
getOperationName Maybe FieldName
operationName)
      (forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
ToCategory a k ANY =>
a k s -> a ANY s
toAny TypeDefinition OBJECT VALID
datatype)
      SelectionSet VALID
operationSelection
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( FetchDefinition
        { clientArgumentsTypeName :: Maybe TypeNameTH
clientArgumentsTypeName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClientTypeDefinition -> TypeNameTH
clientTypeName Maybe ClientTypeDefinition
argumentsType,
          rootTypeName :: TypeNameTH
rootTypeName = ClientTypeDefinition -> TypeNameTH
clientTypeName ClientTypeDefinition
rootType,
          fetchOperationType :: OperationType
fetchOperationType = OperationType
operationType
        },
      ClientTypeDefinition
rootType forall a. a -> [a] -> [a]
: ([ClientTypeDefinition]
localTypes forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> [a]
maybeToList Maybe ClientTypeDefinition
argumentsType)
    )

-------------------------------------------------------------------------
-- generates selection Object Types
genLocalTypes ::
  [FieldName] ->
  TypeName ->
  TypeDefinition ANY VALID ->
  SelectionSet VALID ->
  Converter (NonEmpty ClientTypeDefinition)
genLocalTypes :: [FieldName]
-> TypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> Converter (NonEmpty ClientTypeDefinition)
genLocalTypes [FieldName]
path TypeName
tName TypeDefinition ANY VALID
dataType SelectionSet VALID
recordSelSet = do
  (ClientConstructorDefinition
con, [ClientTypeDefinition]
subTypes) <- [FieldName]
-> TypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> Converter (ClientConstructorDefinition, [ClientTypeDefinition])
toConstructorDefinition (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldName]
path then [coerce :: forall a b. Coercible a b => a -> b
coerce TypeName
tName] else [FieldName]
path) TypeName
tName TypeDefinition ANY VALID
dataType SelectionSet VALID
recordSelSet
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    ClientTypeDefinition
      { clientTypeName :: TypeNameTH
clientTypeName = [FieldName] -> TypeName -> TypeNameTH
TypeNameTH [FieldName]
path TypeName
tName,
        clientCons :: [ClientConstructorDefinition]
clientCons = [ClientConstructorDefinition
con],
        clientKind :: TypeKind
clientKind = Maybe OperationType -> TypeKind
KindObject forall a. Maybe a
Nothing
      }
      forall a. a -> [a] -> NonEmpty a
:| [ClientTypeDefinition]
subTypes

toConstructorDefinition ::
  [FieldName] ->
  TypeName ->
  TypeDefinition ANY VALID ->
  SelectionSet VALID ->
  Converter (ClientConstructorDefinition, [ClientTypeDefinition])
toConstructorDefinition :: [FieldName]
-> TypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> Converter (ClientConstructorDefinition, [ClientTypeDefinition])
toConstructorDefinition [FieldName]
path TypeName
cName TypeDefinition ANY VALID
datatype SelectionSet VALID
selSet = do
  ([FieldDefinition ANY VALID]
cFields, [[ClientTypeDefinition]]
subTypes) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Selection VALID
-> Converter (FieldDefinition ANY VALID, [ClientTypeDefinition])
genField (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet VALID
selSet)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientConstructorDefinition {TypeName
cName :: TypeName
cName :: TypeName
cName, [FieldDefinition ANY VALID]
cFields :: [FieldDefinition ANY VALID]
cFields :: [FieldDefinition ANY VALID]
cFields}, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ClientTypeDefinition]]
subTypes)
  where
    genField :: Selection VALID -> Converter (FieldDefinition ANY VALID, [ClientTypeDefinition])
    genField :: Selection VALID
-> Converter (FieldDefinition ANY VALID, [ClientTypeDefinition])
genField Selection VALID
sel = do
      let fieldName :: FieldName
fieldName = forall k a. KeyOf k a => a -> k
keyOf Selection VALID
sel
      let fieldPath :: [FieldName]
fieldPath = [FieldName]
path forall a. Semigroup a => a -> a -> a
<> [FieldName
fieldName]
      (TypeDefinition ANY VALID
fieldDataType, TypeRef
fieldType) <- [FieldName]
-> TypeDefinition ANY VALID
-> Selection VALID
-> Converter (TypeDefinition ANY VALID, TypeRef)
getFieldType [FieldName]
fieldPath TypeDefinition ANY VALID
datatype Selection VALID
sel
      [ClientTypeDefinition]
subTypes <- [FieldName]
-> TypeDefinition ANY VALID
-> Selection VALID
-> Converter [ClientTypeDefinition]
subTypesBySelection [FieldName]
fieldPath TypeDefinition ANY VALID
fieldDataType Selection VALID
sel
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( FieldDefinition
            { FieldName
fieldName :: FieldName
fieldName :: FieldName
fieldName,
              TypeRef
fieldType :: TypeRef
fieldType :: TypeRef
fieldType,
              fieldContent :: Maybe (FieldContent TRUE ANY VALID)
fieldContent = forall a. Maybe a
Nothing,
              fieldDescription :: Maybe Description
fieldDescription = forall a. Maybe a
Nothing,
              fieldDirectives :: Directives VALID
fieldDirectives = forall coll. Empty coll => coll
empty
            },
          [ClientTypeDefinition]
subTypes
        )

------------------------------------------
subTypesBySelection ::
  [FieldName] ->
  TypeDefinition ANY VALID ->
  Selection VALID ->
  Converter [ClientTypeDefinition]
subTypesBySelection :: [FieldName]
-> TypeDefinition ANY VALID
-> Selection VALID
-> Converter [ClientTypeDefinition]
subTypesBySelection [FieldName]
_ TypeDefinition ANY VALID
_ Selection {selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent = SelectionContent VALID
SelectionField} = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
subTypesBySelection [FieldName]
path TypeDefinition ANY VALID
dType Selection {selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent = SelectionSet SelectionSet VALID
selectionSet} = do
  forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldName]
-> TypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> Converter (NonEmpty ClientTypeDefinition)
genLocalTypes [FieldName]
path (forall (a :: TypeCategory).
[FieldName] -> TypeDefinition a VALID -> TypeName
typeFrom [] TypeDefinition ANY VALID
dType) TypeDefinition ANY VALID
dType SelectionSet VALID
selectionSet
subTypesBySelection [FieldName]
path TypeDefinition ANY VALID
dType Selection {selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent = UnionSelection SelectionSet VALID
interface UnionSelection VALID
unionSelections} =
  do
    let variants :: [UnionTag]
variants = TypeName -> SelectionSet VALID -> UnionTag
UnionTag (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition ANY VALID
dType) SelectionSet VALID
interface forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UnionSelection VALID
unionSelections
    ([ClientConstructorDefinition]
clientCons, [[ClientTypeDefinition]]
subTypes) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([FieldName]
-> UnionTag
-> Converter (ClientConstructorDefinition, [ClientTypeDefinition])
getVariantType [FieldName]
path) [UnionTag]
variants
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( ClientTypeDefinition
          { clientTypeName :: TypeNameTH
clientTypeName = [FieldName] -> TypeName -> TypeNameTH
TypeNameTH [FieldName]
path (forall (a :: TypeCategory).
[FieldName] -> TypeDefinition a VALID -> TypeName
typeFrom [] TypeDefinition ANY VALID
dType),
            [ClientConstructorDefinition]
clientCons :: [ClientConstructorDefinition]
clientCons :: [ClientConstructorDefinition]
clientCons,
            clientKind :: TypeKind
clientKind = TypeKind
KindUnion
          }
          forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ClientTypeDefinition]]
subTypes
      )

getVariantType :: [FieldName] -> UnionTag -> Converter (ClientConstructorDefinition, [ClientTypeDefinition])
getVariantType :: [FieldName]
-> UnionTag
-> Converter (ClientConstructorDefinition, [ClientTypeDefinition])
getVariantType [FieldName]
path (UnionTag TypeName
selectedTyName SelectionSet VALID
selectionVariant) = do
  TypeDefinition ANY VALID
conDatatype <- TypeName -> Converter (TypeDefinition ANY VALID)
getType TypeName
selectedTyName
  [FieldName]
-> TypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> Converter (ClientConstructorDefinition, [ClientTypeDefinition])
toConstructorDefinition [FieldName]
path TypeName
selectedTyName TypeDefinition ANY VALID
conDatatype SelectionSet VALID
selectionVariant

getFieldType ::
  [FieldName] ->
  TypeDefinition ANY VALID ->
  Selection VALID ->
  Converter (TypeDefinition ANY VALID, TypeRef)
getFieldType :: [FieldName]
-> TypeDefinition ANY VALID
-> Selection VALID
-> Converter (TypeDefinition ANY VALID, TypeRef)
getFieldType
  [FieldName]
path
  TypeDefinition {TypeContent TRUE ANY VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE ANY VALID
typeContent, TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName}
  Selection
    { FieldName
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionName :: FieldName
selectionName,
      Position
selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition :: Position
selectionPosition
    } = TypeContent TRUE ANY VALID -> Converter (FieldDefinition OUT VALID)
toFieldDef TypeContent TRUE ANY VALID
typeContent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FieldDefinition OUT VALID
-> Converter (TypeDefinition ANY VALID, TypeRef)
processFieldDefinition
    where
      toFieldDef :: TypeContent TRUE ANY VALID -> Converter (FieldDefinition OUT VALID)
      toFieldDef :: TypeContent TRUE ANY VALID -> Converter (FieldDefinition OUT VALID)
toFieldDef 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 Description
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
                }
      toFieldDef 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 GQLError
selError FieldName
selectionName FieldsDefinition OUT VALID
objectFields
      toFieldDef 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 GQLError
selError FieldName
selectionName FieldsDefinition OUT VALID
interfaceFields
      toFieldDef 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 a. Show a => a -> String
show TypeContent TRUE ANY VALID
dt))
      selError :: GQLError
selError = 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 FieldName
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 a. Show a => a -> String
show TypeContent TRUE ANY VALID
typeContent)
      --
      processFieldDefinition :: FieldDefinition OUT VALID
-> Converter (TypeDefinition ANY VALID, TypeRef)
processFieldDefinition
        FieldDefinition
          { fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = TypeRef {TypeWrapper
TypeName
typeWrappers :: TypeRef -> TypeWrapper
typeConName :: TypeRef -> TypeName
typeWrappers :: TypeWrapper
typeConName :: TypeName
..},
            Directives VALID
fieldDirectives :: Directives VALID
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Directives s
fieldDirectives
          } =
          Converter ()
checkDeprecated forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (TypeDefinition ANY VALID -> (TypeDefinition ANY VALID, TypeRef)
trans forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeName -> Converter (TypeDefinition ANY VALID)
getType TypeName
typeConName)
          where
            trans :: TypeDefinition ANY VALID -> (TypeDefinition ANY VALID, TypeRef)
trans TypeDefinition ANY VALID
x = (TypeDefinition ANY VALID
x, TypeRef {typeConName :: TypeName
typeConName = forall (a :: TypeCategory).
[FieldName] -> TypeDefinition a VALID -> TypeName
typeFrom [FieldName]
path TypeDefinition ANY VALID
x, TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers :: TypeWrapper
..})
            ------------------------------------------------------------------
            checkDeprecated :: Converter ()
            checkDeprecated :: Converter ()
checkDeprecated = Directives VALID -> (FieldName, Ref FieldName) -> Converter ()
deprecationWarning Directives VALID
fieldDirectives (coerce :: forall a b. Coercible a b => a -> b
coerce TypeName
typeName, forall name. name -> Position -> Ref name
Ref FieldName
selectionName Position
selectionPosition)