{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Schema.Internal
  ( KindedProxy (..),
    KindedType (..),
    builder,
    inputType,
    outputType,
    setProxyType,
    unpackMs,
    UpdateDef (..),
    withObject,
    TyContentM,
    asObjectType,
    fromSchema,
    updateByContent,
  )
where

-- MORPHEUS

import Control.Applicative (Applicative (..))
import Control.Monad.Fail (fail)
import Data.Foldable (concatMap, traverse_)
import Data.Functor (($>), (<$>), Functor (..))
import Data.List (partition)
import qualified Data.Map as M
import Data.Maybe (Maybe (..), fromMaybe)
import Data.Morpheus.Error (globalErrorMessage)
import Data.Morpheus.Internal.Utils
  ( Failure (..),
    singleton,
  )
import Data.Morpheus.Server.Deriving.Utils
  ( ConsRep (..),
    FieldRep (..),
    ResRep (..),
    fieldTypeName,
    isEmptyConstraint,
    isUnionRef,
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType (..),
    TypeData (..),
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    insertType,
    updateSchema,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    DataEnumValue (..),
    Description,
    Directives,
    FieldContent (..),
    FieldDefinition (..),
    FieldName,
    FieldName (..),
    FieldsDefinition,
    IN,
    LEAF,
    OBJECT,
    OUT,
    Schema (..),
    TRUE,
    Token,
    TypeCategory,
    TypeContent (..),
    TypeDefinition (..),
    TypeName (..),
    UnionMember (..),
    VALID,
    mkEnumContent,
    mkField,
    mkInputValue,
    mkType,
    mkUnionMember,
    msg,
    unsafeFromFields,
  )
import Data.Morpheus.Types.Internal.Resolving
  ( Eventless,
    Result (..),
  )
import Data.Semigroup ((<>))
import Data.Traversable (traverse)
import Language.Haskell.TH (Exp, Q)
import Prelude
  ( ($),
    (.),
    Bool (..),
    Show (..),
    map,
    null,
    otherwise,
    sequence,
  )

-- | context , like Proxy with multiple parameters
-- * 'kind': object, scalar, enum ...
-- * 'a': actual gql type
data KindedProxy k a
  = KindedProxy

data KindedType (cat :: TypeCategory) a where
  InputType :: KindedType IN a
  OutputType :: KindedType OUT a

-- converts:
--   f a -> KindedType IN a
-- or
--  f k a -> KindedType IN a
inputType :: f a -> KindedType IN a
inputType :: f a -> KindedType IN a
inputType f a
_ = KindedType IN a
forall k (a :: k). KindedType IN a
InputType

outputType :: f a -> KindedType OUT a
outputType :: f a -> KindedType OUT a
outputType f a
_ = KindedType OUT a
forall k (a :: k). KindedType OUT a
OutputType

deriving instance Show (KindedType cat a)

setProxyType :: f b -> kinded k a -> KindedProxy k b
setProxyType :: f b -> kinded k a -> KindedProxy k b
setProxyType f b
_ kinded k a
_ = KindedProxy k b
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy

fromSchema :: Eventless (Schema VALID) -> Q Exp
fromSchema :: Eventless (Schema VALID) -> Q Exp
fromSchema Success {} = [|()|]
fromSchema Failure {GQLErrors
errors :: forall events a. Result events a -> GQLErrors
errors :: GQLErrors
errors} = String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (GQLErrors -> String
forall a. Show a => a -> String
show GQLErrors
errors)

withObject :: (GQLType a) => KindedType c a -> TypeContent TRUE any s -> SchemaT (FieldsDefinition c s)
withObject :: KindedType c a
-> TypeContent TRUE any s -> SchemaT (FieldsDefinition c s)
withObject KindedType c a
InputType DataInputObject {FieldsDefinition IN s
inputObjectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IN a) a s -> FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
inputObjectFields} = FieldsDefinition IN s -> SchemaT (FieldsDefinition IN s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldsDefinition IN s
inputObjectFields
withObject KindedType c a
OutputType DataObject {FieldsDefinition OUT s
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields} = FieldsDefinition OUT s -> SchemaT (FieldsDefinition OUT s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldsDefinition OUT s
objectFields
withObject KindedType c a
x TypeContent TRUE any s
_ = KindedType c a -> SchemaT (FieldsDefinition c s)
forall (c :: TypeCategory) a b.
GQLType a =>
KindedType c a -> SchemaT b
failureOnlyObject KindedType c a
x

asObjectType ::
  GQLType a =>
  (f2 a -> SchemaT (FieldsDefinition OUT CONST)) ->
  f2 a ->
  SchemaT (TypeDefinition OBJECT CONST)
asObjectType :: (f2 a -> SchemaT (FieldsDefinition OUT CONST))
-> f2 a -> SchemaT (TypeDefinition OBJECT CONST)
asObjectType f2 a -> SchemaT (FieldsDefinition OUT CONST)
f f2 a
proxy = (FieldsDefinition OUT CONST
-> TypeName -> TypeDefinition OBJECT CONST
`mkObjectType` TypeData -> TypeName
gqlTypeName (f2 a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type f2 a
proxy)) (FieldsDefinition OUT CONST -> TypeDefinition OBJECT CONST)
-> SchemaT (FieldsDefinition OUT CONST)
-> SchemaT (TypeDefinition OBJECT CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f2 a -> SchemaT (FieldsDefinition OUT CONST)
f f2 a
proxy

mkObjectType :: FieldsDefinition OUT CONST -> TypeName -> TypeDefinition OBJECT CONST
mkObjectType :: FieldsDefinition OUT CONST
-> TypeName -> TypeDefinition OBJECT CONST
mkObjectType FieldsDefinition OUT CONST
fields TypeName
typeName = TypeName
-> TypeContent TRUE OBJECT CONST -> TypeDefinition OBJECT CONST
forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
typeName ([TypeName]
-> FieldsDefinition OUT CONST
-> TypeContent (ELEM OBJECT OBJECT) OBJECT CONST
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject [] FieldsDefinition OUT CONST
fields)

failureOnlyObject :: forall c a b. (GQLType a) => KindedType c a -> SchemaT b
failureOnlyObject :: KindedType c a -> SchemaT b
failureOnlyObject KindedType c a
proxy =
  GQLErrors -> SchemaT b
forall error (f :: * -> *) v. Failure error f => error -> f v
failure
    (GQLErrors -> SchemaT b) -> GQLErrors -> SchemaT b
forall a b. (a -> b) -> a -> b
$ Message -> GQLErrors
globalErrorMessage
    (Message -> GQLErrors) -> Message -> GQLErrors
forall a b. (a -> b) -> a -> b
$ TypeName -> Message
forall a. Msg a => a -> Message
msg (TypeData -> TypeName
gqlTypeName (TypeData -> TypeName) -> TypeData -> TypeName
forall a b. (a -> b) -> a -> b
$ KindedType c a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type KindedType c a
proxy) Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" should have only one nonempty constructor"

type TyContentM kind = (SchemaT (Maybe (FieldContent TRUE kind CONST)))

type TyContent kind = Maybe (FieldContent TRUE kind CONST)

unpackM :: FieldRep (TyContentM k) -> SchemaT (FieldRep (TyContent k))
unpackM :: FieldRep (TyContentM k) -> SchemaT (FieldRep (TyContent k))
unpackM FieldRep {Bool
FieldName
TypeRef
TyContentM k
fieldValue :: forall a. FieldRep a -> a
fieldIsObject :: forall a. FieldRep a -> Bool
fieldTypeRef :: forall a. FieldRep a -> TypeRef
fieldSelector :: forall a. FieldRep a -> FieldName
fieldValue :: TyContentM k
fieldIsObject :: Bool
fieldTypeRef :: TypeRef
fieldSelector :: FieldName
..} =
  FieldName
-> TypeRef -> Bool -> TyContent k -> FieldRep (TyContent k)
forall a. FieldName -> TypeRef -> Bool -> a -> FieldRep a
FieldRep FieldName
fieldSelector TypeRef
fieldTypeRef Bool
fieldIsObject
    (TyContent k -> FieldRep (TyContent k))
-> TyContentM k -> SchemaT (FieldRep (TyContent k))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyContentM k
fieldValue

unpackCons :: ConsRep (TyContentM k) -> SchemaT (ConsRep (TyContent k))
unpackCons :: ConsRep (TyContentM k) -> SchemaT (ConsRep (TyContent k))
unpackCons ConsRep {[FieldRep (TyContentM k)]
TypeName
consFields :: forall v. ConsRep v -> [FieldRep v]
consName :: forall v. ConsRep v -> TypeName
consFields :: [FieldRep (TyContentM k)]
consName :: TypeName
..} = TypeName -> [FieldRep (TyContent k)] -> ConsRep (TyContent k)
forall v. TypeName -> [FieldRep v] -> ConsRep v
ConsRep TypeName
consName ([FieldRep (TyContent k)] -> ConsRep (TyContent k))
-> SchemaT [FieldRep (TyContent k)]
-> SchemaT (ConsRep (TyContent k))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldRep (TyContentM k) -> SchemaT (FieldRep (TyContent k)))
-> [FieldRep (TyContentM k)] -> SchemaT [FieldRep (TyContent k)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldRep (TyContentM k) -> SchemaT (FieldRep (TyContent k))
forall (k :: TypeCategory).
FieldRep (TyContentM k) -> SchemaT (FieldRep (TyContent k))
unpackM [FieldRep (TyContentM k)]
consFields

unpackMs :: [ConsRep (TyContentM k)] -> SchemaT [ConsRep (TyContent k)]
unpackMs :: [ConsRep (TyContentM k)] -> SchemaT [ConsRep (TyContent k)]
unpackMs = (ConsRep (TyContentM k) -> SchemaT (ConsRep (TyContent k)))
-> [ConsRep (TyContentM k)] -> SchemaT [ConsRep (TyContent k)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConsRep (TyContentM k) -> SchemaT (ConsRep (TyContent k))
forall (k :: TypeCategory).
ConsRep (TyContentM k) -> SchemaT (ConsRep (TyContent k))
unpackCons

builder ::
  GQLType a =>
  KindedType kind a ->
  [ConsRep (TyContent kind)] ->
  SchemaT (TypeContent TRUE kind CONST)
builder :: KindedType kind a
-> [ConsRep (TyContent kind)]
-> SchemaT (TypeContent TRUE kind CONST)
builder KindedType kind a
scope [ConsRep {[FieldRep (TyContent kind)]
consFields :: [FieldRep (TyContent kind)]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields}] = [TypeName] -> TypeContent TRUE kind CONST
buildObj ([TypeName] -> TypeContent TRUE kind CONST)
-> SchemaT [TypeName] -> SchemaT (TypeContent TRUE kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SchemaT TypeName] -> SchemaT [TypeName]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (KindedType kind a -> [SchemaT TypeName]
forall a (f :: * -> *). GQLType a => f a -> [SchemaT TypeName]
implements KindedType kind a
scope)
  where
    buildObj :: [TypeName] -> TypeContent TRUE kind CONST
buildObj [TypeName]
interfaces = [TypeName]
-> KindedType kind a
-> FieldsDefinition kind CONST
-> TypeContent TRUE kind CONST
forall k (kind :: TypeCategory) (a :: k).
[TypeName]
-> KindedType kind a
-> FieldsDefinition kind CONST
-> TypeContent TRUE kind CONST
wrapFields [TypeName]
interfaces KindedType kind a
scope ([FieldRep (TyContent kind)] -> FieldsDefinition kind CONST
forall (kind :: TypeCategory).
[FieldRep (Maybe (FieldContent TRUE kind CONST))]
-> FieldsDefinition kind CONST
mkFieldsDefinition [FieldRep (TyContent kind)]
consFields)
builder KindedType kind a
scope [ConsRep (TyContent kind)]
cons = [ConsRep (TyContent kind)] -> SchemaT (TypeContent TRUE kind CONST)
genericUnion [ConsRep (TyContent kind)]
cons
  where
    typeData :: TypeData
typeData = KindedType kind a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type KindedType kind a
scope
    genericUnion :: [ConsRep (TyContent kind)] -> SchemaT (TypeContent TRUE kind CONST)
genericUnion =
      KindedType kind a
-> TypeData
-> ResRep (TyContent kind)
-> SchemaT (TypeContent TRUE kind CONST)
forall k (kind :: TypeCategory) (a :: k).
KindedType kind a
-> TypeData
-> ResRep (Maybe (FieldContent TRUE kind CONST))
-> SchemaT (TypeContent TRUE kind CONST)
mkUnionType KindedType kind a
scope TypeData
typeData
        (ResRep (TyContent kind) -> SchemaT (TypeContent TRUE kind CONST))
-> ([ConsRep (TyContent kind)] -> ResRep (TyContent kind))
-> [ConsRep (TyContent kind)]
-> SchemaT (TypeContent TRUE kind CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> [ConsRep (TyContent kind)] -> ResRep (TyContent kind)
forall (kind :: TypeCategory).
TypeName
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> ResRep (Maybe (FieldContent TRUE kind CONST))
analyseRep (TypeData -> TypeName
gqlTypeName TypeData
typeData)

class UpdateDef value where
  updateDef :: GQLType a => f a -> value -> value

instance UpdateDef (TypeContent TRUE c CONST) where
  updateDef :: f a -> TypeContent TRUE c CONST -> TypeContent TRUE c CONST
updateDef f a
proxy DataObject {objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectFields = FieldsDefinition OUT CONST
fields, [TypeName]
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
objectImplements :: [TypeName]
..} =
    DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject {objectFields :: FieldsDefinition OUT CONST
objectFields = (FieldDefinition OUT CONST -> FieldDefinition OUT CONST)
-> FieldsDefinition OUT CONST -> FieldsDefinition OUT CONST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f a -> FieldDefinition OUT CONST -> FieldDefinition OUT CONST
forall value a (f :: * -> *).
(UpdateDef value, GQLType a) =>
f a -> value -> value
updateDef f a
proxy) FieldsDefinition OUT CONST
fields, [TypeName]
objectImplements :: [TypeName]
objectImplements :: [TypeName]
..}
  updateDef f a
proxy DataInputObject {inputObjectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IN a) a s -> FieldsDefinition IN s
inputObjectFields = FieldsDefinition IN CONST
fields} =
    DataInputObject :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition IN s -> TypeContent (ELEM IN a) a s
DataInputObject {inputObjectFields :: FieldsDefinition IN CONST
inputObjectFields = (FieldDefinition IN CONST -> FieldDefinition IN CONST)
-> FieldsDefinition IN CONST -> FieldsDefinition IN CONST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f a -> FieldDefinition IN CONST -> FieldDefinition IN CONST
forall value a (f :: * -> *).
(UpdateDef value, GQLType a) =>
f a -> value -> value
updateDef f a
proxy) FieldsDefinition IN CONST
fields, ..}
  updateDef f a
proxy DataInterface {interfaceFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IMPLEMENTABLE a) a s -> FieldsDefinition OUT s
interfaceFields = FieldsDefinition OUT CONST
fields} =
    DataInterface :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> TypeContent (ELEM IMPLEMENTABLE a) a s
DataInterface {interfaceFields :: FieldsDefinition OUT CONST
interfaceFields = (FieldDefinition OUT CONST -> FieldDefinition OUT CONST)
-> FieldsDefinition OUT CONST -> FieldsDefinition OUT CONST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f a -> FieldDefinition OUT CONST -> FieldDefinition OUT CONST
forall value a (f :: * -> *).
(UpdateDef value, GQLType a) =>
f a -> value -> value
updateDef f a
proxy) FieldsDefinition OUT CONST
fields, ..}
  updateDef f a
