{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} module Data.Morpheus.Types.Internal.AST.Data ( Arguments , ScalarDefinition(..) , DataEnum , FieldsDefinition(..) , ArgumentDefinition , DataUnion , ArgumentsDefinition(..) , FieldDefinition(..) , InputFieldsDefinition(..) , TypeContent(..) , TypeDefinition(..) , Schema(..) , DataEnumValue(..) , TypeLib , Meta(..) , Directive(..) , TypeUpdater , TypeD(..) , ConsD(..) , ClientQuery(..) , GQLTypeD(..) , ClientType(..) , DataInputUnion , Argument(..) , allDataTypes , createField , createArgument , createDataTypeLib , createEnumType , createScalarType , createType , createUnionType , createAlias , createInputUnionFields , createEnumValue , defineType , isTypeDefined , initTypeLib , isFieldNullable , insertType , fieldVisibility , kindOf , toNullableField , toListField , toHSFieldDefinition , isEntNode , lookupDataType , lookupDeprecated , lookupDeprecatedReason , lookupWith , hasArguments , unsafeFromFields , isInputDataType , unsafeFromInputFields , __inputname ) where import Data.HashMap.Lazy ( HashMap , union , elems ) import qualified Data.HashMap.Lazy as HM import Data.Semigroup ( Semigroup(..), (<>) ) import Language.Haskell.TH.Syntax ( Lift(..) ) import Instances.TH.Lift ( ) import Data.List ( find) -- MORPHEUS import Data.Morpheus.Error.NameCollision ( NameCollision(..) ) import Data.Morpheus.Types.Internal.AST.OrderedMap ( OrderedMap , unsafeFromValues ) import Data.Morpheus.Types.Internal.AST.Base ( Key , Position , Name , Message , Description , TypeWrapper(..) , TypeRef(..) , Stage , VALID , DataTypeKind(..) , DataFingerprint(..) , isNullable , sysFields , toOperationType , hsTypeName , GQLError(..) ) import Data.Morpheus.Types.Internal.Operation ( Empty(..) , Selectable(..) , Listable(..) , Singleton(..) , Listable(..) , Merge(..) , KeyOf(..) ) import Data.Morpheus.Types.Internal.Resolving.Core ( Failure(..) , LibUpdater , resolveUpdates ) import Data.Morpheus.Types.Internal.AST.Value ( Value(..) , ValidValue , ScalarValue(..) ) import Data.Morpheus.Error.Schema ( nameCollisionError ) type DataEnum = [DataEnumValue] type DataUnion = [Key] type DataInputUnion = [(Key, Bool)] -- scalar ------------------------------------------------------------------ newtype ScalarDefinition = ScalarDefinition { validateValue :: ValidValue -> Either Key ValidValue } instance Show ScalarDefinition where show _ = "ScalarDefinition" data Argument (valid :: Stage) = Argument { argumentName :: Name , 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 \"" <> argumentName <> "\"", locations = [argumentPosition] } type Arguments s = OrderedMap (Argument s) -- directive ------------------------------------------------------------------ data Directive = Directive { directiveName :: Name, directiveArgs :: OrderedMap (Argument VALID) } deriving (Show,Lift) lookupDeprecated :: Meta -> Maybe Directive lookupDeprecated Meta { metaDirectives } = find isDeprecation metaDirectives where isDeprecation Directive { directiveName = "deprecated" } = True isDeprecation _ = False lookupDeprecatedReason :: Directive -> Maybe Key lookupDeprecatedReason Directive { directiveArgs } = selectOr Nothing (Just . maybeString) "reason" directiveArgs where maybeString :: Argument VALID -> Name maybeString Argument { argumentValue = (Scalar (String x)) } = x maybeString _ = "can't read deprecated Reason Value" -- META data Meta = Meta { metaDescription:: Maybe Description, metaDirectives :: [Directive] } deriving (Show,Lift) -- ENUM VALUE data DataEnumValue = DataEnumValue{ enumName :: Name, enumMeta :: Maybe Meta } deriving (Show, Lift) -- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema --------------------------------------------------------------------------- -- SchemaDefinition : -- schema Directives[Const](opt) { RootOperationTypeDefinition(list)} -- -- RootOperationTypeDefinition : -- OperationType: NamedType data Schema = Schema { types :: TypeLib , query :: TypeDefinition , mutation :: Maybe TypeDefinition , subscription :: Maybe TypeDefinition } deriving (Show) type TypeLib = HashMap Key TypeDefinition instance Selectable Schema TypeDefinition where selectOr fb f name lib = maybe fb f (lookupDataType name lib) initTypeLib :: TypeDefinition -> Schema initTypeLib query = Schema { types = empty , query = query , mutation = Nothing , subscription = Nothing } allDataTypes :: Schema -> [TypeDefinition] allDataTypes = elems . typeRegister typeRegister :: Schema -> TypeLib typeRegister Schema { types, query, mutation, subscription } = types `union` HM.fromList (concatMap fromOperation [Just query, mutation, subscription]) createDataTypeLib :: Failure Message m => [TypeDefinition] -> m Schema createDataTypeLib types = case popByKey "Query" types of (Nothing ,_ ) -> failure ("INTERNAL: Query Not Defined" :: Message) (Just query, lib1) -> do let (mutation, lib2) = popByKey "Mutation" lib1 let (subscription, lib3) = popByKey "Subscription" lib2 pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription} -- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types ------------------------------------------------------------------------- -- TypeDefinition : -- ScalarTypeDefinition -- ObjectTypeDefinition -- InterfaceTypeDefinition -- UnionTypeDefinition -- EnumTypeDefinition -- InputObjectTypeDefinition data TypeDefinition = TypeDefinition { typeName :: Key , typeFingerprint :: DataFingerprint , typeMeta :: Maybe Meta , typeContent :: TypeContent } deriving (Show) data TypeContent = DataScalar { dataScalar :: ScalarDefinition } | DataEnum { enumMembers :: DataEnum } | DataInputObject { inputObjectFields :: InputFieldsDefinition } | DataObject { objectImplements :: [Name], objectFields :: FieldsDefinition } | DataUnion { unionMembers :: DataUnion } | DataInputUnion { inputUnionMembers :: [(Key,Bool)] } | DataInterface { interfaceFields :: FieldsDefinition } deriving (Show) createType :: Key -> TypeContent -> TypeDefinition createType typeName typeContent = TypeDefinition { typeName , typeMeta = Nothing , typeFingerprint = DataFingerprint typeName [] , typeContent } createScalarType :: Name -> TypeDefinition createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure) createEnumType :: Name -> [Key] -> TypeDefinition createEnumType typeName typeData = createType typeName (DataEnum enumValues) where enumValues = map createEnumValue typeData createEnumValue :: Name -> DataEnumValue createEnumValue enumName = DataEnumValue { enumName, enumMeta = Nothing } createUnionType :: Key -> [Key] -> TypeDefinition createUnionType typeName typeData = createType typeName (DataUnion typeData) isEntNode :: TypeContent -> Bool isEntNode DataScalar{} = True isEntNode DataEnum{} = True isEntNode _ = False isInputDataType :: TypeDefinition -> Bool isInputDataType TypeDefinition { typeContent } = __isInput typeContent where __isInput DataScalar{} = True __isInput DataEnum{} = True __isInput DataInputObject{} = True __isInput DataInputUnion{} = True __isInput _ = False kindOf :: TypeDefinition -> DataTypeKind 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 -- TODO: -- __kind DataInterface {} = KindInterface fromOperation :: Maybe TypeDefinition -> [(Name, TypeDefinition)] fromOperation (Just datatype) = [(typeName datatype,datatype)] fromOperation Nothing = [] lookupDataType :: Key -> Schema -> Maybe TypeDefinition lookupDataType name = HM.lookup name . typeRegister isTypeDefined :: Key -> Schema -> Maybe DataFingerprint isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib defineType :: TypeDefinition -> Schema -> Schema defineType dt@TypeDefinition { typeName, typeContent = DataInputUnion enumKeys, typeFingerprint } lib = lib { types = HM.insert name unionTags (HM.insert typeName dt (types lib)) } where name = typeName <> "Tags" unionTags = TypeDefinition { typeName = name , typeFingerprint , typeMeta = Nothing , typeContent = DataEnum $ map (createEnumValue . fst) enumKeys } defineType datatype lib = lib { types = HM.insert (typeName datatype) datatype (types lib) } insertType :: TypeDefinition -> TypeUpdater insertType datatype@TypeDefinition { typeName } lib = case isTypeDefined typeName lib of Nothing -> resolveUpdates (defineType datatype lib) [] Just fingerprint | fingerprint == typeFingerprint datatype -> return lib -- throw error if 2 different types has same name | otherwise -> failure $ nameCollisionError typeName lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a lookupWith f key = find ((== key) . f) -- lookups and removes TypeDefinition from hashmap popByKey :: Name -> [TypeDefinition] -> (Maybe TypeDefinition,[TypeDefinition]) popByKey name lib = case lookupWith typeName name lib of Just dt@TypeDefinition { typeContent = DataObject {} } -> (Just dt, filter ((/= name) . typeName) lib) _ -> (Nothing, lib) -- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects ------------------------------------------------------------------------------ -- ObjectTypeDefinition: -- Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt) -- -- ImplementsInterfaces -- implements &(opt) NamedType -- ImplementsInterfaces & NamedType -- -- FieldsDefinition -- { FieldDefinition(list) } -- newtype FieldsDefinition = FieldsDefinition { unFieldsDefinition :: OrderedMap FieldDefinition } deriving (Show, Empty) unsafeFromFields :: [FieldDefinition] -> FieldsDefinition unsafeFromFields = FieldsDefinition . unsafeFromValues instance Merge FieldsDefinition where merge path (FieldsDefinition x) (FieldsDefinition y) = FieldsDefinition <$> merge path x y instance Selectable FieldsDefinition FieldDefinition where selectOr fb f name (FieldsDefinition lib) = selectOr fb f name lib instance Singleton FieldsDefinition FieldDefinition where singleton = FieldsDefinition . singleton instance Listable FieldsDefinition FieldDefinition where fromAssoc ls = FieldsDefinition <$> fromAssoc ls toAssoc = toAssoc . unFieldsDefinition -- FieldDefinition -- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) -- data FieldDefinition = FieldDefinition { fieldName :: Key , fieldArgs :: ArgumentsDefinition , fieldType :: TypeRef , fieldMeta :: Maybe Meta } deriving (Show,Lift) instance KeyOf FieldDefinition where keyOf = fieldName instance Selectable FieldDefinition ArgumentDefinition where selectOr fb f key FieldDefinition { fieldArgs } = selectOr fb f key fieldArgs instance NameCollision FieldDefinition where nameCollision name _ = GQLError { message = "There can Be only One field Named \"" <> name <> "\"", locations = [] } fieldVisibility :: FieldDefinition -> Bool fieldVisibility FieldDefinition { fieldName } = fieldName `notElem` sysFields isFieldNullable :: FieldDefinition -> Bool isFieldNullable = isNullable . fieldType createField :: ArgumentsDefinition -> Key -> ([TypeWrapper], Key) -> FieldDefinition createField dataArguments fieldName (typeWrappers, typeConName) = FieldDefinition { fieldArgs = dataArguments , fieldName , fieldType = TypeRef { typeConName, typeWrappers, typeArgs = Nothing } , fieldMeta = Nothing } toHSFieldDefinition :: FieldDefinition -> FieldDefinition toHSFieldDefinition field@FieldDefinition { fieldType = tyRef@TypeRef { typeConName } } = field { fieldType = tyRef { typeConName = hsTypeName typeConName } } toNullableField :: FieldDefinition -> FieldDefinition toNullableField dataField | isNullable (fieldType dataField) = dataField | otherwise = dataField { fieldType = nullable (fieldType dataField) } where nullable alias@TypeRef { typeWrappers } = alias { typeWrappers = TypeMaybe : typeWrappers } toListField :: FieldDefinition -> FieldDefinition toListField dataField = dataField { fieldType = listW (fieldType dataField) } where listW alias@TypeRef { typeWrappers } = alias { typeWrappers = TypeList : typeWrappers } -- 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects --------------------------------------------------------------------------- -- InputObjectTypeDefinition -- Description(opt) input Name Directives(const,opt) InputFieldsDefinition(opt) -- --- InputFieldsDefinition -- { InputValueDefinition(list) } newtype InputFieldsDefinition = InputFieldsDefinition { unInputFieldsDefinition :: OrderedMap FieldDefinition } deriving (Show, Empty) unsafeFromInputFields :: [FieldDefinition] -> InputFieldsDefinition unsafeFromInputFields = InputFieldsDefinition . unsafeFromValues instance Merge InputFieldsDefinition where merge path (InputFieldsDefinition x) (InputFieldsDefinition y) = InputFieldsDefinition <$> merge path x y instance Selectable InputFieldsDefinition FieldDefinition where selectOr fb f name (InputFieldsDefinition lib) = selectOr fb f name lib instance Singleton InputFieldsDefinition FieldDefinition where singleton = InputFieldsDefinition . singleton instance Listable InputFieldsDefinition FieldDefinition where fromAssoc ls = InputFieldsDefinition <$> fromAssoc ls toAssoc = toAssoc . unInputFieldsDefinition -- 3.6.1 Field Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments ----------------------------------------------------------------------------------------------- -- ArgumentsDefinition: -- (InputValueDefinition(list)) data ArgumentsDefinition = ArgumentsDefinition { argumentsTypename :: Maybe Name , arguments :: OrderedMap ArgumentDefinition } | NoArguments deriving (Show, Lift) type ArgumentDefinition = FieldDefinition instance Selectable ArgumentsDefinition ArgumentDefinition where selectOr fb _ _ NoArguments = fb selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args instance Singleton ArgumentsDefinition ArgumentDefinition where singleton = ArgumentsDefinition Nothing . singleton instance Listable ArgumentsDefinition ArgumentDefinition where toAssoc NoArguments = [] toAssoc (ArgumentsDefinition _ args) = toAssoc args fromAssoc [] = pure NoArguments fromAssoc args = ArgumentsDefinition Nothing <$> fromAssoc args createArgument :: Key -> ([TypeWrapper], Key) -> FieldDefinition createArgument = createField NoArguments hasArguments :: ArgumentsDefinition -> Bool hasArguments NoArguments = False hasArguments _ = True -- https://spec.graphql.org/June2018/#InputValueDefinition -- InputValueDefinition -- Description(opt) Name: TypeDefaultValue(opt) Directives[Const](opt) -- TODO: implement inputValue -- data InputValueDefinition = InputValueDefinition -- { inputValueName :: Key -- , inputValueType :: TypeRef -- , inputValueMeta :: Maybe Meta -- } deriving (Show,Lift) __inputname :: Name __inputname = "inputname" createInputUnionFields :: Key -> [Key] -> [FieldDefinition] createInputUnionFields name members = fieldTag : map unionField members where fieldTag = FieldDefinition { fieldName = __inputname , fieldArgs = NoArguments , fieldType = createAlias (name <> "Tags") , fieldMeta = Nothing } unionField memberName = FieldDefinition { fieldArgs = NoArguments , fieldName = memberName , fieldType = TypeRef { typeConName = memberName , typeWrappers = [TypeMaybe] , typeArgs = Nothing } , fieldMeta = Nothing } -- -- OTHER -------------------------------------------------------------------------------------------------- createAlias :: Key -> TypeRef createAlias typeConName = TypeRef { typeConName, typeWrappers = [], typeArgs = Nothing } type TypeUpdater = LibUpdater Schema -- TEMPLATE HASKELL DATA TYPES data ClientQuery = ClientQuery { queryText :: String , queryTypes :: [ClientType] , queryArgsType :: Maybe TypeD } deriving (Show) data ClientType = ClientType { clientType :: TypeD, clientKind :: DataTypeKind } deriving (Show) -- Document data GQLTypeD = GQLTypeD { typeD :: TypeD , typeKindD :: DataTypeKind , typeArgD :: [TypeD] , typeOriginal:: TypeDefinition } deriving (Show) data TypeD = TypeD { tName :: Name , tNamespace :: [Name] , tCons :: [ConsD] , tMeta :: Maybe Meta } deriving (Show) data ConsD = ConsD { cName :: Name , cFields :: [FieldDefinition] } deriving (Show)