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

module Data.Morpheus.Client.CodeGen.Interpreting.Local
  ( toLocalDefinitions,
  )
where

import Data.Morpheus.Client.CodeGen.AST
  ( ClientDeclaration (..),
    ClientPreDeclaration (..),
    RequestTypeDefinition (..),
    UnionPat (..),
  )
import Data.Morpheus.Client.CodeGen.Interpreting.Arguments (genArguments)
import Data.Morpheus.Client.CodeGen.Interpreting.Core
  ( LocalContext (..),
    LocalM,
    clientConfig,
    defaultDerivations,
    deprecationWarning,
    existFragment,
    getNameByPath,
    getType,
    lookupField,
    lookupType,
    registerFragment,
    removeDuplicates,
    typeFrom,
    warning,
  )
import Data.Morpheus.Client.CodeGen.Interpreting.PreDeclarations
  ( mapPreDeclarations,
  )
import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConstructor (..),
    CodeGenField (..),
    CodeGenType (..),
    CodeGenTypeName (..),
    FIELD_TYPE_WRAPPER (..),
    fromTypeName,
    getFullName,
  )
import Data.Morpheus.CodeGen.Utils
  ( Flags,
    langExtension,
    requireExternal,
    runCodeGenT,
  )
import Data.Morpheus.Core (validateRequest)
import Data.Morpheus.Error (deprecatedField)
import Data.Morpheus.Internal.Ext
  ( GQLResult,
  )
import Data.Morpheus.Internal.Utils
  ( keyOf,
    member,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    ExecutableDocument (..),
    FieldDefinition (..),
    FieldName,
    FragmentName,
    Operation (..),
    Position (..),
    PropName (..),
    Schema (..),
    Selection (..),
    SelectionContent (..),
    SelectionSet,
    TypeDefinition (..),
    TypeKind (..),
    TypeName,
    TypeRef (..),
    UnionTag (..),
    VALID,
    at,
    getOperationDataType,
    getOperationName,
    isNullable,
    kindOf,
    msg,
    toAny,
    unpackName,
    withPath,
  )
import qualified Data.Set as S
import qualified Data.Text as T
import Relude hiding (empty, show)

toLocalDefinitions :: (Text, ExecutableDocument) -> Schema VALID -> GQLResult ([ClientDeclaration], Flags)
toLocalDefinitions :: (Text, ExecutableDocument)
-> Schema VALID -> GQLResult ([ClientDeclaration], Flags)
toLocalDefinitions (Text
query, ExecutableDocument
request) Schema VALID
ctxSchema = do
  Operation VALID
validOperation <- Config
-> Schema VALID
-> ExecutableDocument
-> GQLResult (Operation VALID)
validateRequest Config
clientConfig Schema VALID
ctxSchema ExecutableDocument
request
  let context :: LocalContext
context =
        LocalContext
          { Schema VALID
ctxSchema :: Schema VALID
ctxSchema :: Schema VALID
ctxSchema,
            ctxVariables :: VariableDefinitions RAW
ctxVariables = Operation RAW -> VariableDefinitions RAW
forall (s :: Stage). Operation s -> VariableDefinitions s
operationArguments (Operation RAW -> VariableDefinitions RAW)
-> Operation RAW -> VariableDefinitions RAW
forall a b. (a -> b) -> a -> b
$ ExecutableDocument -> Operation RAW
operation ExecutableDocument
request,
            ctxPosition :: Maybe Position
ctxPosition = Maybe Position
forall a. Maybe a
Nothing,
            ctxFragments :: Set FragmentName
ctxFragments = Set FragmentName
forall a. Monoid a => a
mempty
          }
  ([ClientPreDeclaration]
t, Flags
flags) <- CodeGenT LocalContext (Result GQLError) [ClientPreDeclaration]
-> LocalContext -> Result GQLError ([ClientPreDeclaration], Flags)
forall (m :: * -> *) ctx a.
Monad m =>
CodeGenT ctx m a -> ctx -> m (a, Flags)
runCodeGenT (Text
-> Operation VALID
-> CodeGenT LocalContext (Result GQLError) [ClientPreDeclaration]
genLocalDeclarations Text
query Operation VALID
validOperation) LocalContext
context
  [ClientDeclaration]
types <- [ClientDeclaration] -> [ClientDeclaration]
removeDuplicates ([ClientDeclaration] -> [ClientDeclaration])
-> Result GQLError [ClientDeclaration]
-> Result GQLError [ClientDeclaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClientPreDeclaration -> Result GQLError ClientDeclaration)
-> [ClientPreDeclaration] -> Result GQLError [ClientDeclaration]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ClientPreDeclaration -> Result GQLError ClientDeclaration
forall (m :: * -> *).
MonadFail m =>
ClientPreDeclaration -> m ClientDeclaration
mapPreDeclarations [ClientPreDeclaration]
t
  ([ClientDeclaration], Flags)