proxy (DataEnum DataEnum CONST
enums) = DataEnum CONST -> TypeContent (ELEM LEAF c) c CONST
forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (ELEM LEAF a) a s
DataEnum (DataEnum CONST -> TypeContent (ELEM LEAF c) c CONST)
-> DataEnum CONST -> TypeContent (ELEM LEAF c) c CONST
forall a b. (a -> b) -> a -> b
$ (DataEnumValue CONST -> DataEnumValue CONST)
-> DataEnum CONST -> DataEnum CONST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f a -> DataEnumValue CONST -> DataEnumValue CONST
forall value a (f :: * -> *).
(UpdateDef value, GQLType a) =>
f a -> value -> value
updateDef f a
proxy) DataEnum CONST
enums
  updateDef f a
_ TypeContent TRUE c CONST
x = TypeContent TRUE c CONST
x

instance GetFieldContent cat => UpdateDef (FieldDefinition cat CONST) where
  updateDef :: f a -> FieldDefinition cat CONST -> FieldDefinition cat CONST
updateDef f a
proxy FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName, TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType :: TypeRef
fieldType, Maybe (FieldContent TRUE cat CONST)
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent :: Maybe (FieldContent TRUE cat CONST)
fieldContent} =
    FieldDefinition :: forall (cat :: TypeCategory) (s :: Stage).
