{-# 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
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