-> GQLResult ([ClientDeclaration], Flags)
forall a. a -> Result GQLError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ClientDeclaration]
types, Flags
flags)

genLocalDeclarations :: Text -> Operation VALID -> LocalM [ClientPreDeclaration]
genLocalDeclarations :: Text
-> Operation VALID
-> CodeGenT LocalContext (Result GQLError) [ClientPreDeclaration]
genLocalDeclarations Text
query op :: Operation VALID
op@Operation {Maybe FieldName
operationName :: Maybe FieldName
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationName, SelectionSet VALID
operationSelection :: SelectionSet VALID
operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s
operationSelection, OperationType
operationType :: OperationType
operationType :: forall (s :: Stage). Operation s -> OperationType
operationType} = do
  LocalContext {Schema VALID
ctxSchema :: LocalContext -> Schema VALID
ctxSchema :: Schema VALID
ctxSchema, VariableDefinitions RAW
ctxVariables :: LocalContext -> VariableDefinitions RAW
ctxVariables :: VariableDefinitions RAW
ctxVariables} <- (LocalContext -> LocalContext)
-> CodeGenT LocalContext (Result GQLError) LocalContext
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks LocalContext -> LocalContext
forall a. a -> a
id
  TypeDefinition OBJECT VALID
datatype <- Operation VALID
-> Schema VALID
-> CodeGenT
     LocalContext (Result GQLError) (TypeDefinition OBJECT VALID)
forall (m :: * -> *) (s :: Stage).
MonadError GQLError m =>
Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)
getOperationDataType Operation VALID
op Schema VALID
ctxSchema
  let operationTypeName :: TypeName