Maybe Description
-> FieldName
-> TypeRef
-> Maybe (FieldContent TRUE cat s)
-> [Directive s]
-> FieldDefinition cat s
FieldDefinition
      { FieldName
fieldName :: FieldName
fieldName :: FieldName
fieldName,
        fieldDescription :: Maybe Description
fieldDescription = Description -> f a -> Maybe Description
forall a (f :: * -> *).
GQLType a =>
Description -> f a -> Maybe Description
lookupDescription (FieldName -> Description
readName FieldName
fieldName) f a
proxy,
        fieldDirectives :: [Directive CONST]
fieldDirectives = Description -> f a -> [Directive CONST]
forall a (f :: * -> *).
GQLType a =>
Description -> f a -> [Directive CONST]
lookupDirectives (FieldName -> Description
readName FieldName
fieldName) f a
proxy,
        fieldContent :: Maybe (FieldContent TRUE cat CONST)
fieldContent = FieldName
-> Maybe (FieldContent TRUE cat CONST)
-> f a
-> Maybe (FieldContent TRUE cat CONST)
forall (c :: TypeCategory) a (f :: * -> *).
(GetFieldContent c, GQLType a) =>
FieldName
-> Maybe (FieldContent TRUE c CONST)
-> f a
-> Maybe (FieldContent TRUE c CONST)
getFieldContent FieldName
fieldName Maybe (FieldContent TRUE cat CONST)
fieldContent f a
proxy,
        TypeRef
fieldType :: TypeRef
fieldType :: TypeRef
..
      }

