{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.TH.Declare.GQLType
( deriveGQLType,
)
where
import Control.Applicative (Applicative (..))
import Control.Monad (Monad ((>>=)))
import Data.Functor ((<$>), fmap)
import Data.Map (Map, empty, fromList)
import Data.Maybe (Maybe (..), maybe)
import Data.Morpheus.Internal.TH
( apply,
applyVars,
funDProxy,
toName,
tyConArgs,
typeInstanceDec,
)
import Data.Morpheus.Internal.Utils
( elems,
stripConstructorNamespace,
stripFieldNamespace,
)
import Data.Morpheus.Server.Internal.TH.Types
( ServerDecContext (..),
ServerTypeDefinition (..),
)
import Data.Morpheus.Server.Internal.TH.Utils
( kindName,
mkTypeableConstraints,
)
import Data.Morpheus.Server.Types.GQLType
( GQLType (..),
GQLTypeOptions (..),
defaultTypeOptions,
)
import Data.Morpheus.Types (Resolver, interface)
import Data.Morpheus.Types.Internal.AST
( ANY,
ArgumentsDefinition,
DataEnumValue (..),
Description,
Directives,
FieldContent (..),
FieldDefinition (..),
FieldName (..),
FieldsDefinition,
IN,
OUT,
QUERY,
TRUE,
Token,
TypeContent (..),
TypeDefinition (..),
TypeKind (..),
TypeName (..),
Value,
)
import Data.Proxy (Proxy (..))
import Language.Haskell.TH
import Prelude
( ($),
(&&),
(.),
Eq (..),
concatMap,
null,
otherwise,
)
interfaceF :: Name -> ExpQ
interfaceF :: Name -> ExpQ
interfaceF Name
name = [|interface (Proxy :: (Proxy ($(conT name) (Resolver QUERY () Maybe))))|]
introspectInterface :: TypeName -> ExpQ
introspectInterface :: TypeName -> ExpQ
introspectInterface = Name -> ExpQ
interfaceF (Name -> ExpQ) -> (TypeName -> Name) -> TypeName -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Name
forall a. ToName a => a -> Name
toName
deriveGQLType :: ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]
deriveGQLType :: ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]
deriveGQLType
ServerDecContext {Bool
namespace :: ServerDecContext -> Bool
namespace :: Bool
namespace}
ServerTypeDefinition {TypeName
tName :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> TypeName
tName :: TypeName
tName, TypeKind
tKind :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> TypeKind
tKind :: TypeKind
tKind, Maybe (TypeDefinition ANY s)
typeOriginal :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> Maybe (TypeDefinition ANY s)
typeOriginal :: Maybe (TypeDefinition ANY s)
typeOriginal} =
Dec -> [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD CxtQ
constrains TypeQ
iHead (Q Dec
typeFamilies Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: [Q Dec]
functions)
where
functions :: [Q Dec]
functions =
[(Name, ExpQ)] -> [Q Dec]
funDProxy
[ ('description, [|tDescription|]),
('implements, ExpQ
implementsFunc),
('typeOptions, ExpQ
typeOptionsFunc),
('getDescriptions, ExpQ
fieldDescriptionsFunc),
('getDirectives, ExpQ
fieldDirectivesFunc),
('getFieldContents, ExpQ
getFieldContentsFunc)
]
where
tDescription :: Maybe Description
tDescription = Maybe (TypeDefinition ANY s)
typeOriginal Maybe (TypeDefinition ANY s)
-> (TypeDefinition ANY s -> Maybe Description) -> Maybe Description
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeDefinition ANY s -> Maybe Description
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
typeDescription
implementsFunc :: ExpQ
implementsFunc = [ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (TypeName -> ExpQ) -> [TypeName] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeName -> ExpQ
introspectInterface (Maybe (TypeDefinition ANY s) -> [TypeName]
forall (s :: Stage). Maybe (TypeDefinition ANY s) -> [TypeName]
interfacesFrom Maybe (TypeDefinition ANY s)
typeOriginal)
typeOptionsFunc :: ExpQ
typeOptionsFunc
| Bool
namespace Bool -> Bool -> Bool
&& TypeKind
tKind TypeKind -> TypeKind -> Bool
forall a. Eq a => a -> a -> Bool
== TypeKind
KindEnum = [|GQLTypeOptions id (stripConstructorNamespace tName)|]
| Bool
namespace = [|GQLTypeOptions (stripFieldNamespace tName) id|]
| Bool
otherwise = [|defaultTypeOptions|]
fieldDescriptionsFunc :: ExpQ
fieldDescriptionsFunc = [|value|]
where
value :: Map Description Description
value = Maybe (TypeDefinition ANY s) -> Map Description Description
forall (c :: TypeCategory) (s :: Stage).
Maybe (TypeDefinition c s) -> Map Description Description
getDesc Maybe (TypeDefinition ANY s)
typeOriginal
fieldDirectivesFunc :: ExpQ
fieldDirectivesFunc = [|value|]
where
value :: Map Description (Directives s)
value = Maybe (TypeDefinition ANY s) -> Map Description (Directives s)
forall (c :: TypeCategory) (s :: Stage).
Maybe (TypeDefinition c s) -> Map Description (Directives s)
getDirs Maybe (TypeDefinition ANY s)
typeOriginal
getFieldContentsFunc :: ExpQ
getFieldContentsFunc = [|value|]
where
value :: Map FieldName (Maybe (Value s), Maybe (ArgumentsDefinition s))
value =
(FieldDefinition IN s
-> Maybe (Maybe (Value s), Maybe (ArgumentsDefinition s)))
-> (FieldDefinition OUT s
-> Maybe (Maybe (Value s), Maybe (ArgumentsDefinition s)))
-> Maybe (TypeDefinition ANY s)
-> Map FieldName (Maybe (Value s), Maybe (ArgumentsDefinition s))
forall (s :: Stage) a (c :: TypeCategory).
(FieldDefinition IN s -> Maybe a)
-> (FieldDefinition OUT s -> Maybe a)
-> Maybe (TypeDefinition c s)
-> Map FieldName a
fmapFieldValues
((FieldContent TRUE IN s
-> (Maybe (Value s), Maybe (ArgumentsDefinition s)))
-> Maybe (FieldContent TRUE IN s)
-> Maybe (Maybe (Value s), Maybe (ArgumentsDefinition s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldContent TRUE IN s
-> (Maybe (Value s), Maybe (ArgumentsDefinition s))
forall (c :: TypeCategory) (s :: Stage).
FieldContent TRUE c s
-> (Maybe (Value s), Maybe (ArgumentsDefinition s))
getDefaultValue (Maybe (FieldContent TRUE IN s)
-> Maybe (Maybe (Value s), Maybe (ArgumentsDefinition s)))
-> (FieldDefinition IN s -> Maybe (FieldContent TRUE IN s))
-> FieldDefinition IN s
-> Maybe (Maybe (Value s), Maybe (ArgumentsDefinition s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDefinition IN s -> Maybe (FieldContent TRUE IN s)
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent)
((FieldContent TRUE OUT s
-> (Maybe (Value s), Maybe (ArgumentsDefinition s)))
-> Maybe (FieldContent TRUE OUT s)
-> Maybe (Maybe (Value s), Maybe (ArgumentsDefinition s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldContent TRUE OUT s
-> (Maybe (Value s), Maybe (ArgumentsDefinition s))
forall (c :: TypeCategory) (s :: Stage).
FieldContent TRUE c s
-> (Maybe (Value s), Maybe (ArgumentsDefinition s))
getDefaultValue (Maybe (FieldContent TRUE OUT s)
-> Maybe (Maybe (Value s), Maybe (ArgumentsDefinition s)))
-> (FieldDefinition OUT s -> Maybe (FieldContent TRUE OUT s))
-> FieldDefinition OUT s
-> Maybe (Maybe (Value s), Maybe (ArgumentsDefinition s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDefinition OUT s -> Maybe (FieldContent TRUE OUT s)
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent)
Maybe (TypeDefinition ANY s)
typeOriginal
typeArgs :: [String]
typeArgs = TypeKind -> [String]
tyConArgs TypeKind
tKind
iHead :: TypeQ
iHead = Name -> [TypeQ] -> TypeQ
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply ''GQLType [TypeName -> [String] -> TypeQ
forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
ToVar var res) =>
con -> [var] -> res
applyVars TypeName
tName [String]
typeArgs]
headSig :: TypeQ
headSig = TypeName -> [String] -> TypeQ
forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
ToVar var res) =>
con -> [var] -> res
applyVars TypeName
tName [String]
typeArgs
constrains :: CxtQ
constrains = [String] -> CxtQ
mkTypeableConstraints [String]
typeArgs
typeFamilies :: Q Dec
typeFamilies = Name -> Name -> Q Dec
deriveInstance ''KIND (TypeKind -> Name
kindName TypeKind
tKind)
where
deriveInstance :: Name -> Name -> Q Dec
deriveInstance :: Name -> Name -> Q Dec
deriveInstance Name
insName Name
tyName = do
Type
typeN <- TypeQ
headSig
Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Type -> Dec
typeInstanceDec Name
insName Type
typeN (Name -> Type
ConT Name
tyName)
interfacesFrom :: Maybe (TypeDefinition ANY s) -> [TypeName]
interfacesFrom :: Maybe (TypeDefinition ANY s) -> [TypeName]
interfacesFrom (Just TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {[TypeName]
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
objectImplements :: [TypeName]
objectImplements}}) = [TypeName]
objectImplements
interfacesFrom Maybe (TypeDefinition ANY s)
_ = []
fmapFieldValues :: (FieldDefinition IN s -> Maybe a) -> (FieldDefinition OUT s -> Maybe a) -> Maybe (TypeDefinition c s) -> Map FieldName a
fmapFieldValues :: (FieldDefinition IN s -> Maybe a)
-> (FieldDefinition OUT s -> Maybe a)
-> Maybe (TypeDefinition c s)
-> Map FieldName a
fmapFieldValues FieldDefinition IN s -> Maybe a
f FieldDefinition OUT s -> Maybe a
g = Map FieldName a
-> (TypeDefinition c s -> Map FieldName a)
-> Maybe (TypeDefinition c s)
-> Map FieldName a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map FieldName a
forall k a. Map k a
empty ((FieldDefinition IN s -> Maybe a)
-> (FieldDefinition OUT s -> Maybe a)
-> TypeDefinition c s
-> Map FieldName a
forall (s :: Stage) a (c :: TypeCategory).
(FieldDefinition IN s -> Maybe a)
-> (FieldDefinition OUT s -> Maybe a)
-> TypeDefinition c s
-> Map FieldName a
collectFieldValues FieldDefinition IN s -> Maybe a
f FieldDefinition OUT s -> Maybe a
g)
getDesc :: Maybe (TypeDefinition c s) -> Map Token Description
getDesc :: Maybe (TypeDefinition c s) -> Map Description Description
getDesc = [(Description, Description)] -> Map Description Description
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(Description, Description)] -> Map Description Description)
-> (Maybe (TypeDefinition c s) -> [(Description, Description)])
-> Maybe (TypeDefinition c s)
-> Map Description Description
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (TypeDefinition c s) -> [(Description, Description)]
forall a v. Meta a v => a -> [(Description, v)]
get
getDirs :: Maybe (TypeDefinition c s) -> Map Token (Directives s)
getDirs :: Maybe (TypeDefinition c s) -> Map Description (Directives s)
getDirs = [(Description, Directives s)] -> Map Description (Directives s)
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(Description, Directives s)] -> Map Description (Directives s))
-> (Maybe (TypeDefinition c s) -> [(Description, Directives s)])
-> Maybe (TypeDefinition c s)
-> Map Description (Directives s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (TypeDefinition c s) -> [(Description, Directives s)]
forall a v. Meta a v => a -> [(Description, v)]
get
class Meta a v where
get :: a -> [(Token, v)]
instance (Meta a v) => Meta (Maybe a) v where
get :: Maybe a -> [(Description, v)]
get (Just a
x) = a -> [(Description, v)]
forall a v. Meta a v => a -> [(Description, v)]
get a
x
get Maybe a
_ = []
instance
( Meta (FieldsDefinition IN s) v,
Meta (FieldsDefinition OUT s) v,
Meta (DataEnumValue s) v
) =>
Meta (TypeDefinition c s) v
where
get :: TypeDefinition c s -> [(Description, v)]
get TypeDefinition {TypeContent TRUE c s
typeContent :: TypeContent TRUE c s
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent} = TypeContent TRUE c s -> [(Description, v)]
forall a v. Meta a v => a -> [(Description, v)]
get TypeContent TRUE c s
typeContent
instance
( Meta (FieldsDefinition IN s) v,
Meta (FieldsDefinition OUT s) v,
Meta (DataEnumValue s) v
) =>
Meta (TypeContent a c s) v
where
get :: TypeContent a c s -> [(Description, v)]
get 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 -> [(Description, v)]
forall a v. Meta a v => a -> [(Description, v)]
get FieldsDefinition OUT s
objectFields
get 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 -> [(Description, v)]
forall a v. Meta a v => a -> [(Description, v)]
get FieldsDefinition IN s
inputObjectFields
get DataInterface {FieldsDefinition OUT s
interfaceFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IMPLEMENTABLE a) a s -> FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields} = FieldsDefinition OUT s -> [(Description, v)]
forall a v. Meta a v => a -> [(Description, v)]
get FieldsDefinition OUT s
interfaceFields
get DataEnum {DataEnum s
enumMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM LEAF a) a s -> DataEnum s
enumMembers :: DataEnum s
enumMembers} = (DataEnumValue s -> [(Description, v)])
-> DataEnum s -> [(Description, v)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataEnumValue s -> [(Description, v)]
forall a v. Meta a v => a -> [(Description, v)]
get DataEnum s
enumMembers
get TypeContent a c s
_ = []
instance Meta (DataEnumValue s) Description where
get :: DataEnumValue s -> [(Description, Description)]
get DataEnumValue {TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumName :: TypeName
enumName, enumDescription :: forall (s :: Stage). DataEnumValue s -> Maybe Description
enumDescription = Just Description
x} = [(TypeName -> Description
readTypeName TypeName
enumName, Description
x)]
get DataEnumValue s
_ = []
instance Meta (DataEnumValue s) (Directives s) where
get :: DataEnumValue s -> [(Description, Directives s)]
get DataEnumValue {TypeName
enumName :: TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumName, Directives s
enumDirectives :: forall (s :: Stage). DataEnumValue s -> [Directive s]
enumDirectives :: Directives s
enumDirectives}
| Directives s -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Directives s
enumDirectives = []
| Bool
otherwise = [(TypeName -> Description
readTypeName TypeName
enumName, Directives s
enumDirectives)]
instance
Meta (FieldDefinition c s) v =>
Meta (FieldsDefinition c s) v
where
get :: FieldsDefinition c s -> [(Description, v)]
get = (FieldDefinition c s -> [(Description, v)])
-> [FieldDefinition c s] -> [(Description, v)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FieldDefinition c s -> [(Description, v)]
forall a v. Meta a v => a -> [(Description, v)]
get ([FieldDefinition c s] -> [(Description, v)])
-> (FieldsDefinition c s -> [FieldDefinition c s])
-> FieldsDefinition c s
-> [(Description, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldsDefinition c s -> [FieldDefinition c s]
forall a coll. Elems a coll => coll -> [a]
elems
instance Meta (FieldDefinition c s) Description where
get :: FieldDefinition c s -> [(Description, Description)]
get FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName, fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Description
fieldDescription = Just Description
x} = [(FieldName -> Description
readName FieldName
fieldName, Description
x)]
get FieldDefinition c s
_ = []
instance Meta (FieldDefinition c s) (Directives s) where
get :: FieldDefinition c s -> [(Description, Directives s)]
get FieldDefinition {FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName, Directives s
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> [Directive s]
fieldDirectives :: Directives s
fieldDirectives}
| Directives s -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Directives s
fieldDirectives = []
| Bool
otherwise = [(FieldName -> Description
readName FieldName
fieldName, Directives s
fieldDirectives)]
collectFieldValues ::
(FieldDefinition IN s -> Maybe a) ->
(FieldDefinition OUT s -> Maybe a) ->
TypeDefinition c s ->
Map FieldName a
collectFieldValues :: (FieldDefinition IN s -> Maybe a)
-> (FieldDefinition OUT s -> Maybe a)
-> TypeDefinition c s
-> Map FieldName a
collectFieldValues FieldDefinition IN s -> Maybe a
_ FieldDefinition OUT s -> Maybe a
g TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectFields}} = (FieldDefinition OUT s -> Maybe a)
-> FieldsDefinition OUT s -> Map FieldName a
forall (c :: TypeCategory) (s :: Stage) a.
(FieldDefinition c s -> Maybe a)
-> FieldsDefinition c s -> Map FieldName a
getFieldValues FieldDefinition OUT s -> Maybe a
g FieldsDefinition OUT s
objectFields
collectFieldValues FieldDefinition IN s -> Maybe a
f FieldDefinition OUT s -> Maybe a
_ TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInputObject {FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
inputObjectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IN a) a s -> FieldsDefinition IN s
inputObjectFields}} = (FieldDefinition IN s -> Maybe a)
-> FieldsDefinition IN s -> Map FieldName a
forall (c :: TypeCategory) (s :: Stage) a.
(FieldDefinition c s -> Maybe a)
-> FieldsDefinition c s -> Map FieldName a
getFieldValues FieldDefinition IN s -> Maybe a
f FieldsDefinition IN s
inputObjectFields
collectFieldValues FieldDefinition IN s -> Maybe a
_ FieldDefinition OUT s -> Maybe a
g TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInterface {FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IMPLEMENTABLE a) a s -> FieldsDefinition OUT s
interfaceFields}} = (FieldDefinition OUT s -> Maybe a)
-> FieldsDefinition OUT s -> Map FieldName a
forall (c :: TypeCategory) (s :: Stage) a.
(FieldDefinition c s -> Maybe a)
-> FieldsDefinition c s -> Map FieldName a
getFieldValues FieldDefinition OUT s -> Maybe a
g FieldsDefinition OUT s
interfaceFields
collectFieldValues FieldDefinition IN s -> Maybe a
_ FieldDefinition OUT s -> Maybe a
_ TypeDefinition c s
_ = Map FieldName a
forall k a. Map k a
empty
getFieldValues :: (FieldDefinition c s -> Maybe a) -> FieldsDefinition c s -> Map FieldName a
getFieldValues :: (FieldDefinition c s -> Maybe a)
-> FieldsDefinition c s -> Map FieldName a
getFieldValues FieldDefinition c s -> Maybe a
f = [(FieldName, a)] -> Map FieldName a
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(FieldName, a)] -> Map FieldName a)
-> (FieldsDefinition c s -> [(FieldName, a)])
-> FieldsDefinition c s
-> Map FieldName a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FieldName, Maybe a)] -> [(FieldName, a)]
forall k a. [(k, Maybe a)] -> [(k, a)]
notNulls ([(FieldName, Maybe a)] -> [(FieldName, a)])
-> (FieldsDefinition c s -> [(FieldName, Maybe a)])
-> FieldsDefinition c s
-> [(FieldName, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDefinition c s -> (FieldName, Maybe a))
-> [FieldDefinition c s] -> [(FieldName, Maybe a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FieldDefinition c s -> Maybe a)
-> FieldDefinition c s -> (FieldName, Maybe a)
forall (c :: TypeCategory) (s :: Stage) a.
(FieldDefinition c s -> Maybe a)
-> FieldDefinition c s -> (FieldName, Maybe a)
getFieldValue FieldDefinition c s -> Maybe a
f) ([FieldDefinition c s] -> [(FieldName, Maybe a)])
-> (FieldsDefinition c s -> [FieldDefinition c s])
-> FieldsDefinition c s
-> [(FieldName, Maybe a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldsDefinition c s -> [FieldDefinition c s]
forall a coll. Elems a coll => coll -> [a]
elems
notNulls :: [(k, Maybe a)] -> [(k, a)]
notNulls :: [(k, Maybe a)] -> [(k, a)]
notNulls [] = []
notNulls ((k
_, Maybe a
Nothing) : [(k, Maybe a)]
xs) = [(k, Maybe a)] -> [(k, a)]
forall k a. [(k, Maybe a)] -> [(k, a)]
notNulls [(k, Maybe a)]
xs
notNulls ((k
name, Just a
x) : [(k, Maybe a)]
xs) = (k
name, a
x) (k, a) -> [(k, a)] -> [(k, a)]
forall a. a -> [a] -> [a]
: [(k, Maybe a)] -> [(k, a)]
forall k a. [(k, Maybe a)] -> [(k, a)]
notNulls [(k, Maybe a)]
xs
getFieldValue :: (FieldDefinition c s -> Maybe a) -> FieldDefinition c s -> (FieldName, Maybe a)
getFieldValue :: (FieldDefinition c s -> Maybe a)
-> FieldDefinition c s -> (FieldName, Maybe a)
getFieldValue FieldDefinition c s -> Maybe a
f FieldDefinition c s
field = (FieldDefinition c s -> FieldName
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName FieldDefinition c s
field, FieldDefinition c s -> Maybe a
f FieldDefinition c s
field)
getDefaultValue :: FieldContent TRUE c s -> (Maybe (Value s), Maybe (ArgumentsDefinition s))
getDefaultValue :: FieldContent TRUE c s
-> (Maybe (Value s), Maybe (ArgumentsDefinition s))
getDefaultValue DefaultInputValue {Value s
defaultInputValue :: forall (cat :: TypeCategory) (s :: Stage).
FieldContent (ELEM IN cat) cat s -> Value s
defaultInputValue :: Value s
defaultInputValue} = (Value s -> Maybe (Value s)
forall a. a -> Maybe a
Just Value s
defaultInputValue, Maybe (ArgumentsDefinition s)
forall a. Maybe a
Nothing)
getDefaultValue (FieldArgs ArgumentsDefinition s
args) = (Maybe (Value s)
forall a. Maybe a
Nothing, ArgumentsDefinition s -> Maybe (ArgumentsDefinition s)
forall a. a -> Maybe a
Just ArgumentsDefinition s
args)