operationTypeName = Maybe FieldName -> TypeName
getOperationName Maybe FieldName
operationName
  let (TypeName
requestArgs, [ClientPreDeclaration]
argTypes) = TypeName
-> VariableDefinitions RAW -> (TypeName, [ClientPreDeclaration])
genArguments TypeName
operationTypeName VariableDefinitions RAW
ctxVariables
  (CodeGenTypeName
rootTypeName, [ClientPreDeclaration]
localTypes) <- [FieldName]
-> TypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
genLocalTypes [TypeName -> FieldName
forall a b. Coercible a b => a -> b
coerce TypeName
operationTypeName] TypeName
operationTypeName (TypeDefinition OBJECT VALID -> TypeDefinition ANY VALID
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
  [ClientPreDeclaration]
-> CodeGenT LocalContext (Result GQLError) [ClientPreDeclaration]
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( RequestTypeDefinition -> ClientPreDeclaration
RequestTypeClass
        RequestTypeDefinition
          { requestArgs :: TypeName
requestArgs = TypeName
requestArgs,
            requestName :: TypeName
requestName = CodeGenTypeName -> TypeName
typename CodeGenTypeName
rootTypeName,
            requestType :: OperationType
requestType = OperationType
operationType,
            requestQuery :: String
requestQuery = Text -> String
T.unpack Text
query
          }
        ClientPreDeclaration
-> [ClientPreDeclaration] -> [ClientPreDeclaration]
forall a. a -> [a] -> [a]
: [ClientPreDeclaration]
localTypes [ClientPreDeclaration]
-> [ClientPreDeclaration] -> [ClientPreDeclaration]
forall a. Semigroup a => a -> a -> a
<> [ClientPreDeclaration]
argTypes
    )

genLocalTypes ::
  [FieldName] ->
  TypeName ->
  TypeDefinition ANY VALID ->
  SelectionSet VALID ->
  LocalM (CodeGenTypeName, [ClientPreDeclaration])
genLocalTypes :: [FieldName]
-> TypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
genLocalTypes [FieldName]
namespace TypeName
tName = [FieldName]
-> CodeGenTypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
genObjectTypeWithFragment [FieldName]
namespace ([FieldName] -> TypeName -> CodeGenTypeName
getNameByPath [FieldName]
namespace TypeName
tName)

subTypesBySelection ::
  TypeName ->
  [FieldName] ->
  TypeDefinition ANY VALID ->
  Selection VALID ->
  LocalM (CodeGenTypeName, [ClientPreDeclaration])
subTypesBySelection :: TypeName
-> [FieldName]
-> TypeDefinition ANY VALID
-> Selection VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
subTypesBySelection TypeName
name [FieldName]
_ TypeDefinition ANY VALID
_ Selection {selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent = SelectionContent VALID
SelectionField} = do
  Maybe TypeKind
kind <- (TypeDefinition ANY VALID -> TypeKind)
-> Maybe (TypeDefinition ANY VALID) -> Maybe TypeKind
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeDefinition ANY VALID -> TypeKind
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeKind
kindOf (Maybe (TypeDefinition ANY VALID) -> Maybe TypeKind)
-> CodeGenT
     LocalContext (Result GQLError) (Maybe (TypeDefinition ANY VALID))
-> CodeGenT LocalContext (Result GQLError) (Maybe TypeKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeName
-> CodeGenT
     LocalContext (Result GQLError) (Maybe (TypeDefinition ANY VALID))
lookupType TypeName
name
  if Maybe TypeKind -> Bool
forall a. Maybe a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe TypeKind
kind Bool -> Bool -> Bool
|| Maybe TypeKind
kind Maybe TypeKind -> Maybe TypeKind -> Bool
forall a. Eq a => a -> a -> Bool
== TypeKind -> Maybe TypeKind
forall a. a -> Maybe a
Just TypeKind
KIND_SCALAR
    then Text -> CodeGenT LocalContext (Result GQLError) ()
forall (m :: * -> *). MonadState Flags m => Text -> m ()
requireExternal (TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName TypeName
name) CodeGenT LocalContext (Result GQLError) ()
-> (CodeGenTypeName, [ClientPreDeclaration])
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (TypeName -> CodeGenTypeName
fromTypeName TypeName
name, [])
    else (CodeGenTypeName, [ClientPreDeclaration])
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> CodeGenTypeName
fromTypeName TypeName
name, [])
subTypesBySelection TypeName
_ [FieldName]
path TypeDefinition ANY VALID
dType Selection {selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent = SelectionSet SelectionSet VALID
selectionSet} =
  [FieldName]
-> TypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
genLocalTypes [FieldName]
path (CodeGenTypeName -> TypeName
getFullName (CodeGenTypeName -> TypeName) -> CodeGenTypeName -> TypeName
forall a b. (a -> b) -> a -> b
$ [FieldName] -> TypeDefinition ANY VALID -> CodeGenTypeName
forall (a :: TypeCategory).
[FieldName] -> TypeDefinition a VALID -> CodeGenTypeName
typeFrom [] TypeDefinition ANY VALID
dType) TypeDefinition ANY VALID
dType SelectionSet VALID
selectionSet
subTypesBySelection TypeName
_ [FieldName]
namespace TypeDefinition ANY VALID
dType Selection {Position
selectionPosition :: Position
selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition, selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent = UnionSelection Maybe (SelectionSet VALID)
interface UnionSelection VALID
unionSelections} =
  do
    let variants :: [UnionTag]
variants = MergeMap 'False TypeName UnionTag -> [UnionTag]
forall a. MergeMap 'False TypeName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList MergeMap 'False TypeName UnionTag
UnionSelection VALID
unionSelections
    (UnionTag -> CodeGenT LocalContext (Result GQLError) ())
-> [UnionTag] -> CodeGenT LocalContext (Result GQLError) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Position
-> [FieldName]
-> Maybe (SelectionSet VALID)
-> UnionTag
-> CodeGenT LocalContext (Result GQLError) ()
checkTypename Position
selectionPosition [FieldName]
namespace Maybe (SelectionSet VALID)
interface) [UnionTag]
variants
    let cgTypeName :: CodeGenTypeName
cgTypeName = [FieldName] -> TypeDefinition ANY VALID -> CodeGenTypeName
forall (a :: TypeCategory).
[FieldName] -> TypeDefinition a VALID -> CodeGenTypeName
typeFrom [FieldName]
namespace TypeDefinition ANY VALID
dType
    ([Variant]
cons, [[ClientPreDeclaration]]
subTypes) <- [(Variant, [ClientPreDeclaration])]
-> ([Variant], [[ClientPreDeclaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Variant, [ClientPreDeclaration])]
 -> ([Variant], [[ClientPreDeclaration]]))
-> CodeGenT
     LocalContext (Result GQLError) [(Variant, [ClientPreDeclaration])]