instance UpdateDef (DataEnumValue CONST) where
  updateDef :: f a -> DataEnumValue CONST -> DataEnumValue CONST
updateDef f a
proxy DataEnumValue {TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumName :: TypeName
enumName} =
    DataEnumValue :: forall (s :: Stage).
Maybe Description -> TypeName -> [Directive s] -> DataEnumValue s
DataEnumValue
      { TypeName
enumName :: TypeName
enumName :: TypeName
enumName,
        enumDescription :: Maybe Description
enumDescription = Description -> f a -> Maybe Description
forall a (f :: * -> *).
GQLType a =>
Description -> f a -> Maybe Description
lookupDescription (TypeName -> Description
readTypeName TypeName
enumName) f a
proxy,
        enumDirectives :: [Directive CONST]
enumDirectives = Description -> f a -> [Directive CONST]
forall a (f :: * -> *).
GQLType a =>
Description -> f a -> [Directive CONST]
lookupDirectives (TypeName -> Description
readTypeName TypeName
enumName) f a
proxy
      }

lookupDescription :: GQLType a => Token -> f a -> Maybe Description
lookupDescription :: Description -> f a -> Maybe Description
lookupDescription Description
name = (Description
name Description -> Map Description Description -> Maybe Description
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup`) (Map Description Description -> Maybe Description)
-> (f a -> Map Description Description) -> f a -> Maybe Description
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Map Description Description
forall a (f :: * -> *).
GQLType a =>
f a -> Map Description Description
getDescriptions

lookupDirectives :: GQLType a => Token -> f a -> Directives CONST
lookupDirectives :: Description -> f a -> [Directive CONST]
lookupDirectives Description
name = [Directive CONST] -> Maybe [Directive CONST] -> [Directive CONST]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Directive CONST] -> [Directive CONST])
-> (f a -> Maybe [Directive CONST]) -> f a -> [Directive CONST]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Description
name Description
-> Map Description [Directive CONST] -> Maybe [Directive CONST]
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup`) (Map Description [Directive CONST] -> Maybe [Directive CONST])
-> (f a -> Map Description [Directive CONST])
-> f a
-> Maybe [Directive CONST]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Map Description [Directive CONST]
forall a (f :: * -> *).
GQLType a =>
f a -> Map Description [Directive CONST]
getDirectives

class GetFieldContent c where
  getFieldContent :: GQLType a => FieldName -> Maybe (FieldContent TRUE c CONST) -> f a -> Maybe (FieldContent TRUE c CONST)

instance GetFieldContent IN where
  getFieldContent :: FieldName
-> Maybe (FieldContent TRUE IN CONST)
-> f a
-> Maybe (FieldContent TRUE IN CONST)
getFieldContent FieldName
name Maybe (FieldContent TRUE IN CONST)
val f a
proxy =
    case FieldName
