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

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

-- MORPHEUS
import Data.List (partition)
import qualified Data.Map as M
import Data.Morpheus.App.Internal.Resolving
  ( Eventless,
    Result (..),
  )
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 (..),
    __typeData,
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    insertType,
    updateSchema,
    withInterface,
  )
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,
    mkNullaryMember,
    mkType,
    mkTypeRef,
    mkUnionMember,
    msg,
    unitFieldName,
    unitTypeName,
    unsafeFromFields,
  )
import Data.Morpheus.Utils.Kinded
  ( CategoryValue (..),
    KindedType (..),
    outputType,
  )
import Language.Haskell.TH (Exp, Q)
import Relude

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 b a. (Show a, IsString b) => a -> b
show GQLErrors
errors)

withObject :: (GQLType a, CategoryValue c) => KindedType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)
withObject :: KindedType c a
-> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)
withObject KindedType c a
InputType DataInputObject {FieldsDefinition IN s
inputObjectFields :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
inputObjectFields} = FieldsDefinition IN s -> SchemaT c (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).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields} = FieldsDefinition OUT s -> SchemaT c (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 c (FieldsDefinition c s)
forall (c :: TypeCategory) a b.
(GQLType a, CategoryValue c) =>
KindedType c a -> SchemaT c b
failureOnlyObject KindedType c a
x

asObjectType ::
  (GQLType a) =>
  (f2 a -> SchemaT c (FieldsDefinition OUT CONST)) ->
  f2 a ->
  SchemaT c (TypeDefinition OBJECT CONST)
asObjectType :: (f2 a -> SchemaT c (FieldsDefinition OUT CONST))
-> f2 a -> SchemaT c (TypeDefinition OBJECT CONST)
asObjectType f2 a -> SchemaT c (FieldsDefinition OUT CONST)
f f2 a
proxy = (FieldsDefinition OUT CONST
-> TypeName -> TypeDefinition OBJECT CONST
`mkObjectType` TypeData -> TypeName
gqlTypeName (KindedType OUT a -> TypeData
forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData (f2 a -> KindedType OUT a
forall k (f :: k -> *) (a :: k). f a -> KindedType OUT a
outputType f2 a
proxy))) (FieldsDefinition OUT CONST -> TypeDefinition OBJECT CONST)
-> SchemaT c (FieldsDefinition OUT CONST)
-> SchemaT c (TypeDefinition OBJECT CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f2 a -> SchemaT c (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 (OBJECT <=? OBJECT) OBJECT CONST
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s
DataObject [] FieldsDefinition OUT CONST
fields)

failureOnlyObject :: forall (c :: TypeCategory) a b. (GQLType a, CategoryValue c) => KindedType c a -> SchemaT c b
failureOnlyObject :: KindedType c a -> SchemaT c b
failureOnlyObject KindedType c a
proxy =
  GQLErrors -> SchemaT c b
forall error (f :: * -> *) v. Failure error f => error -> f v
failure
    (GQLErrors -> SchemaT c b) -> GQLErrors -> SchemaT c 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 (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData 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 kind (Maybe (FieldContent TRUE kind CONST)))

type TyContent kind = Maybe (FieldContent TRUE kind CONST)

unpackM :: FieldRep (TyContentM k) -> SchemaT k (FieldRep (TyContent k))
unpackM :: FieldRep (TyContentM k) -> SchemaT k (FieldRep (TyContent k))
unpackM FieldRep {Bool
TypeRef
FieldName
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 k (FieldRep (TyContent k))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyContentM k
fieldValue

unpackCons :: ConsRep (TyContentM k) -> SchemaT k (ConsRep (TyContent k))
unpackCons :: ConsRep (TyContentM k) -> SchemaT k (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 k [FieldRep (TyContent k)]
-> SchemaT k (ConsRep (TyContent k))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldRep (TyContentM k) -> SchemaT k (FieldRep (TyContent k)))
-> [FieldRep (TyContentM k)] -> SchemaT k [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 k (FieldRep (TyContent k))
forall (k :: TypeCategory).
FieldRep (TyContentM k) -> SchemaT k (FieldRep (TyContent k))
unpackM [FieldRep (TyContentM k)]
consFields

unpackMs :: [ConsRep (TyContentM k)] -> SchemaT k [ConsRep (TyContent k)]
unpackMs :: [ConsRep (TyContentM k)] -> SchemaT k [ConsRep (TyContent k)]
unpackMs = (ConsRep (TyContentM k) -> SchemaT k (ConsRep (TyContent k)))
-> [ConsRep (TyContentM k)] -> SchemaT k [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 k (ConsRep (TyContent k))
forall (k :: TypeCategory).
ConsRep (TyContentM k) -> SchemaT k (ConsRep (TyContent k))
unpackCons

builder ::
  (GQLType a, CategoryValue kind) =>
  KindedType kind a ->
  [ConsRep (TyContent kind)] ->
  SchemaT cat (TypeContent TRUE kind CONST)
builder :: KindedType kind a
-> [ConsRep (TyContent kind)]
-> SchemaT cat (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 cat [TypeName]
-> SchemaT cat (TypeContent TRUE kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaT OUT [TypeName] -> SchemaT cat [TypeName]
forall a (ct :: TypeCategory). SchemaT OUT a -> SchemaT ct a
withInterface ([SchemaT OUT TypeName] -> SchemaT OUT [TypeName]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (KindedType kind a -> [SchemaT OUT TypeName]
forall a (f :: * -> *). GQLType a => f a -> [SchemaT OUT 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 (kind :: TypeCategory) a.
[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 cat (TypeContent TRUE kind CONST)
genericUnion [ConsRep (TyContent kind)]
cons
  where
    typeData :: TypeData
typeData = KindedType kind a -> TypeData
forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData KindedType kind a
scope
    genericUnion :: [ConsRep (TyContent kind)]
-> SchemaT cat (TypeContent TRUE kind CONST)
genericUnion = KindedType kind a
-> ResRep (TyContent kind)
-> SchemaT cat (TypeContent TRUE kind CONST)
forall (kind :: TypeCategory) (c :: TypeCategory) a.
KindedType kind a
-> ResRep (Maybe (FieldContent TRUE kind CONST))
-> SchemaT c (TypeContent TRUE kind CONST)
mkUnionType KindedType kind a
scope (ResRep (TyContent kind)
 -> SchemaT cat (TypeContent TRUE kind CONST))
-> ([ConsRep (TyContent kind)] -> ResRep (TyContent kind))
-> [ConsRep (TyContent kind)]
-> SchemaT cat (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).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields = FieldsDefinition OUT CONST
fields, [TypeName]
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent OBJECT a s -> [TypeName]
objectImplements :: [TypeName]
..} =
    DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (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).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s
inputObjectFields = FieldsDefinition IN CONST
fields} =
    DataInputObject :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition IN s -> TypeContent (INPUT_OBJECT <=? 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).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields = FieldsDefinition OUT CONST
fields} =
    DataInterface :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> TypeContent (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 (LEAF <=? c) c CONST
forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (LEAF <=? a) a s
DataEnum (DataEnum CONST -> TypeContent (LEAF <=? c) c CONST)
-> DataEnum CONST -> TypeContent (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 (IN <=? IN) IN CONST
forall (s :: Stage) (cat :: TypeCategory).
Value s -> FieldContent (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 (OUT <=? OUT) OUT CONST
forall (s :: Stage) (cat :: TypeCategory).
ArgumentsDefinition s -> FieldContent (OUT <=? cat) cat s
FieldArgs ArgumentsDefinition CONST
x)
      Maybe (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
_ -> Maybe (FieldContent TRUE OUT CONST)
args

updateByContent ::
  (GQLType a, CategoryValue kind) =>
  (f kind a -> SchemaT c (TypeContent TRUE kind CONST)) ->
  f kind a ->
  SchemaT c ()
updateByContent :: (f kind a -> SchemaT c (TypeContent TRUE kind CONST))
-> f kind a -> SchemaT c ()
updateByContent f kind a -> SchemaT c (TypeContent TRUE kind CONST)
f f kind a
proxy =
  TypeFingerprint
-> (f kind a -> SchemaT c (TypeDefinition kind CONST))
-> f kind a
-> SchemaT c ()
forall a (cat' :: TypeCategory) (cat :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (TypeDefinition cat CONST))
-> a
-> SchemaT cat' ()
updateSchema
    (TypeData -> TypeFingerprint
gqlFingerprint (TypeData -> TypeFingerprint) -> TypeData -> TypeFingerprint
forall a b. (a -> b) -> a -> b
$ f kind a -> TypeData
forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData f kind a
proxy)
    f kind a -> SchemaT c (TypeDefinition kind CONST)
deriveD
    f kind a
proxy
  where
    deriveD :: f kind a -> SchemaT c (TypeDefinition kind CONST)
deriveD =
      (TypeContent TRUE kind CONST -> TypeDefinition kind CONST)
-> SchemaT c (TypeContent TRUE kind CONST)
-> SchemaT c (TypeDefinition kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( Maybe Description
-> TypeName
-> [Directive CONST]
-> TypeContent TRUE kind CONST
-> TypeDefinition kind 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 (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData f kind a
proxy))
            []
        )
        (SchemaT c (TypeContent TRUE kind CONST)
 -> SchemaT c (TypeDefinition kind CONST))
-> (f kind a -> SchemaT c (TypeContent TRUE kind CONST))
-> f kind a
-> SchemaT c (TypeDefinition kind CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f kind a -> SchemaT c (TypeContent TRUE kind 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
  | (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool)
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool
forall a. ConsRep a -> Bool
isEmptyConstraint [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons = EnumRep :: forall a. [TypeName] -> ResRep a
EnumRep {enumCons :: [TypeName]
enumCons = ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName
forall v. ConsRep v -> TypeName
consName (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
<$> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons}
  | Bool
otherwise =
    ResRep :: forall a. [TypeName] -> [ConsRep a] -> ResRep a
ResRep
      { 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))]
unionCons :: [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons :: [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons
      }
  where
    ([ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRefRep, [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons) = (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))]
cons

mkUnionType ::
  forall kind c a.
  KindedType kind a ->
  ResRep (Maybe (FieldContent TRUE kind CONST)) ->
  SchemaT c (TypeContent TRUE kind CONST)
mkUnionType :: KindedType kind a
-> ResRep (Maybe (FieldContent TRUE kind CONST))
-> SchemaT c (TypeContent TRUE kind CONST)
mkUnionType KindedType kind a
InputType EnumRep {[TypeName]
enumCons :: [TypeName]
enumCons :: forall a. ResRep a -> [TypeName]
enumCons} = TypeContent TRUE kind CONST
-> SchemaT c (TypeContent TRUE kind CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeContent TRUE kind CONST
 -> SchemaT c (TypeContent TRUE kind CONST))
-> TypeContent TRUE kind CONST
-> SchemaT c (TypeContent TRUE kind CONST)
forall a b. (a -> b) -> a -> b
$ [TypeName] -> TypeContent TRUE kind CONST
forall (a :: TypeCategory) (s :: Stage).
(LEAF <=! a) =>
[TypeName] -> TypeContent TRUE a s
mkEnumContent [TypeName]
enumCons
mkUnionType KindedType kind a
OutputType EnumRep {[TypeName]
enumCons :: [TypeName]
enumCons :: forall a. ResRep a -> [TypeName]
enumCons} = TypeContent TRUE kind CONST
-> SchemaT c (TypeContent TRUE kind CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeContent TRUE kind CONST
 -> SchemaT c (TypeContent TRUE kind CONST))
-> TypeContent TRUE kind CONST
-> SchemaT c (TypeContent TRUE kind CONST)
forall a b. (a -> b) -> a -> b
$ [TypeName] -> TypeContent TRUE kind CONST
forall (a :: TypeCategory) (s :: Stage).
(LEAF <=! a) =>
[TypeName] -> TypeContent TRUE a s
mkEnumContent [TypeName]
enumCons
mkUnionType KindedType kind a
InputType ResRep {[TypeName]
unionRef :: [TypeName]
unionRef :: forall a. ResRep a -> [TypeName]
unionRef, [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons :: [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons :: forall a. ResRep a -> [ConsRep a]
unionCons} = DataInputUnion CONST -> TypeContent TRUE kind CONST
forall (s :: Stage) (a :: TypeCategory).
DataInputUnion s -> TypeContent (IN <=? a) a s
DataInputUnion (DataInputUnion CONST -> TypeContent TRUE kind CONST)
-> SchemaT c (DataInputUnion CONST)
-> SchemaT c (TypeContent TRUE kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaT c (DataInputUnion CONST)
typeMembers
  where
    ([ConsRep (Maybe (FieldContent TRUE kind CONST))]
nullaries, [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons) = (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))]
unionCons
    nullaryMembers :: [UnionMember IN CONST]
    nullaryMembers :: DataInputUnion CONST
nullaryMembers = TypeName -> UnionMember IN CONST
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkNullaryMember (TypeName -> UnionMember IN CONST)
-> (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName)
-> ConsRep (Maybe (FieldContent TRUE kind CONST))
-> UnionMember IN CONST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName
forall v. ConsRep v -> TypeName
consName (ConsRep (Maybe (FieldContent TRUE kind CONST))
 -> UnionMember IN CONST)
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> DataInputUnion CONST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
nullaries
    defineEnumEmpty :: SchemaT c ()
defineEnumEmpty
      | [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConsRep (Maybe (FieldContent TRUE kind CONST))]
nullaries = () -> SchemaT c ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = SchemaT c ()
forall (cat :: TypeCategory). SchemaT cat ()
defineEnumNull
    typeMembers :: SchemaT c [UnionMember IN CONST]
    typeMembers :: SchemaT c (DataInputUnion CONST)
typeMembers =
      (DataInputUnion CONST
-> DataInputUnion CONST -> DataInputUnion CONST
forall a. Semigroup a => a -> a -> a
<> DataInputUnion CONST
nullaryMembers) (DataInputUnion CONST -> DataInputUnion CONST)
-> ([TypeName] -> DataInputUnion CONST)
-> [TypeName]
-> DataInputUnion CONST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeName] -> DataInputUnion CONST
withRefs
        ([TypeName] -> DataInputUnion CONST)
-> SchemaT c [TypeName] -> SchemaT c (DataInputUnion CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( SchemaT c ()
defineEnumEmpty SchemaT c () -> SchemaT c [TypeName] -> SchemaT c [TypeName]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c [TypeName]
forall (kind :: TypeCategory) (c :: TypeCategory).
PackObject kind =>
[ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c [TypeName]
buildUnions [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons
            )
      where
        withRefs :: [TypeName] -> DataInputUnion CONST
withRefs = (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] -> DataInputUnion CONST)
-> ([TypeName] -> [TypeName]) -> [TypeName] -> DataInputUnion CONST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TypeName]
unionRef [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<>)
mkUnionType KindedType kind a
OutputType ResRep {[TypeName]
unionRef :: [TypeName]
unionRef :: forall a. ResRep a -> [TypeName]
unionRef, [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons :: [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons :: forall a. ResRep a -> [ConsRep a]
unionCons} =
  DataUnion CONST -> TypeContent TRUE kind CONST
forall (s :: Stage) (a :: TypeCategory).
DataUnion s -> TypeContent (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] -> DataUnion CONST)
-> ([TypeName] -> [TypeName]) -> [TypeName] -> DataUnion CONST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TypeName]
unionRef [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<>) ([TypeName] -> TypeContent TRUE kind CONST)
-> SchemaT c [TypeName] -> SchemaT c (TypeContent TRUE kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c [TypeName]
forall (kind :: TypeCategory) (c :: TypeCategory).
PackObject kind =>
[ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c [TypeName]
buildUnions [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons

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 (INPUT_OBJECT <=? a) a s
DataInputObject
wrapFields [TypeName]
interfaces KindedType kind a
OutputType = [TypeName]
-> FieldsDefinition OUT CONST
-> TypeContent (OBJECT <=? kind) kind CONST
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (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 c [TypeName]
buildUnions :: [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c [TypeName]
buildUnions [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons =
  (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT c ())
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT c ()
forall (cat :: TypeCategory).
ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT cat ()
buildURecType [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons SchemaT c () -> [TypeName] -> SchemaT c [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 cat ()
buildURecType = ConsRep (Maybe (FieldContent TRUE kind CONST))
-> SchemaT cat (TypeDefinition kind CONST)
forall (kind :: TypeCategory) (cat :: TypeCategory).
PackObject kind =>
ConsRep (Maybe (FieldContent TRUE kind CONST))
-> SchemaT cat (TypeDefinition kind CONST)
buildUnionRecord (ConsRep (Maybe (FieldContent TRUE kind CONST))
 -> SchemaT cat (TypeDefinition kind CONST))
-> (TypeDefinition kind CONST -> SchemaT cat ())
-> ConsRep (Maybe (FieldContent TRUE kind CONST))
-> SchemaT cat ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TypeDefinition kind CONST -> SchemaT cat ()
forall (cat :: TypeCategory) (cat' :: TypeCategory).
TypeDefinition cat CONST -> SchemaT cat' ()
insertType

buildUnionRecord ::
  PackObject kind =>
  ConsRep (Maybe (FieldContent TRUE kind CONST)) ->
  SchemaT cat (TypeDefinition kind CONST)
buildUnionRecord :: ConsRep (Maybe (FieldContent TRUE kind CONST))
-> SchemaT cat (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 (TypeContent TRUE kind CONST -> TypeDefinition kind CONST)
-> (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST)
-> FieldsDefinition kind CONST
-> TypeDefinition kind CONST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
forall (kind :: TypeCategory).
PackObject kind =>
FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
packObject (FieldsDefinition kind CONST -> TypeDefinition kind CONST)
-> SchemaT cat (FieldsDefinition kind CONST)
-> SchemaT cat (TypeDefinition kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaT cat (FieldsDefinition kind CONST)
fields
  where
    fields :: SchemaT cat (FieldsDefinition kind CONST)
fields
      | [FieldRep (Maybe (FieldContent TRUE kind CONST))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldRep (Maybe (FieldContent TRUE kind CONST))]
consFields = SchemaT cat ()
forall (cat :: TypeCategory). SchemaT cat ()
defineEnumNull SchemaT cat ()
-> FieldsDefinition kind CONST
-> SchemaT cat (FieldsDefinition kind CONST)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> FieldDefinition kind CONST -> FieldsDefinition kind CONST
forall a coll. Collection a coll => a -> coll
singleton FieldDefinition kind CONST
forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s
mkNullField
      | Bool
otherwise = FieldsDefinition kind CONST
-> SchemaT cat (FieldsDefinition kind CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldsDefinition kind CONST
 -> SchemaT cat (FieldsDefinition kind CONST))
-> FieldsDefinition kind CONST
-> SchemaT cat (FieldsDefinition 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

defineEnumNull :: SchemaT cat ()
defineEnumNull :: SchemaT cat ()
defineEnumNull =
  TypeDefinition LEAF CONST -> SchemaT cat ()
forall (cat :: TypeCategory) (cat' :: TypeCategory).
TypeDefinition cat CONST -> SchemaT cat' ()
insertType
    ( TypeName
-> TypeContent TRUE LEAF CONST -> TypeDefinition LEAF CONST
forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
unitTypeName ([TypeName] -> TypeContent TRUE LEAF CONST
forall (a :: TypeCategory) (s :: Stage).
(LEAF <=! a) =>
[TypeName] -> TypeContent TRUE a s
mkEnumContent [TypeName
unitTypeName]) ::
        TypeDefinition LEAF CONST
    )

mkNullField :: FieldDefinition cat s
mkNullField :: FieldDefinition cat s
mkNullField = Maybe (FieldContent TRUE cat s)
-> FieldName -> TypeRef -> FieldDefinition cat s
forall (cat :: TypeCategory) (s :: Stage).
Maybe (FieldContent TRUE cat s)
-> FieldName -> TypeRef -> FieldDefinition cat s
mkField Maybe (FieldContent TRUE cat s)
forall a. Maybe a
Nothing FieldName
unitFieldName (TypeName -> TypeRef
mkTypeRef TypeName
unitTypeName)

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 (OBJECT <=? OUT) OUT CONST
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (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 (INPUT_OBJECT <=? a) a s
DataInputObject