-> CodeGenT
     LocalContext
     (Result GQLError)
     ([Variant], [[ClientPreDeclaration]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnionTag
 -> CodeGenT
      LocalContext (Result GQLError) (Variant, [ClientPreDeclaration]))
-> [UnionTag]
-> CodeGenT
     LocalContext (Result GQLError) [(Variant, [ClientPreDeclaration])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([FieldName]
-> UnionTag
-> CodeGenT
     LocalContext (Result GQLError) (Variant, [ClientPreDeclaration])
getVariant [FieldName]
namespace) [UnionTag]
variants
    (Variant
fallbackCons, [ClientPreDeclaration]
fallBackTypes) <- CodeGenT
  LocalContext (Result GQLError) (Variant, [ClientPreDeclaration])
-> (MergeMap 'False FieldName (Selection VALID)
    -> CodeGenT
         LocalContext (Result GQLError) (Variant, [ClientPreDeclaration]))
-> Maybe (MergeMap 'False FieldName (Selection VALID))
-> CodeGenT
     LocalContext (Result GQLError) (Variant, [ClientPreDeclaration])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CodeGenTypeName
-> CodeGenT
     LocalContext (Result GQLError) (Variant, [ClientPreDeclaration])
getEmptyFallback CodeGenTypeName
cgTypeName) ([FieldName]
-> UnionTag
-> CodeGenT
     LocalContext (Result GQLError) (Variant, [ClientPreDeclaration])
getVariant [FieldName]
namespace (UnionTag
 -> CodeGenT
      LocalContext (Result GQLError) (Variant, [ClientPreDeclaration]))
-> (MergeMap 'False FieldName (Selection VALID) -> UnionTag)
-> MergeMap 'False FieldName (Selection VALID)
-> CodeGenT
     LocalContext (Result GQLError) (Variant, [ClientPreDeclaration])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> SelectionSet VALID -> UnionTag
UnionTag (TypeDefinition ANY VALID -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition ANY VALID
dType)) Maybe (MergeMap 'False FieldName (Selection VALID))
Maybe (SelectionSet VALID)
interface
    let typeDef :: CodeGenType
typeDef = CodeGenType {CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName, cgConstructors :: [CodeGenConstructor]
cgConstructors = (Variant -> CodeGenConstructor)
-> [Variant] -> [CodeGenConstructor]
forall a b. (a -> b) -> [a] -> [b]
map Variant -> CodeGenConstructor
buildVariantConstructor ([Variant]
cons [Variant] -> [Variant] -> [Variant]
forall a. Semigroup a => a -> a -> a
<> [Variant
fallbackCons]), cgDerivations :: [DerivingClass]
cgDerivations = [DerivingClass]
defaultDerivations}
    Text -> CodeGenT LocalContext (Result GQLError) ()
forall (m :: * -> *). MonadState Flags m => Text -> m ()
langExtension Text
"LambdaCase"
    (CodeGenTypeName, [ClientPreDeclaration])
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeGenTypeName
cgTypeName, [CodeGenType -> ClientPreDeclaration
ClientType CodeGenType
typeDef, CodeGenTypeName
-> [(UnionPat, (CodeGenTypeName, Maybe String))]
-> ClientPreDeclaration
FromJSONUnionClass CodeGenTypeName
cgTypeName ((Variant -> (UnionPat, (CodeGenTypeName, Maybe String)))
-> [Variant] -> [(UnionPat, (CodeGenTypeName, Maybe String))]
forall a b. (a -> b) -> [a] -> [b]
map Variant -> (UnionPat, (CodeGenTypeName, Maybe String))
forall {f :: * -> *} {b} {a}.
(Functor f, IsString b) =>
(CodeGenTypeName, f a) -> (UnionPat, (CodeGenTypeName, f b))
tagConstructor [Variant]
cons [(UnionPat, (CodeGenTypeName, Maybe String))]
-> [(UnionPat, (CodeGenTypeName, Maybe String))]
-> [(UnionPat, (CodeGenTypeName, Maybe String))]
forall a. Semigroup a => a -> a -> a
<> [(String -> UnionPat
UVar String
"_fallback", Variant -> (CodeGenTypeName, Maybe String)
forall {f :: * -> *} {b} {a} {a}.
(Functor f, IsString b) =>
(a, f a) -> (a, f b)
mapFallback Variant
fallbackCons)])] [ClientPreDeclaration]
-> [ClientPreDeclaration] -> [ClientPreDeclaration]
forall a. Semigroup a => a -> a -> a
<> [[ClientPreDeclaration]] -> [ClientPreDeclaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ClientPreDeclaration]]
subTypes [ClientPreDeclaration]
-> [ClientPreDeclaration] -> [ClientPreDeclaration]
forall a. Semigroup a => a -> a -> a
<> [ClientPreDeclaration]
fallBackTypes)
  where
    tagConstructor :: (CodeGenTypeName, f a) -> (UnionPat, (CodeGenTypeName, f b))
tagConstructor (CodeGenTypeName
name, f a
x) = (TypeName -> UnionPat
UString (TypeName -> UnionPat) -> TypeName -> UnionPat
forall a b. (a -> b) -> a -> b
$ CodeGenTypeName -> TypeName
typename CodeGenTypeName
name, (CodeGenTypeName
name, (a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> a -> b
forall a b. a -> b -> a
const b
"v") f a
x))
    mapFallback :: (a, f a) -> (a, f b)
mapFallback (a
x, f a
y) = (a
x, (a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> a -> b
forall a b. a -> b -> a
const b
"v") f a
y)

checkTypename :: Position -> [FieldName] -> Maybe (SelectionSet VALID) -> UnionTag -> LocalM ()
checkTypename :: Position
-> [FieldName]
-> Maybe (SelectionSet VALID)
-> UnionTag
-> CodeGenT LocalContext (Result GQLError) ()
checkTypename Position
pos [FieldName]
path Maybe (SelectionSet VALID)
iFace UnionTag {TypeName
SelectionSet VALID
unionTagName :: TypeName
unionTagSelection :: SelectionSet VALID
unionTagName :: UnionTag -> TypeName
unionTagSelection :: UnionTag -> SelectionSet VALID
..}
  | (MergeMap 'False FieldName (Selection VALID) -> Bool)
-> [MergeMap 'False FieldName (Selection VALID)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FieldName -> MergeMap 'False FieldName (Selection VALID) -> Bool
forall a. FieldName -> MergeMap 'False FieldName a -> Bool
forall k (m :: * -> *) a. IsMap k m => k -> m a -> Bool
member FieldName
"__typename") (MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
unionTagSelection MergeMap 'False FieldName (Selection VALID)
-> [MergeMap 'False FieldName (Selection VALID)]
-> [MergeMap 'False FieldName (Selection VALID)]
forall a. a -> [a] -> [a]
: Maybe (MergeMap 'False FieldName (Selection VALID))
-> [MergeMap 'False FieldName (Selection VALID)]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (MergeMap 'False FieldName (Selection VALID))
Maybe (SelectionSet VALID)
iFace) = () -> CodeGenT LocalContext (Result GQLError) ()
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise =
      GQLError -> CodeGenT LocalContext (Result GQLError) ()
warning (GQLError -> CodeGenT LocalContext (Result GQLError) ())
-> GQLError -> CodeGenT LocalContext (Result GQLError) ()
forall a b. (a -> b) -> a -> b
$
        GQLError -> [PropName] -> GQLError
withPath
          (GQLError
"missing \"__typename\" for selection " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
unionTagName GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
". this can lead to undesired behavior at runtime!")
          ((FieldName -> PropName) -> [FieldName] -> [PropName]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> PropName
PropName (Text -> PropName) -> (FieldName -> Text) -> FieldName -> PropName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName) [FieldName]
path)
          GQLError -> Position -> GQLError
`at` Position
pos

type Variant = (CodeGenTypeName, Maybe TypeName)

getEmptyFallback :: CodeGenTypeName -> LocalM (Variant, [ClientPreDeclaration])
getEmptyFallback :: CodeGenTypeName
-> CodeGenT
     LocalContext (Result GQLError) (Variant, [ClientPreDeclaration])
getEmptyFallback CodeGenTypeName
name = (Variant, [ClientPreDeclaration])
-> CodeGenT
     LocalContext (Result GQLError) (Variant, [ClientPreDeclaration])
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CodeGenTypeName
name, Maybe TypeName
forall a. Maybe a
Nothing), [])

buildVariantConstructor :: Variant -> CodeGenConstructor
buildVariantConstructor :: Variant -> CodeGenConstructor
buildVariantConstructor (CodeGenTypeName
conName, Maybe TypeName
ref) =
  CodeGenConstructor
    { constructorName :: CodeGenTypeName
constructorName = CodeGenTypeName
conName,
      constructorFields :: [CodeGenField]
constructorFields =
        ( \TypeName
fieldType ->
            CodeGenField
              { fieldName :: FieldName
fieldName = FieldName
"_",
                TypeName
fieldType :: TypeName
fieldType :: TypeName
fieldType,
                wrappers :: [FIELD_TYPE_WRAPPER]
wrappers = [],
                fieldIsNullable :: Bool
fieldIsNullable = Bool
False
              }
        )
          (TypeName -> CodeGenField) -> [TypeName] -> [CodeGenField]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TypeName -> [TypeName]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe TypeName
ref
    }

getVariant :: [FieldName] -> UnionTag -> LocalM (Variant, [ClientPreDeclaration])
getVariant :: [FieldName]
-> UnionTag
-> CodeGenT
     LocalContext (Result GQLError) (Variant, [ClientPreDeclaration])
getVariant [FieldName]
path (UnionTag TypeName
selectedTyName SelectionSet VALID
selectionVariant) = do
  -- traceShow (map getSelectionOrigins variants)
  TypeDefinition ANY VALID
conDatatype <- TypeName -> LocalM (TypeDefinition ANY VALID)
getType TypeName
selectedTyName
  let name :: CodeGenTypeName
name = [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName [FieldName]
path [] TypeName
selectedTyName
  (CodeGenTypeName
n, [ClientPreDeclaration]
types) <- [FieldName]
-> CodeGenTypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
genObjectTypeWithFragment [FieldName]
path CodeGenTypeName
name TypeDefinition ANY VALID
conDatatype SelectionSet VALID
selectionVariant
  (Variant, [ClientPreDeclaration])
-> CodeGenT
     LocalContext (Result GQLError) (Variant, [ClientPreDeclaration])
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( ( [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName ([FieldName]
path [FieldName] -> [FieldName] -> [FieldName]
forall a. Semigroup a => a -> a -> a
<> [FieldName
"variant"]) [] TypeName
selectedTyName,
        TypeName -> Maybe TypeName
forall a. a -> Maybe a
Just (CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
n)
      ),
      [ClientPreDeclaration]
types
    )

getFragmentOrigin :: SelectionSet VALID -> Maybe FragmentName
getFragmentOrigin :: SelectionSet VALID -> Maybe FragmentName
getFragmentOrigin SelectionSet VALID
x = case Set (Maybe FragmentName) -> [Maybe FragmentName]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([Maybe FragmentName] -> Set (Maybe FragmentName)
forall a. Ord a => [a] -> Set a
S.fromList ((Selection VALID -> Maybe FragmentName)
-> [Selection VALID] -> [Maybe FragmentName]
forall a b. (a -> b) -> [a] -> [b]
map Selection VALID -> Maybe FragmentName
forall (s :: Stage). Selection s -> Maybe FragmentName
selectionOrigin ([Selection VALID] -> [Maybe FragmentName])
-> [Selection VALID] -> [Maybe FragmentName]
forall a b. (a -> b) -> a -> b
$ MergeMap 'False FieldName (Selection VALID) -> [Selection VALID]
forall a. MergeMap 'False FieldName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
x)) of
  [Just FragmentName
name] -> FragmentName -> Maybe FragmentName
forall a. a -> Maybe a
Just FragmentName
name
  [Maybe FragmentName]
_ -> Maybe FragmentName
forall a. Maybe a
Nothing

genObjectTypeWithFragment ::
  [FieldName] ->
  CodeGenTypeName ->
  TypeDefinition ANY VALID ->
  SelectionSet VALID ->
  LocalM (CodeGenTypeName, [ClientPreDeclaration])
genObjectTypeWithFragment :: [FieldName]
-> CodeGenTypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
genObjectTypeWithFragment [FieldName]
namespace CodeGenTypeName
cgTypeName TypeDefinition ANY VALID
dataType SelectionSet VALID
recordSelSet = do
  case SelectionSet VALID -> Maybe FragmentName
getFragmentOrigin SelectionSet VALID
recordSelSet of
    Just FragmentName
name -> do
      Bool
exists <- FragmentName -> LocalM Bool
existFragment FragmentName
name
      let tName :: CodeGenTypeName
tName = [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName [] [] (TypeName
"Fragment" TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> FragmentName -> TypeName
forall a b. Coercible a b => a -> b
coerce FragmentName
name)
      if Bool
exists
        then (CodeGenTypeName, [ClientPreDeclaration])
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeGenTypeName
tName, [])
        else FragmentName
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
forall a. FragmentName -> LocalM a -> LocalM a
registerFragment FragmentName
name ([FieldName]
-> CodeGenTypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
genObjectType [FieldName]
namespace CodeGenTypeName
tName TypeDefinition ANY VALID
dataType SelectionSet VALID
recordSelSet)
    Maybe FragmentName
Nothing -> [FieldName]
-> CodeGenTypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
genObjectType [FieldName]
namespace CodeGenTypeName
cgTypeName TypeDefinition ANY VALID
dataType SelectionSet VALID
recordSelSet

genObjectType ::
  [FieldName] ->
  CodeGenTypeName ->
  TypeDefinition ANY VALID ->
  SelectionSet VALID ->
  LocalM (CodeGenTypeName, [ClientPreDeclaration])
genObjectType :: [FieldName]
-> CodeGenTypeName
-> TypeDefinition ANY VALID
-> SelectionSet VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
genObjectType [FieldName]
namespace CodeGenTypeName
cgTypeName TypeDefinition ANY VALID
datatype SelectionSet VALID
selSet = do
  ([CodeGenField]
fields, [[ClientPreDeclaration]]
subTypes) <- [(CodeGenField, [ClientPreDeclaration])]
-> ([CodeGenField], [[ClientPreDeclaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(CodeGenField, [ClientPreDeclaration])]
 -> ([CodeGenField], [[ClientPreDeclaration]]))
-> CodeGenT
     LocalContext
     (Result GQLError)
     [(CodeGenField, [ClientPreDeclaration])]
-> CodeGenT
     LocalContext
     (Result GQLError)
     ([CodeGenField], [[ClientPreDeclaration]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Selection VALID
 -> CodeGenT
      LocalContext
      (Result GQLError)
      (CodeGenField, [ClientPreDeclaration]))
-> [Selection VALID]
-> CodeGenT
     LocalContext
     (Result GQLError)
     [(CodeGenField, [ClientPreDeclaration])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([FieldName]
-> TypeDefinition ANY VALID
-> Selection VALID
-> CodeGenT
     LocalContext
     (Result GQLError)
     (CodeGenField, [ClientPreDeclaration])
genField [FieldName]
namespace TypeDefinition ANY VALID
datatype) (MergeMap 'False FieldName (Selection VALID) -> [Selection VALID]
forall a. MergeMap 'False FieldName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
selSet)
  let constructor :: CodeGenConstructor
constructor = CodeGenConstructor {constructorName :: CodeGenTypeName
constructorName = CodeGenTypeName
cgTypeName, constructorFields :: [CodeGenField]
constructorFields = [CodeGenField]
fields}
  let definition :: CodeGenType
definition = CodeGenType {CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName, cgConstructors :: [CodeGenConstructor]
cgConstructors = [CodeGenConstructor
constructor], cgDerivations :: [DerivingClass]
cgDerivations = [DerivingClass]
defaultDerivations}
  (CodeGenTypeName, [ClientPreDeclaration])
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeGenTypeName
cgTypeName, [CodeGenType -> ClientPreDeclaration
ClientType CodeGenType
definition, CodeGenTypeName -> CodeGenConstructor -> ClientPreDeclaration
FromJSONObjectClass CodeGenTypeName
cgTypeName CodeGenConstructor
constructor] [ClientPreDeclaration]
-> [ClientPreDeclaration] -> [ClientPreDeclaration]
forall a. Semigroup a => a -> a -> a
<> [[ClientPreDeclaration]] -> [ClientPreDeclaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ClientPreDeclaration]]
subTypes)

genField :: [FieldName] -> TypeDefinition ANY VALID -> Selection VALID -> LocalM (CodeGenField, [ClientPreDeclaration])
genField :: [FieldName]
-> TypeDefinition ANY VALID
-> Selection VALID
-> CodeGenT
     LocalContext
     (Result GQLError)
     (CodeGenField, [ClientPreDeclaration])
genField [FieldName]
path TypeDefinition ANY VALID
datatype Selection VALID
sel = do
  let fieldName :: FieldName
fieldName = Selection VALID -> FieldName
forall k a. KeyOf k a => a -> k
keyOf Selection VALID
sel
  let fieldPath :: [FieldName]
fieldPath = [FieldName]
path [FieldName] -> [FieldName] -> [FieldName]
forall a. Semigroup a => a -> a -> a
<> [FieldName
fieldName]
  (TypeDefinition ANY VALID
fieldDataType, TypeRef {TypeName
TypeWrapper
typeConName :: TypeName
typeWrappers :: TypeWrapper
typeConName :: TypeRef -> TypeName
typeWrappers :: TypeRef -> TypeWrapper
..}) <- [FieldName]
-> TypeDefinition ANY VALID
-> Selection VALID
-> LocalM (TypeDefinition ANY VALID, TypeRef)
getFieldType [FieldName]
fieldPath TypeDefinition ANY VALID
datatype Selection VALID
sel
  (CodeGenTypeName
fieldTypeName, [ClientPreDeclaration]
subTypes) <- TypeName
-> [FieldName]
-> TypeDefinition ANY VALID
-> Selection VALID
-> LocalM (CodeGenTypeName, [ClientPreDeclaration])
subTypesBySelection TypeName
typeConName [FieldName]
fieldPath TypeDefinition ANY VALID
fieldDataType Selection VALID
sel
  (CodeGenField, [ClientPreDeclaration])
-> CodeGenT
     LocalContext
     (Result GQLError)
     (CodeGenField, [ClientPreDeclaration])
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( CodeGenField
        { FieldName
fieldName :: FieldName
fieldName :: FieldName
fieldName,
          fieldType :: TypeName
fieldType = CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
fieldTypeName,
          wrappers :: [FIELD_TYPE_WRAPPER]
wrappers = [TypeWrapper -> FIELD_TYPE_WRAPPER
GQL_WRAPPER TypeWrapper
typeWrappers],
          fieldIsNullable :: Bool
fieldIsNullable = TypeWrapper -> Bool
forall a. Nullable a => a -> Bool
isNullable TypeWrapper
typeWrappers
        },
      [ClientPreDeclaration]
subTypes
    )

getFieldType ::
  [FieldName] ->
  TypeDefinition ANY VALID ->
  Selection VALID ->
  LocalM (TypeDefinition ANY VALID, TypeRef)
getFieldType :: [FieldName]
-> TypeDefinition ANY VALID
-> Selection VALID
-> LocalM (TypeDefinition ANY VALID, TypeRef)
getFieldType
  [FieldName]
path
  TypeDefinition {TypeContent TRUE ANY VALID
typeContent :: TypeContent TRUE ANY VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent, TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName}
  Selection
    { FieldName
selectionName :: FieldName
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionName,
      Position
selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition :: Position
selectionPosition
    } = FieldName
-> TypeContent TRUE ANY VALID -> LocalM (FieldDefinition OUT VALID)
lookupField FieldName
selectionName TypeContent TRUE ANY VALID
typeContent LocalM (FieldDefinition OUT VALID)
-> (FieldDefinition OUT VALID
    -> LocalM (TypeDefinition ANY VALID, TypeRef))
-> LocalM (TypeDefinition ANY VALID, TypeRef)
forall a b.
CodeGenT LocalContext (Result GQLError) a
-> (a -> CodeGenT LocalContext (Result GQLError) b)
-> CodeGenT LocalContext (Result GQLError) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FieldDefinition OUT VALID
-> LocalM (TypeDefinition ANY VALID, TypeRef)
processFieldDefinition
    where
      processFieldDefinition :: FieldDefinition OUT VALID
-> LocalM (TypeDefinition ANY VALID, TypeRef)
processFieldDefinition FieldDefinition {fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = TypeRef {TypeName
TypeWrapper
typeConName :: TypeRef -> TypeName
typeWrappers :: TypeRef -> TypeWrapper
typeConName :: TypeName
typeWrappers :: TypeWrapper
..}, Maybe Text
Maybe (FieldContent TRUE OUT VALID)
Directives VALID
FieldName
fieldDescription :: Maybe Text
fieldName :: FieldName
fieldContent :: Maybe (FieldContent TRUE OUT VALID)
fieldDirectives :: Directives VALID
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Text
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
..} = do
        (Maybe Text -> GQLError)
-> Directives VALID -> CodeGenT LocalContext (Result GQLError) ()
forall (s :: Stage).
(Maybe Text -> GQLError)
-> Directives s -> CodeGenT LocalContext (Result GQLError) ()
deprecationWarning Maybe Text -> GQLError
fieldWarnings Directives VALID
fieldDirectives
        TypeDefinition ANY VALID
typeDef <- TypeName -> LocalM (TypeDefinition ANY VALID)
getType TypeName
typeConName
        (TypeDefinition ANY VALID, TypeRef)
-> LocalM (TypeDefinition ANY VALID, TypeRef)
forall a. a -> CodeGenT LocalContext (Result GQLError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition ANY VALID
typeDef, TypeRef {typeConName :: TypeName
typeConName = CodeGenTypeName -> TypeName
getFullName ([FieldName] -> TypeDefinition ANY VALID -> CodeGenTypeName
forall (a :: TypeCategory).
[FieldName] -> TypeDefinition a VALID -> CodeGenTypeName
typeFrom [FieldName]
path TypeDefinition ANY VALID
typeDef), TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers :: TypeWrapper
..})
        where
          fieldWarnings :: Maybe Text -> GQLError
fieldWarnings Maybe Text
reason =
            ( TypeName -> FieldName -> Maybe Text -> GQLError
deprecatedField TypeName
typeName FieldName
selectionName Maybe Text
reason
                GQLError -> Position -> GQLError
`at` Position
selectionPosition
            )
              GQLError -> [PropName] -> GQLError
`withPath` (FieldName -> PropName) -> [FieldName] -> [PropName]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> PropName
PropName (Text -> PropName) -> (FieldName -> Text) -> FieldName -> PropName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName) [FieldName]
path