name FieldName
-> Map
     FieldName (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
-> Maybe (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` f a
-> Map
     FieldName (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
forall a (f :: * -> *).
GQLType a =>
f a
-> Map
     FieldName (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
getFieldContents f a
proxy of
      Just (Just Value CONST
x, Maybe (ArgumentsDefinition CONST)
_) -> FieldContent TRUE IN CONST -> Maybe (FieldContent TRUE IN CONST)
forall a. a -> Maybe a
Just (Value CONST -> FieldContent (ELEM IN IN) IN CONST
forall (s :: Stage) (cat :: TypeCategory).
Value s -> FieldContent (ELEM IN cat) cat s
DefaultInputValue Value CONST
x)
      Maybe (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
_ -> Maybe (FieldContent TRUE IN CONST)
val

instance GetFieldContent OUT where
  getFieldContent :: FieldName
-> Maybe (FieldContent TRUE OUT CONST)
-> f a
-> Maybe (FieldContent TRUE OUT CONST)
getFieldContent FieldName
name Maybe (FieldContent TRUE OUT CONST)
args f a
proxy =
    case FieldName
name FieldName
-> Map
     FieldName (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
-> Maybe (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` f a
-> Map
     FieldName (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
forall a (f :: * -> *).
GQLType a =>
f a
-> Map
     FieldName (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
getFieldContents f a
proxy of
      Just (Maybe (Value CONST)
_, Just ArgumentsDefinition CONST
x) -> FieldContent TRUE OUT CONST -> Maybe (FieldContent TRUE OUT CONST)
forall a. a -> Maybe a
Just (ArgumentsDefinition CONST -> FieldContent (ELEM OUT OUT) OUT CONST
forall (s :: Stage) (cat :: TypeCategory).
ArgumentsDefinition s -> FieldContent (ELEM OUT cat) cat s
FieldArgs ArgumentsDefinition CONST
x)
      Maybe (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
_ -> Maybe (FieldContent TRUE OUT CONST)
args

updateByContent ::
  GQLType a =>
  (f kind a -> SchemaT (TypeContent TRUE cat CONST)) ->
  f kind a ->
  SchemaT ()
updateByContent :: (f kind a -> SchemaT (TypeContent TRUE cat CONST))
-> f kind a -> SchemaT ()
updateByContent f kind a -> SchemaT (TypeContent TRUE cat CONST)
f f kind a
proxy =
  TypeFingerprint
-> (f kind a -> SchemaT (TypeDefinition cat CONST))
-> f kind a
-> SchemaT ()
forall a (cat :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT (TypeDefinition cat CONST)) -> a -> SchemaT ()
updateSchema
    (TypeData -> TypeFingerprint
gqlFingerprint (TypeData -> TypeFingerprint) -> TypeData -> TypeFingerprint
forall a b. (a -> b) -> a -> b
$ f kind a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type f kind a
proxy)
    f kind a -> SchemaT (TypeDefinition cat CONST)
deriveD
    f kind a
proxy
  where
    deriveD :: f kind a -> SchemaT (TypeDefinition cat CONST)
deriveD =
      (TypeContent TRUE cat CONST -> TypeDefinition cat CONST)
-> SchemaT (TypeContent TRUE cat CONST)
-> SchemaT (TypeDefinition cat CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( Maybe Description
-> TypeName
-> [Directive CONST]
-> TypeContent TRUE cat CONST
-> TypeDefinition cat CONST
forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition
            (f kind a -> Maybe Description
forall a (f :: * -> *). GQLType a => f a -> Maybe Description
description f kind a
proxy)
            (TypeData -> TypeName
gqlTypeName (f kind a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type f kind a
proxy))
            []
        )
        (SchemaT (TypeContent TRUE cat CONST)
 -> SchemaT (TypeDefinition cat CONST))
-> (f kind a -> SchemaT (TypeContent TRUE cat CONST))
-> f kind a
-> SchemaT (TypeDefinition cat CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f kind a -> SchemaT (TypeContent TRUE cat CONST)
f

analyseRep :: TypeName -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> ResRep (Maybe (FieldContent TRUE kind CONST))
analyseRep :: TypeName
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> ResRep (Maybe (FieldContent TRUE kind CONST))
analyseRep TypeName
baseName [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons =
  ResRep :: forall a. [TypeName] -> [TypeName] -> [ConsRep a] -> ResRep a
ResRep
    { enumCons :: [TypeName]
enumCons = (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName)
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName
forall v. ConsRep v -> TypeName
consName [ConsRep (Maybe (FieldContent TRUE kind CONST))]
enumRep,
      unionRef :: [TypeName]
unionRef = FieldRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName
forall k. FieldRep k -> TypeName
fieldTypeName (FieldRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName)
-> [FieldRep (Maybe (FieldContent TRUE kind CONST))] -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConsRep (Maybe (FieldContent TRUE kind CONST))
 -> [FieldRep (Maybe (FieldContent TRUE kind CONST))])
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> [FieldRep (Maybe (FieldContent TRUE kind CONST))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConsRep (Maybe (FieldContent TRUE kind CONST))
-> [FieldRep (Maybe (FieldContent TRUE kind CONST))]
forall v. ConsRep v -> [FieldRep v]
consFields [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRefRep,
      [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRecordRep :: [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRecordRep :: [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRecordRep
    }
  where
    ([ConsRep (Maybe (FieldContent TRUE kind CONST))]
enumRep, [ConsRep (Maybe (FieldContent TRUE kind CONST))]
left1) = (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool)
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> ([ConsRep (Maybe (FieldContent TRUE kind CONST))],
    [ConsRep (Maybe (FieldContent TRUE kind CONST))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool
forall a. ConsRep a -> Bool
isEmptyConstraint [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons
    ([ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRefRep, [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRecordRep) = (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool)
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> ([ConsRep (Maybe (FieldContent TRUE kind CONST))],
    [ConsRep (Maybe (FieldContent TRUE kind CONST))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TypeName -> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool
forall k. TypeName -> ConsRep k -> Bool
isUnionRef TypeName
baseName) [ConsRep (Maybe (FieldContent TRUE kind CONST))]
left1

mkUnionType ::
  KindedType kind a ->
  TypeData ->
  ResRep (Maybe (FieldContent TRUE kind CONST)) ->
  SchemaT (TypeContent TRUE kind CONST)
mkUnionType :: KindedType kind a
-> TypeData
-> ResRep (Maybe (FieldContent TRUE kind CONST))
-> SchemaT (TypeContent TRUE kind CONST)
mkUnionType KindedType kind a
InputType TypeData
_ ResRep {unionRef :: forall a. ResRep a -> [TypeName]
unionRef = [], unionRecordRep :: forall a. ResRep a -> [ConsRep a]
unionRecordRep = [], [TypeName]
enumCons :: [TypeName]
enumCons :: forall a. ResRep a -> [TypeName]
enumCons} = TypeContent TRUE kind CONST
-> SchemaT (TypeContent TRUE kind CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeContent TRUE kind CONST
 -> SchemaT (TypeContent TRUE kind CONST))
-> TypeContent TRUE kind CONST
-> SchemaT (TypeContent TRUE kind CONST)
forall a b. (a -> b) -> a -> b
$ [TypeName] -> TypeContent TRUE kind CONST
forall (a :: TypeCategory) (s :: Stage).
(ELEM LEAF a ~ TRUE) =>
[TypeName] -> TypeContent TRUE a s
mkEnumContent [TypeName]
enumCons
mkUnionType KindedType kind a
OutputType TypeData
_ ResRep {unionRef :: forall a. ResRep a -> [TypeName]
unionRef = [], unionRecordRep :: forall a. ResRep a -> [ConsRep a]
unionRecordRep = [], [TypeName]
enumCons :: [TypeName]
enumCons :: forall a. ResRep a -> [TypeName]
enumCons} = TypeContent TRUE kind CONST
-> SchemaT (TypeContent TRUE kind CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeContent TRUE kind CONST
 -> SchemaT (TypeContent TRUE kind CONST))
-> TypeContent TRUE kind CONST
-> SchemaT (TypeContent TRUE kind CONST)
forall a b. (a -> b) -> a -> b
$ [TypeName] -> TypeContent TRUE kind CONST
forall (a :: TypeCategory) (s :: Stage).
(ELEM LEAF a ~ TRUE) =>
[TypeName] -> TypeContent TRUE a s
mkEnumContent [TypeName]
enumCons
mkUnionType KindedType kind a
InputType TypeData
_ ResRep {[TypeName]
unionRef :: [TypeName]
unionRef :: forall a. ResRep a -> [TypeName]
unionRef, [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRecordRep :: [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRecordRep :: forall a. ResRep a -> [ConsRep a]
unionRecordRep, [TypeName]
enumCons :: [TypeName]
enumCons :: forall a. ResRep a -> [TypeName]
enumCons} = DataInputUnion CONST -> TypeContent TRUE kind CONST
forall (s :: Stage) (a :: TypeCategory).
DataInputUnion s -> TypeContent (ELEM IN a) a s
DataInputUnion (DataInputUnion CONST -> TypeContent TRUE kind CONST)
-> SchemaT (DataInputUnion CONST)
-> SchemaT (TypeContent TRUE kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaT (DataInputUnion CONST)
typeMembers
  where
    typeMembers :: SchemaT [UnionMember IN CONST]
    typeMembers :: SchemaT (DataInputUnion CONST)
typeMembers = [TypeName] -> DataInputUnion CONST
withMembers ([TypeName] -> DataInputUnion CONST)
-> SchemaT [TypeName] -> SchemaT (DataInputUnion CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT [TypeName]
forall (kind :: TypeCategory).
PackObject kind =>
[ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT [TypeName]
buildUnions [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRecordRep
      where
        withMembers :: [TypeName] -> DataInputUnion CONST
withMembers [TypeName]
unionMembers = (TypeName -> UnionMember IN CONST)
-> [TypeName] -> DataInputUnion CONST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeName -> UnionMember IN CONST
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkUnionMember ([TypeName]
unionRef [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
unionMembers) DataInputUnion CONST
-> DataInputUnion CONST -> DataInputUnion CONST
forall a. Semigroup a => a -> a -> a
<> (TypeName -> UnionMember IN CONST)
-> [TypeName] -> DataInputUnion CONST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TypeName -> Bool -> UnionMember IN CONST
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> Bool -> UnionMember cat s
`UnionMember` Bool
False) [TypeName]
enumCons
mkUnionType KindedType kind a
OutputType TypeData
typeData ResRep {[TypeName]
unionRef :: [TypeName]
unionRef :: forall a. ResRep a -> [TypeName]
unionRef, [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRecordRep :: [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRecordRep :: forall a. ResRep a -> [ConsRep a]
unionRecordRep, [TypeName]
enumCons :: [TypeName]
enumCons :: forall a. ResRep a -> [TypeName]
enumCons} = DataUnion CONST -> TypeContent TRUE kind CONST
forall (s :: Stage) (a :: TypeCategory).
DataUnion s -> TypeContent (ELEM OUT a) a s
DataUnion (DataUnion CONST -> TypeContent TRUE kind CONST)
-> ([TypeName] -> DataUnion CONST)
-> [TypeName]
-> TypeContent TRUE kind CONST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeName -> UnionMember OUT CONST)
-> [TypeName] -> DataUnion CONST
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> UnionMember OUT CONST
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkUnionMember ([TypeName] -> TypeContent TRUE kind CONST)
-> SchemaT [TypeName] -> SchemaT (TypeContent TRUE kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaT [TypeName]
typeMembers
  where
    typeMembers :: SchemaT [TypeName]
typeMembers = do
      [TypeName]
enums <- TypeData -> [TypeName] -> SchemaT [TypeName]
buildUnionEnum TypeData
typeData [TypeName]
enumCons
      [TypeName]
unions <- [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT [TypeName]
forall (kind :: TypeCategory).
PackObject kind =>
[ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT [TypeName]
buildUnions [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRecordRep
      [TypeName] -> SchemaT [TypeName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TypeName]
unionRef [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
enums [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
unions)

wrapFields :: [TypeName] -> KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
wrapFields :: [TypeName]
-> KindedType kind a
-> FieldsDefinition kind CONST
-> TypeContent TRUE kind CONST
wrapFields [TypeName]
_ KindedType kind a
InputType = FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition IN s -> TypeContent (ELEM IN a) a s
DataInputObject
wrapFields [TypeName]
interfaces KindedType kind a
OutputType = [TypeName]
-> FieldsDefinition OUT CONST
-> TypeContent (ELEM OBJECT kind) kind CONST
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject [TypeName]
interfaces

mkFieldsDefinition :: [FieldRep (Maybe (FieldContent TRUE kind CONST))] -> FieldsDefinition kind CONST
mkFieldsDefinition :: [FieldRep (Maybe (FieldContent TRUE kind CONST))]
-> FieldsDefinition kind CONST
mkFieldsDefinition = [FieldDefinition kind CONST] -> FieldsDefinition kind CONST
forall (cat :: TypeCategory) (s :: Stage).
[FieldDefinition cat s] -> FieldsDefinition cat s
unsafeFromFields ([FieldDefinition kind CONST] -> FieldsDefinition kind CONST)
-> ([FieldRep (Maybe (FieldContent TRUE kind CONST))]
    -> [FieldDefinition kind CONST])
-> [FieldRep (Maybe (FieldContent TRUE kind CONST))]
-> FieldsDefinition kind CONST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldRep (Maybe (FieldContent TRUE kind CONST))
 -> FieldDefinition kind CONST)
-> [FieldRep (Maybe (FieldContent TRUE kind CONST))]
-> [FieldDefinition kind CONST]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldRep (Maybe (FieldContent TRUE kind CONST))
-> FieldDefinition kind CONST
forall (kind :: TypeCategory).
FieldRep (Maybe (FieldContent TRUE kind CONST))
-> FieldDefinition kind CONST
fieldByRep

fieldByRep :: FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST
fieldByRep :: FieldRep (Maybe (FieldContent TRUE kind CONST))
-> FieldDefinition kind CONST
fieldByRep FieldRep {FieldName
fieldSelector :: FieldName
fieldSelector :: forall a. FieldRep a -> FieldName
fieldSelector, TypeRef
fieldTypeRef :: TypeRef
fieldTypeRef :: forall a. FieldRep a -> TypeRef
fieldTypeRef, Maybe (FieldContent TRUE kind CONST)
fieldValue :: Maybe (FieldContent TRUE kind CONST)
fieldValue :: forall a. FieldRep a -> a
fieldValue} =
  Maybe (FieldContent TRUE kind CONST)
-> FieldName -> TypeRef -> FieldDefinition kind CONST
forall (cat :: TypeCategory) (s :: Stage).
Maybe (FieldContent TRUE cat s)
-> FieldName -> TypeRef -> FieldDefinition cat s
mkField Maybe (FieldContent TRUE kind CONST)
fieldValue FieldName
fieldSelector TypeRef
fieldTypeRef

buildUnions ::
  PackObject kind =>
  [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->
  SchemaT [TypeName]
buildUnions :: [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT [TypeName]
buildUnions [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons =
  (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT ())
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT ()
buildURecType [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons SchemaT () -> [TypeName] -> SchemaT [TypeName]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName)
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName
forall v. ConsRep v -> TypeName
consName [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons
  where
    buildURecType :: ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT ()
buildURecType = TypeDefinition kind CONST -> SchemaT ()
forall (cat :: TypeCategory).
TypeDefinition cat CONST -> SchemaT ()
insertType (TypeDefinition kind CONST -> SchemaT ())
-> (ConsRep (Maybe (FieldContent TRUE kind CONST))
    -> TypeDefinition kind CONST)
-> ConsRep (Maybe (FieldContent TRUE kind CONST))
-> SchemaT ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsRep (Maybe (FieldContent TRUE kind CONST))
-> TypeDefinition kind CONST
forall (kind :: TypeCategory).
PackObject kind =>
ConsRep (Maybe (FieldContent TRUE kind CONST))
-> TypeDefinition kind CONST
buildUnionRecord

buildUnionRecord ::
  PackObject kind =>
  ConsRep (Maybe (FieldContent TRUE kind CONST)) ->
  TypeDefinition kind CONST
buildUnionRecord :: ConsRep (Maybe (FieldContent TRUE kind CONST))
-> TypeDefinition kind CONST
buildUnionRecord ConsRep {TypeName
consName :: TypeName
consName :: forall v. ConsRep v -> TypeName
consName, [FieldRep (Maybe (FieldContent TRUE kind CONST))]
consFields :: [FieldRep (Maybe (FieldContent TRUE kind CONST))]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields} =
  TypeName
-> TypeContent TRUE kind CONST -> TypeDefinition kind CONST
forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
consName (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
forall (kind :: TypeCategory).
PackObject kind =>
FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
packObject (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST)
-> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
forall a b. (a -> b) -> a -> b
$ [FieldRep (Maybe (FieldContent TRUE kind CONST))]
-> FieldsDefinition kind CONST
forall (kind :: TypeCategory).
[FieldRep (Maybe (FieldContent TRUE kind CONST))]
-> FieldsDefinition kind CONST
mkFieldsDefinition [FieldRep (Maybe (FieldContent TRUE kind CONST))]
consFields)

class PackObject kind where
  packObject :: FieldsDefinition kind CONST -> TypeContent TRUE kind CONST

instance PackObject OUT where
  packObject :: FieldsDefinition OUT CONST -> TypeContent TRUE OUT CONST
packObject = [TypeName]
-> FieldsDefinition OUT CONST
-> TypeContent (ELEM OBJECT OUT) OUT CONST
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject []

instance PackObject IN where
  packObject :: FieldsDefinition IN CONST -> TypeContent TRUE IN CONST
packObject = FieldsDefinition IN CONST -> TypeContent TRUE IN CONST
forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition IN s -> TypeContent (ELEM IN a) a s
DataInputObject

buildUnionEnum ::
  TypeData ->
  [TypeName] ->
  SchemaT [TypeName]
buildUnionEnum :: TypeData -> [TypeName] -> SchemaT [TypeName]
buildUnionEnum TypeData {TypeName
gqlTypeName :: TypeName
gqlTypeName :: TypeData -> TypeName
gqlTypeName} [TypeName]
enums = SchemaT ()
updates SchemaT () -> [TypeName] -> SchemaT [TypeName]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [TypeName]
members
  where
    members :: [TypeName]
members
      | [TypeName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeName]
enums = []
      | Bool
otherwise = [TypeName
enumTypeWrapperName]
    enumTypeName :: TypeName
enumTypeName = TypeName
gqlTypeName TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
"Enum"
    enumTypeWrapperName :: TypeName
enumTypeWrapperName = TypeName
enumTypeName TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
"Object"
    -------------------------
    updates :: SchemaT ()
    updates :: SchemaT ()
updates
      | [TypeName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeName]
enums = () -> SchemaT ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise =
        TypeName -> TypeName -> SchemaT ()
buildEnumObject TypeName
enumTypeWrapperName TypeName
enumTypeName
          SchemaT () -> SchemaT () -> SchemaT ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TypeName -> [TypeName] -> SchemaT ()
buildEnum TypeName
enumTypeName [TypeName]
enums

buildEnum :: TypeName -> [TypeName] -> SchemaT ()
buildEnum :: TypeName -> [TypeName] -> SchemaT ()
buildEnum TypeName
typeName [TypeName]
tags =
  TypeDefinition LEAF CONST -> SchemaT ()
forall (cat :: TypeCategory).
TypeDefinition cat CONST -> SchemaT ()
insertType
    ( TypeName
-> TypeContent TRUE LEAF CONST -> TypeDefinition LEAF CONST
forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
typeName ([TypeName] -> TypeContent TRUE LEAF CONST
forall (a :: TypeCategory) (s :: Stage).
(ELEM LEAF a ~ TRUE) =>
[TypeName] -> TypeContent TRUE a s
mkEnumContent [TypeName]
tags) ::
        TypeDefinition LEAF CONST
    )

buildEnumObject :: TypeName -> TypeName -> SchemaT ()
buildEnumObject :: TypeName -> TypeName -> SchemaT ()
buildEnumObject TypeName
typeName TypeName
enumTypeName =
  TypeDefinition OBJECT CONST -> SchemaT ()
forall (cat :: TypeCategory).
TypeDefinition cat CONST -> SchemaT ()
insertType
    ( TypeName
-> TypeContent TRUE OBJECT CONST -> TypeDefinition OBJECT CONST
forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType
        TypeName
typeName
        ( [TypeName]
-> FieldsDefinition OUT CONST
-> TypeContent (ELEM OBJECT OBJECT) OBJECT CONST
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject []
            (FieldsDefinition OUT CONST
 -> TypeContent (ELEM OBJECT OBJECT) OBJECT CONST)
-> FieldsDefinition OUT CONST
-> TypeContent (ELEM OBJECT OBJECT) OBJECT CONST
forall a b. (a -> b) -> a -> b
$ FieldDefinition OUT CONST -> FieldsDefinition OUT CONST
forall a coll. Collection a coll => a -> coll
singleton
            (FieldDefinition OUT CONST -> FieldsDefinition OUT CONST)
-> FieldDefinition OUT CONST -> FieldsDefinition OUT CONST
forall a b. (a -> b) -> a -> b
$ FieldName -> [TypeWrapper] -> TypeName -> FieldDefinition OUT CONST
forall (cat :: TypeCategory) (s :: Stage).
FieldName -> [TypeWrapper] -> TypeName -> FieldDefinition cat s
mkInputValue FieldName
"enum" [] TypeName
enumTypeName
        ) ::
        TypeDefinition OBJECT CONST
    )