{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Morpheus.Types.Internal.AST.TypeSystem
( Arguments,
ScalarDefinition (..),
DataEnum,
FieldsDefinition,
ArgumentDefinition,
DataUnion,
ArgumentsDefinition (..),
FieldDefinition (..),
InputFieldsDefinition,
TypeContent (..),
TypeDefinition (..),
Schema (..),
DataEnumValue (..),
TypeLib,
Directive (..),
TypeUpdater,
TypeCategory,
DataInputUnion,
Argument (..),
Fields (..),
createField,
createArgument,
createEnumType,
createScalarType,
createType,
createUnionType,
createAlias,
createInputUnionFields,
createEnumValue,
defineType,
isTypeDefined,
initTypeLib,
isFieldNullable,
insertType,
fieldVisibility,
kindOf,
toNullableField,
toListField,
isEntNode,
lookupDeprecated,
lookupDeprecatedReason,
lookupWith,
unsafeFromFields,
__inputname,
updateSchema,
OUT,
IN,
ANY,
FromAny (..),
ToAny (..),
DirectiveDefinitions,
DirectiveDefinition (..),
Directives,
fieldsToArguments,
FieldContent (..),
fieldContentArgs,
mkField,
mkObjectField,
UnionMember (..),
mkUnionMember,
)
where
import Data.HashMap.Lazy
( HashMap,
union,
)
import qualified Data.HashMap.Lazy as HM
import Data.List (find)
import Data.Morpheus.Error (globalErrorMessage)
import Data.Morpheus.Error.NameCollision
( NameCollision (..),
)
import Data.Morpheus.Error.Schema (nameCollisionError)
import Data.Morpheus.Internal.Utils
( Collection (..),
KeyOf (..),
Listable (..),
Merge (..),
Selectable (..),
elems,
)
import Data.Morpheus.Rendering.RenderGQL
( RenderGQL (..),
renderIndent,
renderObject,
)
import Data.Morpheus.Types.Internal.AST.Base
( DataFingerprint (..),
Description,
FALSE,
FieldName,
FieldName (..),
GQLError (..),
Msg (..),
Position,
RESOLVED,
Stage,
TRUE,
Token,
TypeKind (..),
TypeName,
TypeRef (..),
TypeWrapper (..),
VALID,
isNullable,
isSystemTypeName,
msg,
sysFields,
toFieldName,
toOperationType,
)
import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation)
import Data.Morpheus.Types.Internal.AST.OrderedMap
( OrderedMap,
unsafeFromValues,
)
import Data.Morpheus.Types.Internal.AST.Value
( ScalarValue (..),
ValidValue,
Value (..),
)
import Data.Morpheus.Types.Internal.Resolving.Core
( Failure (..),
LibUpdater,
resolveUpdates,
)
import Data.Semigroup (Semigroup (..))
import Data.Text (intercalate)
import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift (..))
type DataEnum = [DataEnumValue]
mkUnionMember :: TypeName -> UnionMember cat
mkUnionMember name = UnionMember name True
data UnionMember (cat :: TypeCategory) = UnionMember
{ memberName :: TypeName,
visibility :: Bool
}
deriving (Show, Lift, Eq)
type DataUnion = [UnionMember OUT]
type DataInputUnion = [UnionMember IN]
instance RenderGQL (UnionMember cat) where
render = render . memberName
newtype ScalarDefinition = ScalarDefinition
{validateValue :: ValidValue -> Either Token ValidValue}
instance Show ScalarDefinition where
show _ = "ScalarDefinition"
instance Lift ScalarDefinition where
lift _ = [|ScalarDefinition pure|]
data Argument (valid :: Stage) = Argument
{ argumentName :: FieldName,
argumentValue :: Value valid,
argumentPosition :: Position
}
deriving (Show, Eq, Lift)
instance KeyOf (Argument stage) where
keyOf = argumentName
instance NameCollision (Argument s) where
nameCollision _ Argument {argumentName, argumentPosition} =
GQLError
{ message = "There can Be only One Argument Named " <> msg argumentName,
locations = [argumentPosition]
}
type Arguments s = OrderedMap FieldName (Argument s)
data Directive (s :: Stage) = Directive
{ directiveName :: FieldName,
directivePosition :: Position,
directiveArgs :: Arguments s
}
deriving (Show, Lift, Eq)
instance KeyOf (Directive s) where
keyOf = directiveName
type Directives s = [Directive s]
data DirectiveDefinition = DirectiveDefinition
{ directiveDefinitionName :: FieldName,
directiveDefinitionDescription :: Maybe Description,
directiveDefinitionLocations :: [DirectiveLocation],
directiveDefinitionArgs :: ArgumentsDefinition
}
deriving (Show, Lift)
type DirectiveDefinitions = [DirectiveDefinition]
instance KeyOf DirectiveDefinition where
keyOf = directiveDefinitionName
instance Selectable DirectiveDefinition ArgumentDefinition where
selectOr fb f key DirectiveDefinition {directiveDefinitionArgs} =
selectOr fb f key directiveDefinitionArgs
lookupDeprecated :: [Directive VALID] -> Maybe (Directive VALID)
lookupDeprecated = find isDeprecation
where
isDeprecation Directive {directiveName = "deprecated"} = True
isDeprecation _ = False
lookupDeprecatedReason :: Directive VALID -> Maybe Description
lookupDeprecatedReason Directive {directiveArgs} =
selectOr Nothing (Just . maybeString) "reason" directiveArgs
where
maybeString :: Argument VALID -> Description
maybeString Argument {argumentValue = (Scalar (String x))} = x
maybeString _ = "can't read deprecated Reason Value"
data DataEnumValue = DataEnumValue
{ enumName :: TypeName,
enumDescription :: Maybe Description,
enumDirectives :: [Directive VALID]
}
deriving (Show, Lift)
instance RenderGQL DataEnumValue where
render DataEnumValue {enumName} = render enumName
data Schema = Schema
{ types :: TypeLib,
query :: TypeDefinition 'Out,
mutation :: Maybe (TypeDefinition 'Out),
subscription :: Maybe (TypeDefinition 'Out)
}
deriving (Show)
type TypeLib = HashMap TypeName (TypeDefinition ANY)
instance Selectable Schema (TypeDefinition ANY) where
selectOr fb f name lib = maybe fb f (lookupDataType name lib)
instance Listable (TypeDefinition ANY) Schema where
elems = HM.elems . typeRegister
fromElems types = case popByKey "Query" types of
(Nothing, _) -> failure (globalErrorMessage "INTERNAL: Query Not Defined")
(Just query, lib1) -> do
let (mutation, lib2) = popByKey "Mutation" lib1
let (subscription, lib3) = popByKey "Subscription" lib2
pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription}
initTypeLib :: TypeDefinition 'Out -> Schema
initTypeLib query =
Schema
{ types = empty,
query = query,
mutation = Nothing,
subscription = Nothing
}
typeRegister :: Schema -> TypeLib
typeRegister Schema {types, query, mutation, subscription} =
types
`union` HM.fromList
(concatMap fromOperation [Just query, mutation, subscription])
lookupDataType :: TypeName -> Schema -> Maybe (TypeDefinition ANY)
lookupDataType name = HM.lookup name . typeRegister
isTypeDefined :: TypeName -> Schema -> Maybe DataFingerprint
isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib
data TypeDefinition (a :: TypeCategory) = TypeDefinition
{ typeName :: TypeName,
typeFingerprint :: DataFingerprint,
typeDescription :: Maybe Description,
typeDirectives :: Directives VALID,
typeContent :: TypeContent TRUE a
}
deriving (Show, Lift)
instance KeyOf (TypeDefinition a) where
type KEY (TypeDefinition a) = TypeName
keyOf = typeName
data TypeCategory = In | Out | Any
type IN = 'In
type OUT = 'Out
type ANY = 'Any
class ToAny a where
toAny :: a (k :: TypeCategory) -> a ANY
instance ToAny TypeDefinition where
toAny TypeDefinition {typeContent, ..} = TypeDefinition {typeContent = toAny typeContent, ..}
instance ToAny (TypeContent TRUE) where
toAny DataScalar {..} = DataScalar {..}
toAny DataEnum {..} = DataEnum {..}
toAny DataInputObject {..} = DataInputObject {..}
toAny DataInputUnion {..} = DataInputUnion {..}
toAny DataObject {..} = DataObject {..}
toAny DataUnion {..} = DataUnion {..}
toAny DataInterface {..} = DataInterface {..}
instance ToAny FieldDefinition where
toAny FieldDefinition {fieldContent, ..} = FieldDefinition {fieldContent = toAny <$> fieldContent, ..}
instance ToAny (FieldContent TRUE) where
toAny (FieldArgs x) = FieldArgs x
toAny (DefaultInputValue x) = DefaultInputValue x
class FromAny a (k :: TypeCategory) where
fromAny :: a ANY -> Maybe (a k)
instance (FromAny (TypeContent TRUE) a) => FromAny TypeDefinition a where
fromAny TypeDefinition {typeContent, ..} = bla <$> fromAny typeContent
where
bla x = TypeDefinition {typeContent = x, ..}
instance FromAny (TypeContent TRUE) IN where
fromAny DataScalar {..} = Just DataScalar {..}
fromAny DataEnum {..} = Just DataEnum {..}
fromAny DataInputObject {..} = Just DataInputObject {..}
fromAny DataInputUnion {..} = Just DataInputUnion {..}
fromAny _ = Nothing
instance FromAny (TypeContent TRUE) OUT where
fromAny DataScalar {..} = Just DataScalar {..}
fromAny DataEnum {..} = Just DataEnum {..}
fromAny DataObject {..} = Just DataObject {..}
fromAny DataUnion {..} = Just DataUnion {..}
fromAny DataInterface {..} = Just DataInterface {..}
fromAny _ = Nothing
type family IsSelected (c :: TypeCategory) (a :: TypeCategory) :: Bool
type instance IsSelected ANY a = TRUE
type instance IsSelected OUT OUT = TRUE
type instance IsSelected IN IN = TRUE
type instance IsSelected IN OUT = FALSE
type instance IsSelected OUT IN = FALSE
type instance IsSelected a ANY = TRUE
data TypeContent (b :: Bool) (a :: TypeCategory) where
DataScalar ::
{ dataScalar :: ScalarDefinition
} ->
TypeContent TRUE a
DataEnum ::
{ enumMembers :: DataEnum
} ->
TypeContent TRUE a
DataInputObject ::
{ inputObjectFields :: FieldsDefinition IN
} ->
TypeContent (IsSelected a IN) a
DataInputUnion ::
{ inputUnionMembers :: DataInputUnion
} ->
TypeContent (IsSelected a IN) a
DataObject ::
{ objectImplements :: [TypeName],
objectFields :: FieldsDefinition OUT
} ->
TypeContent (IsSelected a OUT) a
DataUnion ::
{ unionMembers :: DataUnion
} ->
TypeContent (IsSelected a OUT) a
DataInterface ::
{ interfaceFields :: FieldsDefinition OUT
} ->
TypeContent (IsSelected a OUT) a
deriving instance Show (TypeContent a b)
deriving instance Lift (TypeContent a b)
createType :: TypeName -> TypeContent TRUE a -> TypeDefinition a
createType typeName typeContent =
TypeDefinition
{ typeName,
typeDescription = Nothing,
typeFingerprint = DataFingerprint typeName [],
typeDirectives = [],
typeContent
}
createScalarType :: TypeName -> TypeDefinition a
createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure)
createEnumType :: TypeName -> [TypeName] -> TypeDefinition a
createEnumType typeName typeData = createType typeName (DataEnum enumValues)
where
enumValues = map createEnumValue typeData
createEnumValue :: TypeName -> DataEnumValue
createEnumValue enumName =
DataEnumValue
{ enumName,
enumDescription = Nothing,
enumDirectives = []
}
createUnionType :: TypeName -> [TypeName] -> TypeDefinition OUT
createUnionType typeName typeData = createType typeName (DataUnion $ map mkUnionMember typeData)
isEntNode :: TypeContent TRUE a -> Bool
isEntNode DataScalar {} = True
isEntNode DataEnum {} = True
isEntNode _ = False
kindOf :: TypeDefinition a -> TypeKind
kindOf TypeDefinition {typeName, typeContent} = __kind typeContent
where
__kind DataScalar {} = KindScalar
__kind DataEnum {} = KindEnum
__kind DataInputObject {} = KindInputObject
__kind DataObject {} = KindObject (toOperationType typeName)
__kind DataUnion {} = KindUnion
__kind DataInputUnion {} = KindInputUnion
__kind DataInterface {} = KindInterface
fromOperation :: Maybe (TypeDefinition OUT) -> [(TypeName, TypeDefinition ANY)]
fromOperation (Just datatype) = [(typeName datatype, toAny datatype)]
fromOperation Nothing = []
defineType :: TypeDefinition cat -> Schema -> Schema
defineType dt@TypeDefinition {typeName, typeContent = DataInputUnion enumKeys, typeFingerprint} lib =
lib {types = HM.insert name unionTags (HM.insert typeName (toAny dt) (types lib))}
where
name = typeName <> "Tags"
unionTags =
TypeDefinition
{ typeName = name,
typeFingerprint,
typeDescription = Nothing,
typeDirectives = [],
typeContent = DataEnum $ map (createEnumValue . memberName) enumKeys
}
defineType datatype lib =
lib {types = HM.insert (typeName datatype) (toAny datatype) (types lib)}
insertType ::
TypeDefinition ANY ->
TypeUpdater
insertType datatype@TypeDefinition {typeName} lib = case isTypeDefined typeName lib of
Nothing -> resolveUpdates (defineType datatype lib) []
Just fingerprint
| fingerprint == typeFingerprint datatype -> return lib
| otherwise -> failure $ nameCollisionError typeName
updateSchema ::
TypeName ->
DataFingerprint ->
[TypeUpdater] ->
(a -> TypeDefinition cat) ->
a ->
TypeUpdater
updateSchema name fingerprint stack f x lib =
case isTypeDefined name lib of
Nothing ->
resolveUpdates
(defineType (f x) lib)
stack
Just fingerprint' | fingerprint' == fingerprint -> return lib
Just _ -> failure $ nameCollisionError name
lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a
lookupWith f key = find ((== key) . f)
popByKey :: TypeName -> [TypeDefinition ANY] -> (Maybe (TypeDefinition OUT), [TypeDefinition ANY])
popByKey name types = case lookupWith typeName name types of
Just dt@TypeDefinition {typeContent = DataObject {}} ->
(fromAny dt, filter ((/= name) . typeName) types)
_ -> (Nothing, types)
newtype Fields def = Fields
{unFields :: OrderedMap FieldName def}
deriving
( Show,
Lift,
Functor,
Foldable,
Traversable
)
deriving instance (KEY def ~ FieldName, KeyOf def) => Collection def (Fields def)
instance Merge (FieldsDefinition cat) where
merge path (Fields x) (Fields y) = Fields <$> merge path x y
instance Selectable (Fields (FieldDefinition cat)) (FieldDefinition cat) where
selectOr fb f name (Fields lib) = selectOr fb f name lib
unsafeFromFields :: [FieldDefinition cat] -> FieldsDefinition cat
unsafeFromFields = Fields . unsafeFromValues
fieldsToArguments :: FieldsDefinition IN -> ArgumentsDefinition
fieldsToArguments = ArgumentsDefinition Nothing . unFields
instance (KEY def ~ FieldName, KeyOf def, NameCollision def) => Listable def (Fields def) where
fromElems = fmap Fields . fromElems
elems = elems . unFields
type FieldsDefinition cat = Fields (FieldDefinition cat)
data FieldDefinition (cat :: TypeCategory) = FieldDefinition
{ fieldName :: FieldName,
fieldDescription :: Maybe Description,
fieldType :: TypeRef,
fieldContent :: Maybe (FieldContent TRUE cat),
fieldDirectives :: [Directive VALID]
}
deriving (Show, Lift)
data FieldContent (bool :: Bool) (cat :: TypeCategory) where
DefaultInputValue ::
{ defaultInputValue :: Value RESOLVED
} ->
FieldContent (IsSelected cat IN) cat
FieldArgs ::
{ fieldArgsDef :: ArgumentsDefinition
} ->
FieldContent (IsSelected cat OUT) cat
fieldContentArgs :: FieldContent b cat -> OrderedMap FieldName ArgumentDefinition
fieldContentArgs (FieldArgs (ArgumentsDefinition _ argsD)) = argsD
fieldContentArgs _ = empty
deriving instance Show (FieldContent bool cat)
deriving instance Lift (FieldContent bool cat)
instance KeyOf (FieldDefinition cat) where
keyOf = fieldName
instance Selectable (FieldDefinition OUT) ArgumentDefinition where
selectOr fb f key FieldDefinition {fieldContent = Just (FieldArgs args)} = selectOr fb f key args
selectOr fb _ _ _ = fb
instance NameCollision (FieldDefinition cat) where
nameCollision name _ =
GQLError
{ message = "There can Be only One field Named " <> msg name,
locations = []
}
instance RenderGQL (FieldDefinition cat) where
render FieldDefinition {fieldName = FieldName name, fieldType, fieldContent = Just (FieldArgs args)} =
name <> render args <> ": " <> render fieldType
render FieldDefinition {fieldName = FieldName name, fieldType} =
name <> ": " <> render fieldType
instance RenderGQL (FieldsDefinition OUT) where
render = renderObject render . ignoreHidden . elems
instance RenderGQL (FieldsDefinition IN) where
render = renderObject render . ignoreHidden . elems
fieldVisibility :: FieldDefinition cat -> Bool
fieldVisibility FieldDefinition {fieldName} = fieldName `notElem` sysFields
isFieldNullable :: FieldDefinition cat -> Bool
isFieldNullable = isNullable . fieldType
createField :: Maybe (FieldContent TRUE cat) -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat
createField fieldContent fieldName (typeWrappers, typeConName) =
FieldDefinition
{ fieldName,
fieldContent,
fieldDescription = Nothing,
fieldType = TypeRef {typeConName, typeWrappers, typeArgs = Nothing},
fieldDirectives = []
}
mkField :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat
mkField = createField Nothing
mkObjectField :: ArgumentsDefinition -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition OUT
mkObjectField args = createField (Just $ FieldArgs args)
toNullableField :: FieldDefinition cat -> FieldDefinition cat
toNullableField dataField
| isNullable (fieldType dataField) = dataField
| otherwise = dataField {fieldType = nullable (fieldType dataField)}
where
nullable alias@TypeRef {typeWrappers} =
alias {typeWrappers = TypeMaybe : typeWrappers}
toListField :: FieldDefinition cat -> FieldDefinition cat
toListField dataField = dataField {fieldType = listW (fieldType dataField)}
where
listW alias@TypeRef {typeWrappers} =
alias {typeWrappers = TypeList : typeWrappers}
type InputFieldsDefinition = Fields InputValueDefinition
type InputValueDefinition = FieldDefinition IN
data ArgumentsDefinition = ArgumentsDefinition
{ argumentsTypename :: Maybe TypeName,
arguments :: OrderedMap FieldName ArgumentDefinition
}
deriving (Show, Lift)
instance RenderGQL ArgumentsDefinition where
render ArgumentsDefinition {arguments}
| null arguments =
""
| otherwise = "(" <> intercalate ", " (map render $ elems arguments) <> ")"
type ArgumentDefinition = FieldDefinition IN
instance Selectable ArgumentsDefinition ArgumentDefinition where
selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args
instance Collection ArgumentDefinition ArgumentsDefinition where
empty = ArgumentsDefinition Nothing empty
singleton = ArgumentsDefinition Nothing . singleton
instance Listable ArgumentDefinition ArgumentsDefinition where
elems (ArgumentsDefinition _ args) = elems args
fromElems args = ArgumentsDefinition Nothing <$> fromElems args
createArgument :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition IN
createArgument = mkField
__inputname :: FieldName
__inputname = "inputname"
createInputUnionFields :: TypeName -> [UnionMember IN] -> [FieldDefinition IN]
createInputUnionFields name members = fieldTag : map unionField members
where
fieldTag =
FieldDefinition
{ fieldName = __inputname,
fieldDescription = Nothing,
fieldContent = Nothing,
fieldType = createAlias (name <> "Tags"),
fieldDirectives = []
}
unionField :: UnionMember IN -> FieldDefinition IN
unionField UnionMember {memberName} =
FieldDefinition
{ fieldName = toFieldName memberName,
fieldDescription = Nothing,
fieldContent = Nothing,
fieldType =
TypeRef
{ typeConName = memberName,
typeWrappers = [TypeMaybe],
typeArgs = Nothing
},
fieldDirectives = []
}
createAlias :: TypeName -> TypeRef
createAlias typeConName =
TypeRef {typeConName, typeWrappers = [], typeArgs = Nothing}
type TypeUpdater = LibUpdater Schema
instance RenderGQL Schema where
render schema = intercalate "\n\n" $ map render visibleTypes
where
visibleTypes = filter (not . isSystemTypeName . typeName) (elems schema)
instance RenderGQL (TypeDefinition a) where
render TypeDefinition {typeName, typeContent} = __render typeContent
where
__render DataInterface {interfaceFields} = "interface " <> render typeName <> render interfaceFields
__render DataScalar {} = "scalar " <> render typeName
__render (DataEnum tags) = "enum " <> render typeName <> renderObject render tags
__render (DataUnion members) =
"union "
<> render typeName
<> " =\n "
<> intercalate ("\n" <> renderIndent <> "| ") (map render members)
__render (DataInputObject fields) = "input " <> render typeName <> render fields
__render (DataInputUnion members) = "input " <> render typeName <> render fieldsDef
where
fieldsDef = unsafeFromFields fields
fields :: [FieldDefinition IN]
fields = createInputUnionFields typeName members
__render DataObject {objectFields} = "type " <> render typeName <> render objectFields
ignoreHidden :: [FieldDefinition cat] -> [FieldDefinition cat]
ignoreHidden = filter fieldVisibility