morpheus-graphql 0.8.0 → 0.9.0
raw patch · 55 files changed
+841/−784 lines, 55 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Data.Morpheus.Types.Internal.AST: ArgsType :: Key -> ResolverKind -> ArgsType
- Data.Morpheus.Types.Internal.AST: DataTypeLib :: HashMap Key DataType -> (Name, DataType) -> Maybe (Name, DataType) -> Maybe (Name, DataType) -> DataTypeLib
- Data.Morpheus.Types.Internal.AST: ExternalResolver :: ResolverKind
- Data.Morpheus.Types.Internal.AST: FinalDataType :: DataType -> RawDataType
- Data.Morpheus.Types.Internal.AST: Implements :: Key -> [Key] -> Maybe Meta -> DataObject -> RawDataType
- Data.Morpheus.Types.Internal.AST: Interface :: Key -> Maybe Meta -> DataObject -> RawDataType
- Data.Morpheus.Types.Internal.AST: PlainResolver :: ResolverKind
- Data.Morpheus.Types.Internal.AST: TypeVarResolver :: ResolverKind
- Data.Morpheus.Types.Internal.AST: [argsTypeName] :: ArgsType -> Key
- Data.Morpheus.Types.Internal.AST: [implementsContent] :: RawDataType -> DataObject
- Data.Morpheus.Types.Internal.AST: [implementsInterfaces] :: RawDataType -> [Key]
- Data.Morpheus.Types.Internal.AST: [implementsMeta] :: RawDataType -> Maybe Meta
- Data.Morpheus.Types.Internal.AST: [implementsName] :: RawDataType -> Key
- Data.Morpheus.Types.Internal.AST: [interfaceContent] :: RawDataType -> DataObject
- Data.Morpheus.Types.Internal.AST: [interfaceMeta] :: RawDataType -> Maybe Meta
- Data.Morpheus.Types.Internal.AST: [interfaceName] :: RawDataType -> Key
- Data.Morpheus.Types.Internal.AST: [resKind] :: ArgsType -> ResolverKind
- Data.Morpheus.Types.Internal.AST: data ArgsType
- Data.Morpheus.Types.Internal.AST: data DataTypeLib
- Data.Morpheus.Types.Internal.AST: data RawDataType
- Data.Morpheus.Types.Internal.AST: data ResolverKind
- Data.Morpheus.Types.Internal.AST: getDataType :: Failure error m => Key -> DataTypeLib -> error -> m DataType
- Data.Morpheus.Types.Internal.AST: lookupDataObject :: (Monad m, Failure e m) => e -> Key -> DataTypeLib -> m (Name, DataObject)
- Data.Morpheus.Types.Internal.AST: lookupType :: Failure e m => e -> [(Key, a)] -> Key -> m a
+ Data.Morpheus.Types: type WithOperation (o :: OperationType) = LiftOperation o Resolver
+ Data.Morpheus.Types.Internal.AST: DataInterface :: DataObject -> DataTypeContent
+ Data.Morpheus.Types.Internal.AST: FULL_VALIDATION :: VALIDATION_MODE
+ Data.Morpheus.Types.Internal.AST: Schema :: HashMap Name DataType -> (Name, DataType) -> Maybe (Name, DataType) -> Maybe (Name, DataType) -> Schema
+ Data.Morpheus.Types.Internal.AST: WITHOUT_VARIABLES :: VALIDATION_MODE
+ Data.Morpheus.Types.Internal.AST: [dataScalar] :: DataTypeContent -> DataScalar
+ Data.Morpheus.Types.Internal.AST: [enumMembers] :: DataTypeContent -> DataEnum
+ Data.Morpheus.Types.Internal.AST: [inputObjectFields] :: DataTypeContent -> DataObject
+ Data.Morpheus.Types.Internal.AST: [inputUnionMembers] :: DataTypeContent -> [(Key, Bool)]
+ Data.Morpheus.Types.Internal.AST: [interfaceFields] :: DataTypeContent -> DataObject
+ Data.Morpheus.Types.Internal.AST: [objectFields] :: DataTypeContent -> DataObject
+ Data.Morpheus.Types.Internal.AST: [objectImplements] :: DataTypeContent -> [Name]
+ Data.Morpheus.Types.Internal.AST: [unionMembers] :: DataTypeContent -> DataUnion
+ Data.Morpheus.Types.Internal.AST: checkForUnknownKeys :: Failure e m => [Ref] -> [Name] -> ([Ref] -> e) -> m [Ref]
+ Data.Morpheus.Types.Internal.AST: checkNameCollision :: (Failure e m, Ord a) => [a] -> ([a] -> e) -> m [a]
+ Data.Morpheus.Types.Internal.AST: class DataLookup l a
+ Data.Morpheus.Types.Internal.AST: data Schema
+ Data.Morpheus.Types.Internal.AST: data VALIDATION_MODE
+ Data.Morpheus.Types.Internal.AST: isOutputType :: DataTypeKind -> Bool
+ Data.Morpheus.Types.Internal.AST: lookupResult :: (DataLookup l a, Failure e m, Monad m) => e -> Name -> l -> m a
- Data.Morpheus.Client: __fetch :: (Fetch a, Monad m, Show a, ToJSON (Args a), FromJSON a) => String -> String -> (ByteString -> m ByteString) -> Args a -> m (Either String a)
+ Data.Morpheus.Client: __fetch :: (Fetch a, Monad m, Show a, ToJSON (Args a), FromJSON a) => String -> Text -> (ByteString -> m ByteString) -> Args a -> m (Either String a)
- Data.Morpheus.Client: defineQuery :: IO (Validation DataTypeLib) -> (GQLQuery, String) -> Q [Dec]
+ Data.Morpheus.Client: defineQuery :: IO (Validation Schema) -> (GQLQuery, String) -> Q [Dec]
- Data.Morpheus.Document: parseDSL :: ByteString -> Either String DataTypeLib
+ Data.Morpheus.Document: parseDSL :: ByteString -> Either String Schema
- Data.Morpheus.Document: parseFullGQLDocument :: ByteString -> Validation DataTypeLib
+ Data.Morpheus.Document: parseFullGQLDocument :: ByteString -> Validation Schema
- Data.Morpheus.Types: constRes :: (LiftEither o Resolver, Monad m) => b -> a -> Resolver o e m b
+ Data.Morpheus.Types: constRes :: (WithOperation o, Monad m) => b -> a -> Resolver o e m b
- Data.Morpheus.Types: failRes :: (LiftEither o Resolver, Monad m) => String -> Resolver o e m a
+ Data.Morpheus.Types: failRes :: (WithOperation o, Monad m) => String -> Resolver o e m a
- Data.Morpheus.Types: liftEither :: (LiftEither o res, Monad m) => m (Either (ResError res) a) -> res o event m a
+ Data.Morpheus.Types: liftEither :: (MonadTrans t, Monad (t m), Failure Message (t m)) => Monad m => m (Either String a) -> t m a
- Data.Morpheus.Types.Internal.AST: ConsD :: String -> [DataField] -> ConsD
+ Data.Morpheus.Types.Internal.AST: ConsD :: Name -> [DataField] -> ConsD
- Data.Morpheus.Types.Internal.AST: DataField :: Key -> [(Key, DataArgument)] -> Maybe ArgsType -> TypeRef -> Maybe Meta -> DataField
+ Data.Morpheus.Types.Internal.AST: DataField :: Key -> [(Key, DataArgument)] -> Maybe Name -> TypeRef -> Maybe Meta -> DataField
- Data.Morpheus.Types.Internal.AST: DataObject :: DataObject -> DataTypeContent
+ Data.Morpheus.Types.Internal.AST: DataObject :: [Name] -> DataObject -> DataTypeContent
- Data.Morpheus.Types.Internal.AST: TypeD :: String -> [String] -> [ConsD] -> Maybe Meta -> TypeD
+ Data.Morpheus.Types.Internal.AST: TypeD :: Name -> [Name] -> [ConsD] -> Maybe Meta -> TypeD
- Data.Morpheus.Types.Internal.AST: [cName] :: ConsD -> String
+ Data.Morpheus.Types.Internal.AST: [cName] :: ConsD -> Name
- Data.Morpheus.Types.Internal.AST: [fieldArgsType] :: DataField -> Maybe ArgsType
+ Data.Morpheus.Types.Internal.AST: [fieldArgsType] :: DataField -> Maybe Name
- Data.Morpheus.Types.Internal.AST: [mutation] :: DataTypeLib -> Maybe (Name, DataType)
+ Data.Morpheus.Types.Internal.AST: [mutation] :: Schema -> Maybe (Name, DataType)
- Data.Morpheus.Types.Internal.AST: [query] :: DataTypeLib -> (Name, DataType)
+ Data.Morpheus.Types.Internal.AST: [query] :: Schema -> (Name, DataType)
- Data.Morpheus.Types.Internal.AST: [subscription] :: DataTypeLib -> Maybe (Name, DataType)
+ Data.Morpheus.Types.Internal.AST: [subscription] :: Schema -> Maybe (Name, DataType)
- Data.Morpheus.Types.Internal.AST: [tName] :: TypeD -> String
+ Data.Morpheus.Types.Internal.AST: [tName] :: TypeD -> Name
- Data.Morpheus.Types.Internal.AST: [tNamespace] :: TypeD -> [String]
+ Data.Morpheus.Types.Internal.AST: [tNamespace] :: TypeD -> [Name]
- Data.Morpheus.Types.Internal.AST: [types] :: DataTypeLib -> HashMap Key DataType
+ Data.Morpheus.Types.Internal.AST: [types] :: Schema -> HashMap Name DataType
- Data.Morpheus.Types.Internal.AST: allDataTypes :: DataTypeLib -> [(Key, DataType)]
+ Data.Morpheus.Types.Internal.AST: allDataTypes :: Schema -> [(Key, DataType)]
- Data.Morpheus.Types.Internal.AST: createDataTypeLib :: [(Key, DataType)] -> Validation DataTypeLib
+ Data.Morpheus.Types.Internal.AST: createDataTypeLib :: [(Key, DataType)] -> Validation Schema
- Data.Morpheus.Types.Internal.AST: defineType :: (Key, DataType) -> DataTypeLib -> DataTypeLib
+ Data.Morpheus.Types.Internal.AST: defineType :: (Key, DataType) -> Schema -> Schema
- Data.Morpheus.Types.Internal.AST: getOperationDataType :: Operation a -> DataTypeLib -> Validation DataType
+ Data.Morpheus.Types.Internal.AST: getOperationDataType :: Operation a -> Schema -> Validation DataType
- Data.Morpheus.Types.Internal.AST: getOperationObject :: Operation a -> DataTypeLib -> Validation (Name, DataObject)
+ Data.Morpheus.Types.Internal.AST: getOperationObject :: Operation a -> Schema -> Validation (Name, DataObject)
- Data.Morpheus.Types.Internal.AST: initTypeLib :: (Key, DataType) -> DataTypeLib
+ Data.Morpheus.Types.Internal.AST: initTypeLib :: (Key, DataType) -> Schema
- Data.Morpheus.Types.Internal.AST: isTypeDefined :: Key -> DataTypeLib -> Maybe DataFingerprint
+ Data.Morpheus.Types.Internal.AST: isTypeDefined :: Key -> Schema -> Maybe DataFingerprint
- Data.Morpheus.Types.Internal.AST: lookupDataType :: Key -> DataTypeLib -> Maybe DataType
+ Data.Morpheus.Types.Internal.AST: lookupDataType :: Key -> Schema -> Maybe DataType
- Data.Morpheus.Types.Internal.AST: lookupDataUnion :: (Monad m, Failure e m) => e -> Key -> DataTypeLib -> m DataUnion
+ Data.Morpheus.Types.Internal.AST: lookupDataUnion :: (Monad m, Failure e m) => e -> Key -> Schema -> m DataUnion
- Data.Morpheus.Types.Internal.AST: lookupFieldAsSelectionSet :: (Monad m, Failure GQLErrors m) => Position -> Key -> DataTypeLib -> DataField -> m (Name, DataObject)
+ Data.Morpheus.Types.Internal.AST: lookupFieldAsSelectionSet :: (Monad m, Failure GQLErrors m) => Position -> Key -> Schema -> DataField -> m (Name, DataObject)
- Data.Morpheus.Types.Internal.AST: lookupInputType :: Failure e m => Key -> DataTypeLib -> e -> m DataType
+ Data.Morpheus.Types.Internal.AST: lookupInputType :: Failure e m => Key -> Schema -> e -> m DataType
- Data.Morpheus.Types.Internal.AST: lookupUnionTypes :: (Monad m, Failure GQLErrors m) => Position -> Key -> DataTypeLib -> DataField -> m [(Name, DataObject)]
+ Data.Morpheus.Types.Internal.AST: lookupUnionTypes :: (Monad m, Failure GQLErrors m) => Position -> Key -> Schema -> DataField -> m [(Name, DataObject)]
- Data.Morpheus.Types.Internal.AST: type RAW = 'VALID
+ Data.Morpheus.Types.Internal.AST: type RAW = 'RAW
- Data.Morpheus.Types.Internal.AST: type TypeUpdater = LibUpdater DataTypeLib
+ Data.Morpheus.Types.Internal.AST: type TypeUpdater = LibUpdater Schema
- Data.Morpheus.Types.Internal.AST: type VALID = 'RAW
+ Data.Morpheus.Types.Internal.AST: type VALID = 'VALID
Files
- README.md +23/−24
- changelog.md +83/−6
- morpheus-graphql.cabal +4/−3
- src/Data/Morpheus/Client.hs +2/−2
- src/Data/Morpheus/Document.hs +5/−5
- src/Data/Morpheus/Execution/Client/Aeson.hs +15/−14
- src/Data/Morpheus/Execution/Client/Build.hs +4/−3
- src/Data/Morpheus/Execution/Client/Compile.hs +3/−4
- src/Data/Morpheus/Execution/Client/Fetch.hs +9/−5
- src/Data/Morpheus/Execution/Client/Selection.hs +39/−43
- src/Data/Morpheus/Execution/Document/Compile.hs +2/−3
- src/Data/Morpheus/Execution/Document/Convert.hs +107/−93
- src/Data/Morpheus/Execution/Document/Declare.hs +1/−1
- src/Data/Morpheus/Execution/Document/Encode.hs +30/−17
- src/Data/Morpheus/Execution/Document/GQLType.hs +10/−9
- src/Data/Morpheus/Execution/Document/Introspect.hs +7/−8
- src/Data/Morpheus/Execution/Internal/Declare.hs +22/−22
- src/Data/Morpheus/Execution/Internal/Decode.hs +1/−1
- src/Data/Morpheus/Execution/Internal/Utils.hs +16/−13
- src/Data/Morpheus/Execution/Server/Encode.hs +13/−12
- src/Data/Morpheus/Execution/Server/Introspect.hs +16/−9
- src/Data/Morpheus/Execution/Server/Resolve.hs +9/−10
- src/Data/Morpheus/Parsing/Document/Parser.hs +2/−2
- src/Data/Morpheus/Parsing/Document/TypeSystem.hs +25/−31
- src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +4/−3
- src/Data/Morpheus/Rendering/RenderGQL.hs +4/−3
- src/Data/Morpheus/Rendering/RenderIntrospection.hs +63/−63
- src/Data/Morpheus/Schema/SchemaAPI.hs +14/−19
- src/Data/Morpheus/Types.hs +15/−4
- src/Data/Morpheus/Types/Internal/AST.hs +6/−8
- src/Data/Morpheus/Types/Internal/AST/Base.hs +20/−2
- src/Data/Morpheus/Types/Internal/AST/Data.hs +100/−114
- src/Data/Morpheus/Types/Internal/AST/Selection.hs +4/−4
- src/Data/Morpheus/Types/Internal/Resolving.hs +2/−1
- src/Data/Morpheus/Types/Internal/Resolving/Core.hs +10/−3
- src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +37/−33
- src/Data/Morpheus/Types/Internal/TH.hs +22/−9
- src/Data/Morpheus/Validation/Document/Validation.hs +13/−28
- src/Data/Morpheus/Validation/Internal/Utils.hs +0/−47
- src/Data/Morpheus/Validation/Internal/Value.hs +2/−2
- src/Data/Morpheus/Validation/Query/Arguments.hs +5/−7
- src/Data/Morpheus/Validation/Query/Fragment.hs +8/−7
- src/Data/Morpheus/Validation/Query/Selection.hs +11/−15
- src/Data/Morpheus/Validation/Query/Validation.hs +3/−5
- src/Data/Morpheus/Validation/Query/Variable.hs +5/−6
- test/Feature/Holistic/API.hs +15/−13
- test/Feature/Holistic/cases.json +4/−0
- test/Feature/Holistic/selection/__typename/query.gql +5/−0
- test/Feature/Holistic/selection/__typename/response.json +7/−0
- test/Feature/InputType/API.hs +1/−5
- test/Feature/Schema/A2.hs +5/−8
- test/Feature/Schema/API.hs +1/−5
- test/Feature/UnionType/API.hs +4/−19
- test/Feature/WrappedTypeName/API.hs +2/−10
- test/Rendering/TestSchemaRendering.hs +1/−1
README.md view
@@ -2,8 +2,8 @@ Build GraphQL APIs with your favourite functional language! -Morpheus GraphQL (Server & Client) helps you to build GraphQL APIs in Haskell with native haskell types.-Morpheus will convert your haskell types to a GraphQL schema and all your resolvers are just native Haskell functions. Mopheus GraphQL can also convert your GraphQL Schema or Query to Haskell types and validate them in compile time.+Morpheus GraphQL (Server & Client) helps you to build GraphQL APIs in Haskell with native Haskell types.+Morpheus will convert your Haskell types to a GraphQL schema and all your resolvers are just native Haskell functions. Mopheus GraphQL can also convert your GraphQL Schema or Query to Haskell types and validate them in compile time. Morpheus is still in an early stage of development, so any feedback is more than welcome, and we appreciate any contribution! Just open an issue here on GitHub, or join [our Slack channel](https://morpheus-graphql-slack-invite.herokuapp.com/) to get in touch.@@ -29,7 +29,7 @@ resolver: lts-14.8 extra-deps:- - morpheus-graphql-0.8.0+ - morpheus-graphql-0.9.0 ``` As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update`@@ -90,10 +90,11 @@ subscriptionResolver = Undefined } where- queryDeity QueryDeityArgs {queryDeityArgsName} = pure Deity {deityName, deityPower}- where- deityName _ = pure "Morpheus"- deityPower _ = pure (Just "Shapeshifting")+ queryDeity QueryDeityArgs {queryDeityArgsName} = pure Deity+ {+ deityName = pure "Morpheus"+ , deityPower = pure (Just "Shapeshifting")+ } api :: ByteString -> IO ByteString api = interpreter rootResolver@@ -101,9 +102,9 @@ Template Haskell Generates types: `Query` , `Deity`, `DeityArgs`, that can be used by `rootResolver` -`descriptions` and `deprecations` will be displayed in intropsection.+`descriptions` and `deprecations` will be displayed in introspection. -`importGQLDocumentWithNamespace` will generate Types with namespaced fields. if you don't need napespacing use `importGQLDocument`+`importGQLDocumentWithNamespace` will generate Types with namespaced fields. If you don't need napespacing use `importGQLDocument` ### with Native Haskell Types @@ -231,8 +232,7 @@ ```haskell data Character- = data Character =- CharacterDeity Deity -- Only <tyconName><conName> should generate direct link+ = CharacterDeity Deity -- Only <tyconName><conName> should generate direct link -- RECORDS | Creature { creatureName :: Text, creatureAge :: Int } --- Types@@ -245,11 +245,11 @@ deriving (Generic, GQLType) ``` -where deity is and object+where `Deity` is an object. -as you see there ar different kinds of unions. `morpheus` handles them all.+As you see there are different kinds of unions. `morpheus` handles them all. -this type will be represented as+This type will be represented as ```gql union Character =@@ -291,7 +291,7 @@ - namespaced Unions: `CharacterDeity` where `Character` is TypeConstructor and `Deity` referenced object (not scalar) type: will be generate regular graphql Union -- for for all other unions will be generated new object type. for types without record syntaxt, fields will be automatally indexed.+- for all other unions will be generated new object type. for types without record syntaxt, fields will be automatally indexed. - all empty constructors in union will be summed in type `<tyConName>Enum` (e.g `CharacterEnum`), this enum will be wrapped in `CharacterEnumObject` and added to union members. @@ -389,7 +389,7 @@ im morpheus subscription and mutation communicating with Events, `Event` consists with user defined `Channel` and `Content`. -every subscription has own Channel by which will be triggered+Every subscription has its own Channel by which it will be triggered ```haskell data Channel@@ -403,36 +403,35 @@ type MyEvent = Event Channel Content newtype Query m = Query- { deity :: () -> m Deity+ { deity :: m Deity } deriving (Generic) newtype Mutation m = Mutation- { createDeity :: () -> m Deity+ { createDeity :: m Deity } deriving (Generic) newtype Subscription (m :: * -> * ) = Subscription- { newDeity :: () -> m Deity+ { newDeity :: m Deity } deriving (Generic) type APIEvent = Event Channel Content rootResolver :: GQLRootResolver IO APIEvent Query Mutation Subscription rootResolver = GQLRootResolver- { queryResolver = Query { deity }+ { queryResolver = Query { deity = fetchDeity } , mutationResolver = Mutation { createDeity } , subscriptionResolver = Subscription { newDeity } } where- deity _args = fetchDeity -- Mutation Without Event Triggering- createDeity :: () -> ResolveM EVENT IO Address- createDeity _args = MutResolver \$ do+ createDeity :: ResolveM EVENT IO Address+ createDeity = MutResolver \$ do value <- lift dbCreateDeity pure ( [Event { channels = [ChannelA], content = ContentA 1 }], value )- newDeity _args = SubResolver [ChannelA] subResolver+ newDeity = SubResolver [ChannelA] subResolver where subResolver (Event [ChannelA] (ContentA _value)) = fetchDeity -- resolve New State subResolver (Event [ChannelA] (ContentB _value)) = fetchDeity -- resolve New State
changelog.md view
@@ -1,7 +1,84 @@-## [0.8.0] - 15.12.2009+# Changelog +## [0.9.0] - 02.01.2020++### Added++- `WithOperation` constraint for Generic Resolvers (#347) thanks @dandoh++### Fixed++- liftEither support in MutResolver (#351)+- selection of `__typename` on object und union objects (#337)+- auto inferece of external types in gql document (#343)++ th will generate field `m (Type m)` if type has an argument+ + e.g for this types and DSL+ + ```hs+ data Type1 = Type1 { ... }+ type Type2 m = SomeType m+ data Type3 m = Type2 { bla :: m Text } deriving ...+ ```++ ```gql+ type Query {+ field1 : Type1!+ field2 : Type2!+ field3 : Type3!+ }+ ``` ++ morpheus generates++ ```hs+ data Query m = Query {+ field1 :: m Type1+ field2 :: m (Type2 m)+ field3 :: m (Type3 m)+ } deriving ...+ ```++ now you can combine multiple gql documents:+ + ```hs+ importDocumentWithNamespace `coreTypes.gql`+ importDocumentWithNamespace `operations.gql`+ ```+ ### Changed +- support of resolver fields `m type` for the fields without arguments++ ```hs+ data Diety m = Deity {+ name :: m Text+ }+ -- is equal to+ data Diety m = Deity {+ name :: () -> m Text+ }+ ```++- template haskell generates `m type` insead of `() -> m type` for fields without argument (#334)++ ```hs+ data Diety m = Deity {+ name :: (Arrow () (m Text)),+ power :: (Arrow () (m (Maybe Text)))+ }+ -- changed to+ data Diety m = Deity {+ name :: m Text,+ power :: m (Maybe Text)+ }+ ```++## [0.8.0] - 15.12.2019++### Changed+ - deprecated: `INPUT_OBJECT`, `OBJECT`, `UNION`, - use `INPUT` instead of `INPUT_OBJECT`@@ -12,7 +89,7 @@ e.g: ```hs- data Character = + data Character = CharacterDeity Deity SomeDeity Deity deriving (GQLType)@@ -283,7 +360,7 @@ compiler output: - ```+ ```json warning: Morpheus Client Warning: {@@ -310,7 +387,7 @@ ## [0.6.2] - 2.11.2019 -## Added+### Added - support of ghc 8.8.1 @@ -323,7 +400,7 @@ - example `API` executable is removed from Production build -## Added+### Added - helper functions: `liftEitherM` , `liftM` @@ -345,7 +422,7 @@ - Parser supports anonymous Operation: `query` , `mutation` , `subscription` for example: - ```+ ```gql mutation { name }
morpheus-graphql.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: edc0f21d61026ad6d50de9239e2f190424c4f7c8968b0908c467f9c487bf4e5b+-- hash: 334690ee72a44b0b477a859d7e0357b805cb23e1fa9e8695d71e7d34df4ecde4 name: morpheus-graphql-version: 0.8.0+version: 0.9.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql@@ -76,6 +76,7 @@ test/Feature/Holistic/parsing/numbers/query.gql test/Feature/Holistic/parsing/singleLineComments/query.gql test/Feature/Holistic/schema.gql+ test/Feature/Holistic/selection/__typename/query.gql test/Feature/Holistic/selection/AliasNameConflict/query.gql test/Feature/Holistic/selection/AliasResolve/query.gql test/Feature/Holistic/selection/AliasUnknownField/query.gql@@ -200,6 +201,7 @@ test/Feature/Holistic/parsing/notNullSpacing/variables.json test/Feature/Holistic/parsing/numbers/response.json test/Feature/Holistic/parsing/singleLineComments/response.json+ test/Feature/Holistic/selection/__typename/response.json test/Feature/Holistic/selection/AliasNameConflict/response.json test/Feature/Holistic/selection/AliasResolve/response.json test/Feature/Holistic/selection/AliasUnknownField/response.json@@ -373,7 +375,6 @@ Data.Morpheus.Types.IO Data.Morpheus.Types.Types Data.Morpheus.Validation.Document.Validation- Data.Morpheus.Validation.Internal.Utils Data.Morpheus.Validation.Internal.Value Data.Morpheus.Validation.Query.Arguments Data.Morpheus.Validation.Query.Fragment
src/Data/Morpheus/Client.hs view
@@ -32,7 +32,7 @@ ( Validation ) import Data.Morpheus.Types.Internal.AST ( GQLQuery- , DataTypeLib+ , Schema ) gql :: QuasiQuoter@@ -59,7 +59,7 @@ defineByDocument :: IO ByteString -> (GQLQuery, String) -> Q [Dec] defineByDocument doc = defineQuery (schemaByDocument doc) -schemaByDocument :: IO ByteString -> IO (Validation DataTypeLib)+schemaByDocument :: IO ByteString -> IO (Validation Schema) schemaByDocument documentGQL = parseFullGQLDocument <$> documentGQL defineByIntrospection :: IO ByteString -> (GQLQuery, String) -> Q [Dec]
src/Data/Morpheus/Document.hs view
@@ -39,7 +39,7 @@ import Data.Morpheus.Schema.SchemaAPI ( defaultTypes ) import Data.Morpheus.Types ( GQLRootResolver ) import Data.Morpheus.Types.Internal.AST- ( DataTypeLib+ ( Schema , createDataTypeLib ) import Data.Morpheus.Types.Internal.Resolving@@ -50,20 +50,20 @@ ( validatePartialDocument ) -parseDSL :: ByteString -> Either String DataTypeLib+parseDSL :: ByteString -> Either String Schema parseDSL doc = case parseGraphQLDocument doc of Failure errors -> Left (show errors) Success { result } -> Right result -parseDocument :: Text -> Validation DataTypeLib+parseDocument :: Text -> Validation Schema parseDocument doc = parseTypes doc >>= validatePartialDocument >>= createDataTypeLib -parseGraphQLDocument :: ByteString -> Validation DataTypeLib+parseGraphQLDocument :: ByteString -> Validation Schema parseGraphQLDocument x = parseDocument (LT.toStrict $ decodeUtf8 x) -parseFullGQLDocument :: ByteString -> Validation DataTypeLib+parseFullGQLDocument :: ByteString -> Validation Schema parseFullGQLDocument = parseGraphQLDocument >=> defaultTypes -- | Generates schema.gql file from 'GQLRootResolver'
src/Data/Morpheus/Execution/Client/Aeson.hs view
@@ -24,7 +24,7 @@ import Language.Haskell.TH import Data.Morpheus.Execution.Internal.Utils- ( nameSpaceTypeString )+ ( nameSpaceType ) -- -- MORPHEUS@@ -33,6 +33,7 @@ , isFieldNullable , ConsD(..) , TypeD(..)+ , Key ) import Data.Morpheus.Types.Internal.TH ( destructRecord@@ -48,22 +49,22 @@ name (aesonObject tNamespace) cons- where name = nameSpaceTypeString tNamespace tName+ where name = nameSpaceType tNamespace tName deriveFromJSON typeD@TypeD { tName, tCons, tNamespace } | isEnum tCons = defineFromJSON name aesonEnum tCons | otherwise = defineFromJSON name (aesonUnionObject tNamespace) typeD- where name = nameSpaceTypeString tNamespace tName+ where name = nameSpaceType tNamespace tName -aesonObject :: [String] -> ConsD -> ExpQ+aesonObject :: [Key] -> ConsD -> ExpQ aesonObject tNamespace con@ConsD { cName } = appE [|withObject name|] (lamE [varP (mkName "o")] (aesonObjectBody tNamespace con))- where name = nameSpaceTypeString tNamespace cName+ where name = unpack $ nameSpaceType tNamespace cName -aesonObjectBody :: [String] -> ConsD -> ExpQ+aesonObjectBody :: [Key] -> ConsD -> ExpQ aesonObjectBody namespace ConsD { cName, cFields } = handleFields cFields where- consName = mkName $ nameSpaceTypeString namespace cName+ consName = mkName $ unpack $ nameSpaceType namespace cName ------------------------------------------ handleFields [] = fail "No Empty Object" handleFields fields = startExp fields@@ -83,14 +84,14 @@ applyFields (x : xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs) -aesonUnionObject :: [String] -> TypeD -> ExpQ+aesonUnionObject :: [Key] -> TypeD -> ExpQ aesonUnionObject namespace TypeD { tCons } = appE (varE 'takeValueType) (lamCaseE (map buildMatch tCons <> [elseCaseEXP])) where buildMatch cons@ConsD { cName } = match objectPattern body [] where- objectPattern = tupP [litP (stringL cName), varP $ mkName "o"]+ objectPattern = tupP [litP (stringL $ unpack cName), varP $ mkName "o"] body = normalB $ aesonObjectBody namespace cons takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a@@ -101,7 +102,7 @@ fail $ "key \"__typename\" should be string but found: " <> show val takeValueType _ _ = fail "expected Object" -defineFromJSON :: String -> (t -> ExpQ) -> t -> DecQ+defineFromJSON :: Key -> (t -> ExpQ) -> t -> DecQ defineFromJSON tName parseJ cFields = instanceD (cxt []) iHead [method] where iHead = instanceHeadT ''FromJSON tName []@@ -119,8 +120,8 @@ where buildMatch ConsD { cName } = match enumPat body [] where- enumPat = litP $ stringL cName- body = normalB $ appE (varE 'pure) (conE $ mkName cName)+ enumPat = litP $ stringL $ unpack cName+ body = normalB $ appE (varE 'pure) (conE $ mkName $ unpack cName) elseCaseEXP :: MatchQ elseCaseEXP = match (varP varName) body []@@ -146,9 +147,9 @@ methods = [funD 'toJSON [clause argsE (normalB body) []]] where argsE = [destructRecord tName varNames]- body = appE (varE 'object) (listE $ map decodeVar varNames)+ body = appE (varE 'object) (listE $ map (decodeVar . unpack) varNames) decodeVar name = [|name .= $(varName)|] where varName = varE $ mkName name- varNames = map (unpack . fieldName) cFields+ varNames = map fieldName cFields deriveToJSON TypeD { tName, tCons } | isEnum tCons = pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) []
src/Data/Morpheus/Execution/Client/Build.hs view
@@ -11,6 +11,7 @@ import Data.Semigroup ( (<>) ) import Language.Haskell.TH+import Data.Text ( unpack ) -- -- MORPHEUS@@ -32,7 +33,7 @@ import Data.Morpheus.Types.Internal.AST ( GQLQuery(..) , DataTypeKind(..)- , DataTypeLib+ , Schema , isOutputObject , ClientType(..) , ClientQuery(..)@@ -45,7 +46,7 @@ -defineQuery :: IO (Validation DataTypeLib) -> (GQLQuery, String) -> Q [Dec]+defineQuery :: IO (Validation Schema) -> (GQLQuery, String) -> Q [Dec] defineQuery ioSchema queryRoot = do schema <- runIO ioSchema case schema >>= (`validateWith` queryRoot) of@@ -87,7 +88,7 @@ queryArgumentType :: Maybe TypeD -> (Type, Q [Dec]) queryArgumentType Nothing = (ConT $ mkName "()", pure []) queryArgumentType (Just rootType@TypeD { tName }) =- (ConT $ mkName tName, declareInputType rootType)+ (ConT $ mkName $ unpack tName, declareInputType rootType) defineOperationType :: (Type, Q [Dec]) -> String -> ClientType -> Q [Dec] defineOperationType (argType, argumentTypes) query ClientType { clientType } =
src/Data/Morpheus/Execution/Client/Compile.hs view
@@ -32,15 +32,14 @@ import Data.Morpheus.Types.Internal.AST ( GQLQuery(..)- , DataTypeLib+ , Schema , ClientQuery(..)+ , VALIDATION_MODE(..) ) import Data.Morpheus.Types.Internal.Resolving ( Validation , Result(..) )-import Data.Morpheus.Validation.Internal.Utils- ( VALIDATION_MODE(..) ) import Data.Morpheus.Validation.Query.Validation ( validateRequest ) @@ -55,7 +54,7 @@ , variables = Nothing } -validateWith :: DataTypeLib -> (GQLQuery, String) -> Validation ClientQuery+validateWith :: Schema -> (GQLQuery, String) -> Validation ClientQuery validateWith schema (rawRequest@GQLQuery { operation }, queryText) = do validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest (queryArgsType, queryTypes) <- operationTypes
src/Data/Morpheus/Execution/Client/Fetch.hs view
@@ -18,7 +18,10 @@ , encode ) import Data.ByteString.Lazy ( ByteString )-import Data.Text ( pack )+import Data.Text ( pack+ , unpack+ , Text+ ) import Language.Haskell.TH @@ -44,24 +47,25 @@ __fetch :: (Monad m, Show a, ToJSON (Args a), FromJSON a) => String- -> String+ -> Text -> (ByteString -> m ByteString) -> Args a -> m (Either String a) __fetch strQuery opName trans vars = (eitherDecode >=> processResponse) <$> trans (encode gqlReq) where- gqlReq = GQLRequest {operationName = Just (pack opName), query = pack strQuery, variables = fixVars (toJSON vars)}+ gqlReq = GQLRequest {operationName = Just opName, query = pack strQuery, variables = fixVars (toJSON vars)} ------------------------------------------------------------- processResponse JSONResponse {responseData = Just x} = Right x processResponse invalidResponse = Left (show invalidResponse) fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either String a) -deriveFetch :: Type -> String -> String -> Q [Dec]++deriveFetch :: Type -> Text -> String -> Q [Dec] deriveFetch resultType typeName queryString = pure <$> instanceD (cxt []) iHead methods where iHead = instanceHeadT ''Fetch typeName [] methods = [ funD 'fetch [clause [] (normalB [|__fetch queryString typeName|]) []]- , pure $ typeInstanceDec ''Args (ConT $ mkName typeName) resultType+ , pure $ typeInstanceDec ''Args (ConT $ mkName $ unpack typeName) resultType ]
src/Data/Morpheus/Execution/Client/Selection.hs view
@@ -14,7 +14,6 @@ import Data.Semigroup ( (<>) ) import Data.Text ( Text , pack- , unpack ) -- -- MORPHEUS@@ -39,18 +38,18 @@ , DataTypeContent(..) , DataType(..) , DataTypeKind(..)- , DataTypeLib(..)+ , Schema(..) , Key , TypeRef(..) , DataEnumValue(..)- , allDataTypes- , lookupType+ , DataLookup(..) , ConsD(..) , ClientType(..) , TypeD(..) , lookupDeprecated , lookupDeprecatedReason , RAW+ , Name ) import Data.Morpheus.Types.Internal.Resolving ( GQLErrors@@ -73,7 +72,7 @@ globalErrorMessage $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" operationTypes- :: DataTypeLib+ :: Schema -> VariableDefinitions -> ValidOperation -> Validation (Maybe TypeD, [ClientType])@@ -104,12 +103,9 @@ where rootArgumentsType :: TypeD rootArgumentsType = TypeD- { tName = unpack argsName+ { tName = argsName , tNamespace = []- , tCons = [ ConsD { cName = unpack argsName- , cFields = map fieldD variables- }- ]+ , tCons = [ConsD { cName = argsName, cFields = map fieldD variables }] , tMeta = Nothing } where@@ -124,17 +120,17 @@ --------------------------------------------------------- -- generates selection Object Types genRecordType- :: [Key]- -> Key+ :: [Name]+ -> Name -> DataType -> ValidSelectionSet- -> Validation ([ClientType], [Text])- genRecordType path name dataType recordSelSet = do- (con, subTypes, requests) <- genConsD (unpack name) dataType recordSelSet+ -> Validation ([ClientType], [Name])+ genRecordType path tName dataType recordSelSet = do+ (con, subTypes, requests) <- genConsD tName dataType recordSelSet pure ( ClientType { clientType = TypeD { tName- , tNamespace = map unpack path+ , tNamespace = path , tCons = [con] , tMeta = Nothing }@@ -144,9 +140,8 @@ , requests ) where- tName = unpack name genConsD- :: String+ :: Name -> DataType -> ValidSelectionSet -> Validation (ConsD, [ClientType], [Text])@@ -194,8 +189,8 @@ unzip3 <$> mapM getUnionType unionSelections pure ( ClientType- { clientType = TypeD { tNamespace = map unpack fieldPath- , tName = unpack $ typeFrom [] dType+ { clientType = TypeD { tNamespace = fieldPath+ , tName = typeFrom [] dType , tCons , tMeta = Nothing }@@ -207,9 +202,9 @@ where getUnionType (selectedTyName, selectionVariant) = do conDatatype <- getType lib selectedTyName- genConsD (unpack selectedTyName) conDatatype selectionVariant+ genConsD selectedTyName conDatatype selectionVariant -scanInputTypes :: DataTypeLib -> Key -> LibUpdater [Key]+scanInputTypes :: Schema -> Key -> LibUpdater [Key] scanInputTypes lib name collected | name `elem` collected = pure collected | otherwise = getType lib name >>= scanInpType where@@ -225,7 +220,7 @@ scanType (DataEnum _) = pure (collected <> [typeName]) scanType _ = pure collected -buildInputType :: DataTypeLib -> Text -> Validation [ClientType]+buildInputType :: Schema -> Text -> Validation [ClientType] buildInputType lib name = getType lib name >>= generateTypes where generateTypes DataType { typeName, typeContent } = subTypes typeContent@@ -234,13 +229,15 @@ fields <- traverse toFieldD inputFields pure [ ClientType- { clientType =- TypeD- { tName = unpack typeName- , tNamespace = []- , tCons = [ConsD { cName = unpack typeName, cFields = fields }]- , tMeta = Nothing- }+ { clientType = TypeD+ { tName = typeName+ , tNamespace = []+ , tCons = [ ConsD { cName = typeName+ , cFields = fields+ }+ ]+ , tMeta = Nothing+ } , clientKind = KindInputObject } ]@@ -251,7 +248,7 @@ pure $ field { fieldType = fieldType { typeConName } } subTypes (DataEnum enumTags) = pure [ ClientType- { clientType = TypeD { tName = unpack typeName+ { clientType = TypeD { tName = typeName , tNamespace = [] , tCons = map enumOption enumTags , tMeta = Nothing@@ -261,19 +258,19 @@ ] where enumOption DataEnumValue { enumName } =- ConsD { cName = unpack enumName, cFields = [] }+ ConsD { cName = enumName, cFields = [] } subTypes _ = pure [] lookupFieldType- :: DataTypeLib+ :: Schema -> [Key] -> DataType -> Position -> Text -> Validation (DataType, TypeRef)-lookupFieldType lib path DataType { typeContent = DataObject typeContent, typeName } refPosition key- = case lookup key typeContent of+lookupFieldType lib path DataType { typeContent = DataObject { objectFields }, typeName } refPosition key+ = case lookup key objectFields of Just DataField { fieldType = alias@TypeRef { typeConName }, fieldMeta } -> checkDeprecated >> (trans <$> getType lib typeConName) where@@ -291,7 +288,7 @@ ------------------ Nothing -> failure- (compileError $ "cant find field \"" <> pack (show typeContent) <> "\"")+ (compileError $ "cant find field \"" <> pack (show objectFields) <> "\"") lookupFieldType _ _ dt _ _ = failure (compileError $ "Type should be output Object \"" <> pack (show dt)) @@ -304,11 +301,10 @@ fromKind DataScalar{} = pure ([], []) fromKind _ = failure $ compileError "Invalid schema Expected scalar" -getType :: DataTypeLib -> Text -> Validation DataType-getType lib typename =- lookupType (compileError typename) (allDataTypes lib) typename+getType :: Schema -> Text -> Validation DataType+getType lib typename = lookupResult (compileError typename) typename lib -typeFromScalar :: Text -> Text+typeFromScalar :: Name -> Name typeFromScalar "Boolean" = "Bool" typeFromScalar "Int" = "Int" typeFromScalar "Float" = "Float"@@ -316,10 +312,10 @@ typeFromScalar "ID" = "ID" typeFromScalar _ = "ScalarValue" -typeFrom :: [Key] -> DataType -> Text+typeFrom :: [Name] -> DataType -> Name typeFrom path DataType { typeName, typeContent } = __typeFrom typeContent where __typeFrom DataScalar{} = typeFromScalar typeName- __typeFrom DataObject{} = pack $ nameSpaceType path typeName- __typeFrom DataUnion{} = pack $ nameSpaceType path typeName+ __typeFrom DataObject{} = nameSpaceType path typeName+ __typeFrom DataUnion{} = nameSpaceType path typeName __typeFrom _ = typeName
src/Data/Morpheus/Execution/Document/Compile.hs view
@@ -19,7 +19,7 @@ , gqlWarnings ) import Data.Morpheus.Execution.Document.Convert- ( renderTHTypes )+ ( toTHDefinitions ) import Data.Morpheus.Execution.Document.Declare ( declareTypes ) import Data.Morpheus.Parsing.Document.Parser@@ -54,8 +54,7 @@ case parseTypes (T.pack documentTXT) >>= validatePartialDocument- >>= renderTHTypes namespace of Failure errors -> fail (renderGQLErrors errors) Success { result = schema, warnings } ->- gqlWarnings warnings >> declareTypes namespace schema+ gqlWarnings warnings >> toTHDefinitions namespace schema >>= declareTypes namespace
src/Data/Morpheus/Execution/Document/Convert.hs view
@@ -3,110 +3,93 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} module Data.Morpheus.Execution.Document.Convert- ( renderTHTypes+ ( toTHDefinitions ) where import Data.Semigroup ( (<>) )-import Data.Text ( Text- , pack- , unpack- )+import Data.Text (unpack)+import Language.Haskell.TH --- -- MORPHEUS-import Data.Morpheus.Error.Internal ( internalError )+import Data.Morpheus.Types.Internal.TH (infoTyVars) import Data.Morpheus.Execution.Internal.Utils ( capital ) import Data.Morpheus.Types.Internal.AST- ( ArgsType(..)- , DataField(..)+ ( DataField(..) , DataTypeContent(..) , DataType(..) , DataTypeKind(..) , OperationType(..)- , ResolverKind(..) , TypeRef(..) , DataEnumValue(..) , sysTypes , ConsD(..) , GQLTypeD(..) , TypeD(..)+ , Key+ , DataObject )-import Data.Morpheus.Types.Internal.Resolving- ( Validation ) -renderTHTypes :: Bool -> [(Text, DataType)] -> Validation [GQLTypeD]-renderTHTypes namespace lib = traverse renderTHType lib++m_ :: Key+m_ = "m"++getTypeArgs :: Key -> [(Key, DataType)] -> Q (Maybe Key)+getTypeArgs "__TypeKind" _ = pure Nothing+getTypeArgs "Boolean" _ = pure Nothing+getTypeArgs "String" _ = pure Nothing+getTypeArgs "Int" _ = pure Nothing+getTypeArgs "Float" _ = pure Nothing+getTypeArgs key lib = case typeContent <$> lookup key lib of+ Just x -> pure (kindToTyArgs x)+ Nothing -> getTyArgs <$> reify (mkName $ unpack key)++getTyArgs :: Info -> Maybe Key+getTyArgs x + | length (infoTyVars x) > 0 = Just m_ + | otherwise = Nothing+++kindToTyArgs :: DataTypeContent -> Maybe Key+kindToTyArgs DataObject{} = Just m_+kindToTyArgs DataUnion{} = Just m_+kindToTyArgs _ = Nothing++toTHDefinitions :: Bool -> [(Key, DataType)] -> Q [GQLTypeD]+toTHDefinitions namespace lib = traverse renderTHType lib where- renderTHType :: (Text, DataType) -> Validation GQLTypeD+ renderTHType :: (Key, DataType) -> Q GQLTypeD renderTHType (tyConName, x) = generateType x where- genArgsTypeName fieldName | namespace = sysName tyConName <> argTName+ genArgsTypeName :: Key -> Key+ genArgsTypeName fieldName | namespace = hsTypeName tyConName <> argTName | otherwise = argTName where argTName = capital fieldName <> "Args"- genArgumentType :: (Text, DataField) -> Validation [TypeD]- genArgumentType (_ , DataField { fieldArgs = [] }) = pure []- genArgumentType (fieldName, DataField { fieldArgs } ) = pure- [ TypeD- { tName- , tNamespace = []- , tCons = [ ConsD { cName = sysName $ pack tName- , cFields = map genField fieldArgs- }- ]- , tMeta = Nothing- }- ]- where tName = genArgsTypeName $ sysName fieldName- -------------------------------------------- genFieldTypeName = genTypeName- ------------------------------- --genTypeName :: Text -> Text- genTypeName "String" = "Text"- genTypeName "Boolean" = "Bool"- genTypeName name | name `elem` sysTypes = "S" <> name- genTypeName name = name- ----------------------------------------- sysName = unpack . genTypeName ---------------------------------------------------------------------------------------------- genField :: (Text, DataField) -> DataField- genField (_, field@DataField { fieldType = alias@TypeRef { typeConName } })- = field { fieldType = alias { typeConName = genFieldTypeName typeConName }- }- ---------------------------------------------------------------------------------------------- genResField :: (Text, DataField) -> DataField- genResField (_, field@DataField { fieldName, fieldArgs, fieldType = alias@TypeRef { typeConName } })- = field { fieldType = alias { typeConName = ftName, typeArgs }- , fieldArgsType+ genResField :: (Key, DataField) -> Q DataField+ genResField (_, field@DataField { fieldName, fieldArgs, fieldType = typeRef@TypeRef { typeConName } })+ = do + typeArgs <- getTypeArgs typeConName lib + pure $ field { + fieldType = typeRef { typeConName = hsTypeName typeConName, typeArgs }+ , fieldArgsType } where- ftName = genFieldTypeName typeConName- ---------------------------------------- typeArgs = case typeContent <$> lookup typeConName lib of- Just DataObject{} -> Just "m"- Just DataUnion{} -> Just "m"- _ -> Nothing- ------------------------------------ fieldArgsType = Just- $ ArgsType { argsTypeName, resKind = getFieldType ftName }- where- argsTypeName | null fieldArgs = "()"- | otherwise = pack $ genArgsTypeName $ unpack fieldName- --------------------------------------- getFieldType key = case typeContent <$> lookup key lib of- Nothing -> ExternalResolver- Just DataObject{} -> TypeVarResolver- Just DataUnion{} -> TypeVarResolver- Just _ -> PlainResolver+ fieldArgsType+ | null fieldArgs = Nothing+ | otherwise = Just (genArgsTypeName fieldName) --------------------------------------------+ generateType :: DataType -> Q GQLTypeD generateType dt@DataType { typeName, typeContent, typeMeta } = genType typeContent where+ genType :: DataTypeContent -> Q GQLTypeD genType (DataEnum tags) = pure GQLTypeD- { typeD = TypeD { tName = sysName typeName+ { typeD = TypeD { tName = hsTypeName typeName , tNamespace = [] , tCons = map enumOption tags , tMeta = typeMeta@@ -117,17 +100,17 @@ } where enumOption DataEnumValue { enumName } =- ConsD { cName = sysName enumName, cFields = [] }- genType (DataScalar _) =- internalError "Scalar Types should defined By Native Haskell Types"- genType (DataInputUnion _) = internalError "Input Unions not Supported"+ ConsD { cName = hsTypeName enumName, cFields = [] }+ genType DataScalar {} = fail "Scalar Types should defined By Native Haskell Types"+ genType DataInputUnion {} = fail "Input Unions not Supported"+ genType DataInterface {} = fail "interfaces must be eliminated in Validation" genType (DataInputObject fields) = pure GQLTypeD { typeD = TypeD- { tName = sysName typeName+ { tName = hsTypeName typeName , tNamespace = []- , tCons = [ ConsD { cName = sysName typeName- , cFields = map genField fields+ , tCons = [ ConsD { cName = hsTypeName typeName+ , cFields = genInputFields fields } ] , tMeta = typeMeta@@ -136,19 +119,19 @@ , typeArgD = [] , typeOriginal = (typeName, dt) }- genType (DataObject fields) = do- typeArgD <- concat <$> traverse genArgumentType fields+ genType DataObject {objectFields} = do+ typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) objectFields+ cFields <- traverse genResField objectFields pure GQLTypeD- { typeD =- TypeD- { tName = sysName typeName- , tNamespace = []- , tCons = [ ConsD { cName = sysName typeName- , cFields = map genResField fields- }- ]- , tMeta = typeMeta- }+ { typeD = TypeD+ { tName = hsTypeName typeName+ , tNamespace = []+ , tCons = [ ConsD { cName = hsTypeName typeName+ , cFields + }+ ]+ , tMeta = typeMeta+ } , typeKindD = if typeName == "Subscription" then KindObject (Just Subscription) else KindObject Nothing@@ -158,7 +141,7 @@ genType (DataUnion members) = do let tCons = map unionCon members pure GQLTypeD- { typeD = TypeD { tName = unpack typeName+ { typeD = TypeD { tName = typeName , tNamespace = [] , tCons , tMeta = typeMeta@@ -171,9 +154,9 @@ unionCon memberName = ConsD { cName , cFields = [ DataField- { fieldName = pack $ "un" <> cName- , fieldType = TypeRef { typeConName = pack utName- , typeArgs = Just "m"+ { fieldName = "un" <> cName+ , fieldType = TypeRef { typeConName = utName+ , typeArgs = Just m_ , typeWrappers = [] } , fieldMeta = Nothing@@ -183,5 +166,36 @@ ] } where- cName = sysName typeName <> utName- utName = sysName memberName+ cName = hsTypeName typeName <> utName+ utName = hsTypeName memberName++++hsTypeName :: Key -> Key+hsTypeName "String" = "Text"+hsTypeName "Boolean" = "Bool"+hsTypeName name | name `elem` sysTypes = "S" <> name+hsTypeName name = name++genArgumentType :: (Key -> Key) -> (Key, DataField) -> Q [TypeD]+genArgumentType _ (_, DataField { fieldArgs = [] }) = pure []+genArgumentType namespaceWith (fieldName, DataField { fieldArgs }) = pure+ [ TypeD+ { tName+ , tNamespace = []+ , tCons = [ ConsD { cName = hsTypeName tName+ , cFields = genInputFields fieldArgs+ }+ ]+ , tMeta = Nothing+ }+ ]+ where tName = namespaceWith (hsTypeName fieldName)+++genInputFields :: DataObject -> [DataField]+genInputFields = map (genField . snd)+ where+ genField :: DataField -> DataField+ genField field@DataField { fieldType = tyRef@TypeRef { typeConName } } =+ field { fieldType = tyRef { typeConName = hsTypeName typeConName } }
src/Data/Morpheus/Execution/Document/Declare.hs view
@@ -10,7 +10,7 @@ import Data.Semigroup ( (<>) ) import Language.Haskell.TH ---+ -- MORPHEUS import Data.Morpheus.Execution.Document.Decode ( deriveDecode )
src/Data/Morpheus/Execution/Document/Encode.hs view
@@ -28,11 +28,12 @@ , ConsD(..) , GQLTypeD(..) , TypeD(..)+ , Key ) import Data.Morpheus.Types.Internal.Resolving ( Resolver , MapStrategy(..)- , LiftEither+ , LiftOperation , ResolvingStrategy , DataResolver(..) )@@ -43,11 +44,25 @@ , typeT ) -encodeVars :: [String]-encodeVars = ["e", "m"] ++m_ :: Key+m_ = "m"++fo_ :: Key+fo_ = "fieldOperationKind"++po_ :: Key+po_ = "parentOparation"++e_ :: Key+e_ = "encodeEvent"++encodeVars :: [Key]+encodeVars = [e_, m_]+ encodeVarsT :: [TypeQ]-encodeVarsT = map (varT . mkName) encodeVars+encodeVarsT = map (varT . mkName . unpack) encodeVars deriveEncode :: GQLTypeD -> Q [Dec] deriveEncode GQLTypeD { typeKindD, typeD = TypeD { tName, tCons = [ConsD { cFields }] } }@@ -55,37 +70,35 @@ where subARgs = conT ''SUBSCRIPTION : encodeVarsT instanceArgs | isSubscription typeKindD = subARgs- | otherwise = map (varT . mkName) ("o" : encodeVars)- mainType = applyT (mkName tName) [mainTypeArg]+ | otherwise = map (varT . mkName . unpack) (po_ : encodeVars)+ mainType = applyT (mkName $ unpack tName) [mainTypeArg] where mainTypeArg | isSubscription typeKindD = applyT ''Resolver subARgs | otherwise = typeT ''Resolver (fo_ : encodeVars) ------------------------------------------------------------------------------------------ fo_ = "fieldOperationKind"- po_ = "o"- --------------------- typeables | isSubscription typeKindD = [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]] | otherwise- = [ iLiftEither ''ResolvingStrategy- , iLiftEither ''Resolver+ = [ iLiftOp fo_ ''ResolvingStrategy+ , iLiftOp fo_ ''Resolver , typeT ''MapStrategy [fo_, po_] , iTypeable fo_ , iTypeable po_ ] -------------------------- iLiftEither name = applyT ''LiftEither [varT $ mkName fo_, conT name]+ iLiftOp op name =+ applyT ''LiftOperation [varT $ mkName $ unpack op, conT name] ------------------------- iTypeable name = typeT ''Typeable [name] ------------------------------------------- -- defines Constraint: (Typeable m, Monad m) constrains = typeables- <> [ typeT ''Monad ["m"]+ <> [ typeT ''Monad [m_] , applyT ''Encode (mainType : instanceArgs)- , iTypeable "e"- , iTypeable "m"+ , iTypeable e_+ , iTypeable m_ ] ------------------------------------------------------------------- -- defines: instance <constraint> => ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value) where@@ -97,8 +110,8 @@ methods = [funD 'exploreResolvers [clause argsE (normalB body) []]] where argsE = [varP (mkName "_"), destructRecord tName varNames]- body = appE (conE 'ObjectRes) (listE $ map decodeVar varNames)+ body = appE (conE 'ObjectRes) (listE $ map (decodeVar . unpack) varNames) decodeVar name = [| (name, encode $(varName))|] where varName = varE $ mkName name- varNames = map (unpack . fieldName) cFields+ varNames = map fieldName cFields deriveEncode _ = pure []
src/Data/Morpheus/Execution/Document/GQLType.hs view
@@ -34,6 +34,7 @@ , isSchemaTypeName , GQLTypeD(..) , TypeD(..)+ , Key ) import Data.Morpheus.Types.Internal.TH ( instanceHeadT@@ -43,9 +44,11 @@ ) import Data.Typeable ( Typeable ) -genTypeName :: String -> String-genTypeName ('S' : name) | isSchemaTypeName (pack name) = name-genTypeName name = name+genTypeName :: Key -> Key+genTypeName = pack . __genTypeName . unpack+ where+ __genTypeName ('S' : name) | isSchemaTypeName (pack name) = name+ __genTypeName name = name deriveGQLType :: GQLTypeD -> Q [Dec] deriveGQLType GQLTypeD { typeD = TypeD { tName, tMeta }, typeKindD } =@@ -53,18 +56,16 @@ where functions = map instanceProxyFunD- [ ('__typeName , [|pack (genTypeName tName)|])- , ('description, descriptionValue)- ]+ [('__typeName, [|genTypeName tName|]), ('description, descriptionValue)] where descriptionValue = case tMeta >>= metaDescription of- Nothing -> [| Nothing |]- Just x -> [| Just (pack desc)|] where desc = unpack x+ Nothing -> [| Nothing |]+ Just desc -> [| Just desc |] ------------------------------------------------- typeArgs = tyConArgs typeKindD ---------------------------------------------- iHead = instanceHeadT ''GQLType tName typeArgs- headSig = typeT (mkName tName) typeArgs+ headSig = typeT (mkName $ unpack tName) typeArgs ----------------------------------------------- constrains = map conTypeable typeArgs where conTypeable name = typeT ''Typeable [name]
src/Data/Morpheus/Execution/Document/Introspect.hs view
@@ -15,9 +15,9 @@ -- MORPHEUS import Data.Morpheus.Execution.Internal.Declare (tyConArgs)-import Data.Morpheus.Execution.Server.Introspect (Introspect (..), objectFields, IntrospectRep (..),TypeScope(..))+import Data.Morpheus.Execution.Server.Introspect (Introspect (..), introspectObjectFields, IntrospectRep (..),TypeScope(..)) import Data.Morpheus.Types.GQLType (GQLType (__typeName), TRUE)-import Data.Morpheus.Types.Internal.AST (ConsD (..), TypeD (..), ArgsType (..),Key, DataType(..), DataTypeContent(..), DataField (..),insertType,DataTypeKind(..), TypeRef (..))+import Data.Morpheus.Types.Internal.AST (ConsD (..), TypeD (..), Key, DataType(..), DataTypeContent(..), DataField (..),insertType,DataTypeKind(..), TypeRef (..)) import Data.Morpheus.Types.Internal.TH (instanceFunD, instanceProxyFunD,instanceHeadT, instanceHeadMultiT, typeT) @@ -33,7 +33,7 @@ }) = pure <$> instanceD (cxt []) iHead [defineIntrospect] where ------------------------------------------------ iHead = instanceHeadT ''Introspect (unpack name) []+ iHead = instanceHeadT ''Introspect name [] defineIntrospect = instanceProxyFunD ('introspect,body) where body =[| insertType (name,DataType {@@ -49,7 +49,7 @@ deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, tKind) = pure <$> instanceD (cxt constrains) iHead methods where- mainTypeName = typeT (mkName tName) typeArgs+ mainTypeName = typeT (mkName $ unpack tName) typeArgs typeArgs = concatMap tyConArgs (maybeToList tKind) constrains = map conTypeable typeArgs where@@ -60,18 +60,17 @@ where body | tKind == Just KindInputObject || null tKind = [| (DataInputObject $(buildFields cFields), concat $(buildTypes cFields))|]- | otherwise = [| (DataObject $(buildFields cFields), concat $(buildTypes cFields))|]+ | otherwise = [| (DataObject [] $(buildFields cFields), concat $(buildTypes cFields))|] deriveObjectRep _ = pure [] - buildTypes :: [DataField] -> ExpQ buildTypes = listE . concatMap introspectField where introspectField DataField {fieldType, fieldArgsType} = [|[introspect $(proxyT fieldType)]|] : inputTypes fieldArgsType where- inputTypes (Just ArgsType {argsTypeName})- | argsTypeName /= "()" = [[|snd $ objectFields (Proxy :: Proxy TRUE) (argsTypeName, InputType,$(proxyT tAlias))|]]+ inputTypes (Just argsTypeName)+ | argsTypeName /= "()" = [[|snd $ introspectObjectFields (Proxy :: Proxy TRUE) (argsTypeName, InputType,$(proxyT tAlias))|]] where tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing} inputTypes _ = []
src/Data/Morpheus/Execution/Internal/Declare.hs view
@@ -14,9 +14,7 @@ where import Data.Maybe ( maybe )-import Data.Text ( pack- , unpack- )+import Data.Text ( unpack ) import GHC.Generics ( Generic ) import Language.Haskell.TH @@ -26,8 +24,7 @@ , nameSpaceWith ) import Data.Morpheus.Types.Internal.AST- ( ArgsType(..)- , DataField(..)+ ( DataField(..) , DataTypeKind(..) , DataTypeKind(..) , TypeRef(..)@@ -36,15 +33,21 @@ , isSubscription , ConsD(..) , TypeD(..)+ , Key+ , isOutputObject ) import Data.Morpheus.Types.Internal.Resolving ( UnSubResolver ) type Arrow = (->) ++m_ :: Key+m_ = "m"+ declareTypeRef :: Bool -> TypeRef -> Type-declareTypeRef isSub TypeRef { typeConName, typeWrappers, typeArgs } =- wrappedT typeWrappers+declareTypeRef isSub TypeRef { typeConName, typeWrappers, typeArgs } = wrappedT+ typeWrappers where wrappedT :: [TypeWrapper] -> Type wrappedT (TypeList : xs) = AppT (ConT ''[]) $ wrappedT xs@@ -54,12 +57,12 @@ typeName = ConT (mkName $ unpack typeConName) -------------------------------------------- decType _ | isSub =- AppT typeName (AppT (ConT ''UnSubResolver) (VarT $ mkName "m"))+ AppT typeName (AppT (ConT ''UnSubResolver) (VarT $ mkName $ unpack m_)) decType (Just par) = AppT typeName (VarT $ mkName $ unpack par) decType _ = typeName -tyConArgs :: DataTypeKind -> [String]-tyConArgs kindD | isOutputObject kindD || kindD == KindUnion = ["m"]+tyConArgs :: DataTypeKind -> [Key]+tyConArgs kindD | isOutputObject kindD || kindD == KindUnion = [m_] | otherwise = [] -- declareType@@ -68,9 +71,9 @@ DataD [] (genName tName) tVars Nothing (map cons tCons) $ map derive (''Generic : derivingList) where- genName = mkName . nameSpaceType (map pack tNamespace) . pack+ genName = mkName . unpack . nameSpaceType tNamespace tVars = maybe [] (declareTyVar . tyConArgs) kindD- where declareTyVar = map (PlainTV . mkName)+ where declareTyVar = map (PlainTV . mkName . unpack) defBang = Bang NoSourceUnpackedness NoSourceStrictness derive className = DerivClause Nothing [ConT className] cons ConsD { cName, cFields } = RecC (genName cName)@@ -79,23 +82,20 @@ declareField DataField { fieldName, fieldArgsType, fieldType } = (fName, defBang, fiType) where- fName | namespace = mkName (nameSpaceWith tName (unpack fieldName))+ fName | namespace = mkName $ unpack (nameSpaceWith tName fieldName) | otherwise = mkName (unpack fieldName) fiType = genFieldT fieldArgsType where- monadVar = VarT $ mkName "m"+ monadVar = VarT $ mkName $ unpack m_ ---------------------------- genFieldT Nothing = fType False- genFieldT (Just ArgsType { argsTypeName }) = AppT+ genFieldT Nothing+ | (isOutputObject <$> kindD) == Just True = AppT monadVar result+ | otherwise = result+ genFieldT (Just argsTypeName) = AppT (AppT arrowType argType)- (fType True)+ (AppT monadVar result) where argType = ConT $ mkName (unpack argsTypeName) arrowType = ConT ''Arrow- ------------------------------------------------- fType isResolver- | maybe False isSubscription kindD = AppT monadVar result- | isResolver = AppT monadVar result- | otherwise = result ------------------------------------------------ result = declareTypeRef (maybe False isSubscription kindD) fieldType
src/Data/Morpheus/Execution/Internal/Decode.hs view
@@ -41,7 +41,7 @@ decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ decodeObjectExpQ fieldDecoder ConsD { cName, cFields } = handleFields cFields where- consName = conE (mkName cName)+ consName = conE (mkName $ unpack cName) ---------------------------------------------------------------------------------- handleFields fNames = uInfixE consName (varE '(<$>)) (applyFields fNames) where
src/Data/Morpheus/Execution/Internal/Utils.hs view
@@ -3,7 +3,6 @@ , nonCapital , nameSpaceWith , nameSpaceType- , nameSpaceTypeString ) where @@ -13,22 +12,26 @@ import Data.Semigroup ( (<>) ) import Data.Text ( Text , unpack+ , pack )+import qualified Data.Text as T+ ( concat ) -nameSpaceTypeString :: [String] -> String -> String-nameSpaceTypeString list name = concatMap capital (list <> [name])--nameSpaceType :: [Text] -> Text -> String-nameSpaceType list name = concatMap (capital . unpack) (list <> [name])+nameSpaceType :: [Text] -> Text -> Text+nameSpaceType list name = T.concat $ map capital (list <> [name]) -nameSpaceWith :: String -> String -> String+nameSpaceWith :: Text -> Text -> Text nameSpaceWith nSpace name = nonCapital nSpace <> capital name -nonCapital :: String -> String-nonCapital [] = []-nonCapital (x : xs) = toLower x : xs+nonCapital :: Text -> Text+nonCapital = pack . __nonCapital . unpack+ where+ __nonCapital [] = []+ __nonCapital (x : xs) = toLower x : xs -capital :: String -> String-capital [] = []-capital (x : xs) = toUpper x : xs+capital :: Text -> Text+capital = pack . __capital . unpack+ where+ __capital [] = []+ __capital (x : xs) = toUpper x : xs
src/Data/Morpheus/Execution/Server/Encode.hs view
@@ -72,7 +72,7 @@ ) import Data.Morpheus.Types.Internal.Resolving ( MapStrategy(..)- , LiftEither(..)+ , LiftOperation , Resolver(..) , resolving , toResolver@@ -90,11 +90,11 @@ class Encode resolver o e (m :: * -> *) where encode :: resolver -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue -instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m , LiftEither o ResolvingStrategy) => Encode a o e m where+instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m , LiftOperation o ResolvingStrategy) => Encode a o e m where encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a) -- MAYBE-instance (Monad m , LiftEither o ResolvingStrategy,Encode a o e m) => Encode (Maybe a) o e m where+instance (Monad m , LiftOperation o ResolvingStrategy,Encode a o e m) => Encode (Maybe a) o e m where encode = maybe (const $ pure gqlNull) encode -- Tuple (a,b)@@ -106,28 +106,29 @@ encode = encode . S.toList -- Map-instance (Eq k, Monad m,LiftEither o Resolver, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v) o e m where+instance (Eq k, Monad m,LiftOperation o Resolver, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v) o e m where encode value = encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver o e m)) -- LIST []-instance (Monad m, Encode a o e m, LiftEither o ResolvingStrategy) => Encode [a] o e m where+instance (Monad m, Encode a o e m, LiftOperation o ResolvingStrategy) => Encode [a] o e m where encode list query = gqlList <$> traverse (`encode` query) list -- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance (DecodeType a,Generic a, Monad m,LiftEither fo Resolver, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where+instance (DecodeType a,Generic a, Monad m,LiftOperation fo Resolver, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where encode resolver selection@(_, Selection { selectionArguments }) = mapStrategy $ resolving encode (toResolver args resolver) selection where args :: Validation a args = decodeArguments selectionArguments --+-- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY+instance (Monad m,LiftOperation fo Resolver, MapStrategy fo o, Encode b fo e m) => Encode (Resolver fo e m b) o e m where+ encode resolver = mapStrategy . resolving encode resolver -- ENCODE GQL KIND class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where- encodeKind :: LiftEither o ResolvingStrategy => VContext kind a -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue+ encodeKind :: LiftOperation o ResolvingStrategy => VContext kind a -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue -- SCALAR instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where@@ -166,7 +167,7 @@ convertNode- :: (Monad m, LiftEither o ResolvingStrategy)+ :: (Monad m, LiftOperation o ResolvingStrategy) => ResNode o e m -> DataResolver o e m convertNode ResNode { resKind = REP_OBJECT, resFields } =@@ -211,7 +212,7 @@ class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where exploreResolvers :: Proxy custom -> a -> DataResolver o e m -instance (Generic a,Monad m,LiftEither o ResolvingStrategy,TypeRep (Rep a) o e m ) => ExploreResolvers 'False a o e m where+instance (Generic a,Monad m,LiftOperation o ResolvingStrategy,TypeRep (Rep a) o e m ) => ExploreResolvers 'False a o e m where exploreResolvers _ value = convertNode $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value) @@ -244,7 +245,7 @@ encodeOperationWith :: forall o e m a- . (Monad m, EncodeCon o e m a, LiftEither o ResolvingStrategy)+ . (Monad m, EncodeCon o e m a, LiftOperation o ResolvingStrategy) => Maybe (DataResolver o e m) -> EncodeOperator o e m a encodeOperationWith externalRes rootResolver Operation { operationSelection } =
src/Data/Morpheus/Execution/Server/Introspect.hs view
@@ -22,7 +22,7 @@ , IntroCon , updateLib , buildType- , objectFields+ , introspectObjectFields , TypeScope(..) ) where@@ -57,6 +57,7 @@ import Data.Morpheus.Types.Internal.Resolving ( Failure(..) , resolveUpdates+ , Resolver ) import Data.Morpheus.Types.Internal.AST ( Name@@ -134,7 +135,7 @@ field _ name = fieldObj { fieldArgs } where fieldObj = field (Proxy @b) name- fieldArgs = fst $ objectFields+ fieldArgs = fst $ introspectObjectFields (Proxy :: Proxy 'False) (__typeName (Proxy @b), OutputType, Proxy @a) introspect _ typeLib = resolveUpdates typeLib@@ -143,8 +144,15 @@ name = "Arguments for " <> __typeName (Proxy @b) inputs :: [TypeUpdater] inputs =- snd $ objectFields (Proxy :: Proxy 'False) (name, InputType, Proxy @a)+ snd $ introspectObjectFields (Proxy :: Proxy 'False) (name, InputType, Proxy @a) +-- GQL Resolver b, MUTATION, SUBSCRIPTION, QUERY+instance (GQLType b, Introspect b) => Introspect (Resolver fo e m b) where+ isObject _ = False+ field _ = field (Proxy @b)+ introspect _ = introspect (Proxy @b)++ -- | Introspect With specific Kind: 'kind': object, scalar, enum ... class IntrospectKind (kind :: GQL_KIND) a where introspectKind :: Context kind a -> TypeUpdater -- Generates internal GraphQL Schema@@ -183,16 +191,15 @@ type GQL_TYPE a = (Generic a, GQLType a) --objectFields+introspectObjectFields :: IntrospectRep custom a => proxy1 (custom :: Bool) -> (Name, TypeScope, proxy2 a) -> ([(Name, DataField)], [TypeUpdater])-objectFields p1 (name, scope, proxy) = withObject+introspectObjectFields p1 (name, scope, proxy) = withObject (introspectRep p1 (proxy, scope, "", DataFingerprint "" [])) where- withObject (DataObject x, ts) = (x, ts)+ withObject (DataObject {objectFields}, ts) = (objectFields, ts) withObject (DataInputObject x, ts) = (x, ts) withObject _ = ( []@@ -317,7 +324,7 @@ where genericUnion InputType = buildInputUnion (baseName, baseFingerprint) genericUnion OutputType =- buildUnionType (baseName, baseFingerprint) DataUnion DataObject+ buildUnionType (baseName, baseFingerprint) DataUnion (DataObject []) buildInputUnion@@ -362,7 +369,7 @@ buildObject isOutput consFields = (wrap fields, types) where (fields, types) = buildDataObject consFields- wrap | isOutput == OutputType = DataObject+ wrap | isOutput == OutputType = DataObject [] | otherwise = DataInputObject buildDataObject :: [FieldRep] -> (DataObject, [TypeUpdater])
src/Data/Morpheus/Execution/Server/Resolve.hs view
@@ -39,7 +39,7 @@ ) import Data.Morpheus.Execution.Server.Introspect ( IntroCon- , objectFields+ , introspectObjectFields , TypeScope(..) ) import Data.Morpheus.Execution.Subscription.ClientRegister@@ -59,7 +59,7 @@ , ValidOperation , DataFingerprint(..) , DataTypeContent(..)- , DataTypeLib(..)+ , Schema(..) , DataType(..) , MUTATION , OperationType(..)@@ -69,6 +69,7 @@ , ValidValue , Name , DataField+ , VALIDATION_MODE(..) ) import Data.Morpheus.Types.Internal.Resolving ( GQLRootResolver(..)@@ -88,8 +89,6 @@ , GQLResponse(..) , renderResponse )-import Data.Morpheus.Validation.Internal.Utils- ( VALIDATION_MODE(..) ) import Data.Morpheus.Validation.Query.Validation ( validateRequest ) import Data.Typeable ( Typeable )@@ -156,7 +155,7 @@ = validRequest >>= execOperator where validRequest- :: Monad m => ResponseStream event m (DataTypeLib, ValidOperation)+ :: Monad m => ResponseStream event m (Schema, ValidOperation) validRequest = cleanEvents $ ResultT $ pure $ do schema <- fullSchema $ Identity root query <- parseGQL request >>= validateRequest schema FULL_VALIDATION@@ -190,14 +189,14 @@ :: forall proxy m event query mutation subscription . (IntrospectConstraint m event query mutation subscription) => proxy (GQLRootResolver m event query mutation subscription)- -> Validation DataTypeLib+ -> Validation Schema fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema where querySchema = resolveUpdates (initTypeLib (operatorType (hiddenRootFields ++ fields) "Query")) (defaultTypes : types) where- (fields, types) = objectFields+ (fields, types) = introspectObjectFields (Proxy @(CUSTOM (query (Resolver QUERY event m)))) ("type for query", OutputType, Proxy @(query (Resolver QUERY event m))) ------------------------------@@ -205,7 +204,7 @@ (lib { mutation = maybeOperator fields "Mutation" }) types where- (fields, types) = objectFields+ (fields, types) = introspectObjectFields (Proxy @(CUSTOM (mutation (Resolver MUTATION event m)))) ( "type for mutation" , OutputType@@ -216,7 +215,7 @@ (lib { subscription = maybeOperator fields "Subscription" }) types where- (fields, types) = objectFields+ (fields, types) = introspectObjectFields (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION event m)))) ( "type for subscription" , OutputType@@ -229,7 +228,7 @@ operatorType :: [(Name, DataField)] -> Name -> (Name, DataType) operatorType fields typeName = ( typeName- , DataType { typeContent = DataObject fields+ , DataType { typeContent = DataObject [] fields , typeName , typeFingerprint = DataFingerprint typeName [] , typeMeta = Nothing
src/Data/Morpheus/Parsing/Document/Parser.hs view
@@ -20,13 +20,13 @@ import Data.Morpheus.Parsing.Internal.Terms ( spaceAndComments ) import Data.Morpheus.Types.Internal.AST- ( RawDataType )+ ( DataType ) import Data.Morpheus.Types.Internal.Resolving ( Validation , Failure(..) ) -parseTypes :: Text -> Validation [(Text, RawDataType)]+parseTypes :: Text -> Validation [(Text, DataType)] parseTypes doc = case parseDoc of Right root -> pure root Left parseError -> failure (processErrorBundle parseError)
src/Data/Morpheus/Parsing/Document/TypeSystem.hs view
@@ -38,7 +38,6 @@ , DataType(..) , DataValidator(..) , Key- , RawDataType(..) , Meta(..) ) @@ -76,20 +75,20 @@ -- FieldDefinition -- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) ---objectTypeDefinition :: Maybe Text -> Parser (Text, RawDataType)+objectTypeDefinition :: Maybe Text -> Parser (Text, DataType) objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do- implementsName <- typDeclaration "type"- implementsInterfaces <- optionalImplementsInterfaces- metaDirectives <- optionalDirectives- fields <- fieldsDefinition+ typeName <- typDeclaration "type"+ objectImplements <- optionalImplementsInterfaces+ metaDirectives <- optionalDirectives+ objectFields <- fieldsDefinition -------------------------- pure- ( implementsName- , Implements- { implementsName- , implementsInterfaces- , implementsMeta = Just Meta { metaDescription, metaDirectives }- , implementsContent = fields+ ( typeName+ , DataType+ { typeName+ , typeMeta = Just Meta { metaDescription, metaDirectives }+ , typeFingerprint = DataFingerprint typeName []+ , typeContent = DataObject { objectImplements, objectFields } } ) @@ -104,19 +103,21 @@ -- InterfaceTypeDefinition -- Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) ---interfaceTypeDefinition :: Maybe Text -> Parser (Text, RawDataType)+interfaceTypeDefinition :: Maybe Text -> Parser (Text, DataType) interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do- interfaceName <- typDeclaration "interface"+ typeName <- typDeclaration "interface" metaDirectives <- optionalDirectives fields <- fieldsDefinition pure- ( interfaceName- , Interface { interfaceName- , interfaceMeta = Just Meta { metaDescription, metaDirectives }- , interfaceContent = fields- }+ ( typeName+ , DataType { typeName+ , typeMeta = Just Meta { metaDescription, metaDirectives }+ , typeFingerprint = DataFingerprint typeName []+ , typeContent = DataInterface fields+ } ) + -- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions -- -- UnionTypeDefinition:@@ -198,21 +199,14 @@ parseFinalDataType :: Maybe Text -> Parser (Text, DataType) parseFinalDataType description = label "TypeDefinition"- $ inputObjectTypeDefinition description+ $ inputObjectTypeDefinition description <|> unionTypeDefinition description <|> enumTypeDefinition description <|> scalarTypeDefinition description+ <|> objectTypeDefinition description+ <|> interfaceTypeDefinition description -parseDataType :: Parser (Text, RawDataType)+parseDataType :: Parser (Text, DataType) parseDataType = label "TypeDefinition" $ do description <- optDescription- types description- where- types description =- interfaceTypeDefinition description- <|> objectTypeDefinition description- <|> finalDataT- where- finalDataT = do- (name, datatype) <- parseFinalDataType description- pure (name, FinalDataType datatype)+ parseFinalDataType description
src/Data/Morpheus/Parsing/JSONSchema/Parse.hs view
@@ -21,11 +21,12 @@ , Type(..) ) import Data.Morpheus.Schema.TypeKind ( TypeKind(..) )+import qualified Data.Morpheus.Types.Internal.AST as AST+ ( Schema) import Data.Morpheus.Types.Internal.AST ( DataField , DataType(..) , DataTypeContent(..)- , DataTypeLib , DataTypeWrapper(..) , Key , TypeWrapper@@ -46,7 +47,7 @@ , pack ) -decodeIntrospection :: ByteString -> Validation DataTypeLib+decodeIntrospection :: ByteString -> Validation AST.Schema decodeIntrospection jsonDoc = case jsonSchema of Left errors -> internalError $ pack errors Right JSONResponse { responseData = Just Introspection { __schema = Schema { types } } }@@ -75,7 +76,7 @@ parse Type { name = Just typeName, kind = OBJECT, fields = Just oFields } = do fields <- traverse parse oFields- pure [(typeName, createType typeName $ DataObject fields)]+ pure [(typeName, createType typeName $ DataObject [] fields)] parse _ = pure [] instance ParseJSONSchema Field (Key,DataField) where
src/Data/Morpheus/Rendering/RenderGQL.hs view
@@ -23,7 +23,7 @@ ( DataField(..) , DataTypeContent(..) , DataType(..)- , DataTypeLib+ , Schema , DataTypeWrapper(..) , Key , TypeRef(..)@@ -38,7 +38,7 @@ ) -renderGraphQLDocument :: DataTypeLib -> ByteString+renderGraphQLDocument :: Schema -> ByteString renderGraphQLDocument lib = encodeUtf8 $ LT.fromStrict $ intercalate "\n\n" $ map render visibleTypes where@@ -71,6 +71,7 @@ instance RenderGQL (Key, DataType) where render (name, DataType { typeContent }) = __render typeContent where+ __render DataInterface { interfaceFields } = "interface " <> name <> render interfaceFields __render DataScalar{} = "scalar " <> name __render (DataEnum tags) = "enum " <> name <> renderObject render tags __render (DataUnion members) =@@ -81,7 +82,7 @@ __render (DataInputObject fields ) = "input " <> name <> render fields __render (DataInputUnion members) = "input " <> name <> render fields where fields = createInputUnionFields name (map fst members)- __render (DataObject fields) = "type " <> name <> render fields+ __render (DataObject {objectFields}) = "type " <> name <> render objectFields -- OBJECT instance RenderGQL [(Text, DataField)] where
src/Data/Morpheus/Rendering/RenderIntrospection.hs view
@@ -24,7 +24,7 @@ , DataTypeContent(..) , DataType(..) , DataTypeKind(..)- , DataTypeLib+ , Schema , DataTypeWrapper(..) , DataUnion , Meta(..)@@ -46,14 +46,16 @@ constRes :: Applicative m => a -> b -> m a constRes = const . pure -type Result m a = DataTypeLib -> m a+type Result m a = Schema -> m a class RenderSchema a b where- render :: (Monad m, Failure Text m) => (Text, a) -> DataTypeLib -> m (b m)+ render :: (Monad m, Failure Text m) => (Text, a) -> Schema -> m (b m) instance RenderSchema DataType S__Type where render (name, DataType { typeMeta, typeContent }) = __render typeContent where+ __render+ :: (Monad m, Failure Text m) => DataTypeContent -> Schema -> m (S__Type m) __render DataScalar{} = constRes $ createLeafType SCALAR name typeMeta Nothing __render (DataEnum enums) = constRes@@ -61,9 +63,9 @@ __render (DataInputObject fields) = \lib -> createInputObject name typeMeta <$> traverse (`renderinputValue` lib) fields- __render (DataObject fields) = \lib ->+ __render (DataObject {objectFields}) = \lib -> createObjectType name (typeMeta >>= metaDescription)- <$> (Just <$> traverse (`render` lib) (filter fieldVisibility fields))+ <$> (Just <$> traverse (`render` lib) (filter fieldVisibility objectFields)) __render (DataUnion union) = constRes $ typeFromUnion (name, typeMeta, union) __render (DataInputUnion members) =@@ -71,11 +73,10 @@ createEnumValue :: Monad m => DataEnumValue -> S__EnumValue m createEnumValue DataEnumValue { enumName, enumMeta } = S__EnumValue- { s__EnumValueName = constRes enumName- , s__EnumValueDescription = constRes (enumMeta >>= metaDescription)- , s__EnumValueIsDeprecated = constRes (isJust deprecated)- , s__EnumValueDeprecationReason = constRes- (deprecated >>= lookupDeprecatedReason)+ { s__EnumValueName = pure enumName+ , s__EnumValueDescription = pure (enumMeta >>= metaDescription)+ , s__EnumValueIsDeprecated = pure (isJust deprecated)+ , s__EnumValueDeprecationReason = pure (deprecated >>= lookupDeprecatedReason) } where deprecated = enumMeta >>= lookupDeprecated @@ -85,13 +86,13 @@ kind <- renderTypeKind <$> lookupKind typeConName lib args <- traverse (`renderinputValue` lib) fieldArgs pure S__Field- { s__FieldName = constRes (convertToJSONName name)- , s__FieldDescription = constRes (fieldMeta >>= metaDescription)- , s__FieldArgs = constRes args+ { s__FieldName = pure (convertToJSONName name)+ , s__FieldDescription = pure (fieldMeta >>= metaDescription)+ , s__FieldArgs = pure args , s__FieldType' =- constRes (wrap field $ createType kind typeConName Nothing $ Just [])- , s__FieldIsDeprecated = constRes (isJust deprecated)- , s__FieldDeprecationReason = constRes+ pure (wrap field $ createType kind typeConName Nothing $ Just [])+ , s__FieldIsDeprecated = pure (isJust deprecated)+ , s__FieldDeprecationReason = pure (deprecated >>= lookupDeprecatedReason) } where deprecated = fieldMeta >>= lookupDeprecated@@ -155,58 +156,57 @@ -> Maybe [S__EnumValue m] -> S__Type m createLeafType kind name meta enums = S__Type- { s__TypeKind = constRes kind- , s__TypeName = constRes $ Just name- , s__TypeDescription = constRes (meta >>= metaDescription)+ { s__TypeKind = pure kind+ , s__TypeName = pure $ Just name+ , s__TypeDescription = pure (meta >>= metaDescription) , s__TypeFields = constRes Nothing- , s__TypeOfType = constRes Nothing- , s__TypeInterfaces = constRes Nothing- , s__TypePossibleTypes = constRes Nothing+ , s__TypeOfType = pure Nothing+ , s__TypeInterfaces = pure Nothing+ , s__TypePossibleTypes = pure Nothing , s__TypeEnumValues = constRes enums- , s__TypeInputFields = constRes Nothing+ , s__TypeInputFields = pure Nothing } typeFromUnion :: Monad m => (Text, Maybe Meta, DataUnion) -> S__Type m typeFromUnion (name, typeMeta, typeContent) = S__Type- { s__TypeKind = constRes UNION- , s__TypeName = constRes $ Just name- , s__TypeDescription = constRes (typeMeta >>= metaDescription)+ { s__TypeKind = pure UNION+ , s__TypeName = pure $ Just name+ , s__TypeDescription = pure (typeMeta >>= metaDescription) , s__TypeFields = constRes Nothing- , s__TypeOfType = constRes Nothing- , s__TypeInterfaces = constRes Nothing+ , s__TypeOfType = pure Nothing+ , s__TypeInterfaces = pure Nothing , s__TypePossibleTypes =- constRes- $ Just (map (\x -> createObjectType x Nothing $ Just []) typeContent)+ pure $ Just (map (\x -> createObjectType x Nothing $ Just []) typeContent) , s__TypeEnumValues = constRes Nothing- , s__TypeInputFields = constRes Nothing+ , s__TypeInputFields = pure Nothing } createObjectType :: Monad m => Text -> Maybe Text -> Maybe [S__Field m] -> S__Type m createObjectType name description fields = S__Type- { s__TypeKind = constRes OBJECT- , s__TypeName = constRes $ Just name- , s__TypeDescription = constRes description+ { s__TypeKind = pure OBJECT+ , s__TypeName = pure $ Just name+ , s__TypeDescription = pure description , s__TypeFields = constRes fields- , s__TypeOfType = constRes Nothing- , s__TypeInterfaces = constRes $ Just []- , s__TypePossibleTypes = constRes Nothing+ , s__TypeOfType = pure Nothing+ , s__TypeInterfaces = pure $ Just []+ , s__TypePossibleTypes = pure Nothing , s__TypeEnumValues = constRes Nothing- , s__TypeInputFields = constRes Nothing+ , s__TypeInputFields = pure Nothing } createInputObject :: Monad m => Text -> Maybe Meta -> [S__InputValue m] -> S__Type m createInputObject name meta fields = S__Type- { s__TypeKind = constRes INPUT_OBJECT- , s__TypeName = constRes $ Just name- , s__TypeDescription = constRes (meta >>= metaDescription)+ { s__TypeKind = pure INPUT_OBJECT+ , s__TypeName = pure $ Just name+ , s__TypeDescription = pure (meta >>= metaDescription) , s__TypeFields = constRes Nothing- , s__TypeOfType = constRes Nothing- , s__TypeInterfaces = constRes Nothing- , s__TypePossibleTypes = constRes Nothing+ , s__TypeOfType = pure Nothing+ , s__TypeInterfaces = pure Nothing+ , s__TypePossibleTypes = pure Nothing , s__TypeEnumValues = constRes Nothing- , s__TypeInputFields = constRes $ Just fields+ , s__TypeInputFields = pure $ Just fields } createType@@ -217,34 +217,34 @@ -> Maybe [S__Field m] -> S__Type m createType kind name description fields = S__Type- { s__TypeKind = constRes kind- , s__TypeName = constRes $ Just name- , s__TypeDescription = constRes description+ { s__TypeKind = pure kind+ , s__TypeName = pure $ Just name+ , s__TypeDescription = pure description , s__TypeFields = constRes fields- , s__TypeOfType = constRes Nothing- , s__TypeInterfaces = constRes Nothing- , s__TypePossibleTypes = constRes Nothing+ , s__TypeOfType = pure Nothing+ , s__TypeInterfaces = pure Nothing+ , s__TypePossibleTypes = pure Nothing , s__TypeEnumValues = constRes $ Just []- , s__TypeInputFields = constRes Nothing+ , s__TypeInputFields = pure Nothing } wrapAs :: Monad m => TypeKind -> S__Type m -> S__Type m-wrapAs kind contentType = S__Type { s__TypeKind = constRes kind- , s__TypeName = constRes Nothing- , s__TypeDescription = constRes Nothing+wrapAs kind contentType = S__Type { s__TypeKind = pure kind+ , s__TypeName = pure Nothing+ , s__TypeDescription = pure Nothing , s__TypeFields = constRes Nothing- , s__TypeOfType = constRes $ Just contentType- , s__TypeInterfaces = constRes Nothing- , s__TypePossibleTypes = constRes Nothing+ , s__TypeOfType = pure $ Just contentType+ , s__TypeInterfaces = pure Nothing+ , s__TypePossibleTypes = pure Nothing , s__TypeEnumValues = constRes Nothing- , s__TypeInputFields = constRes Nothing+ , s__TypeInputFields = pure Nothing } createInputValueWith :: Monad m => Text -> Maybe Meta -> S__Type m -> S__InputValue m createInputValueWith name meta ivType = S__InputValue- { s__InputValueName = constRes (convertToJSONName name)- , s__InputValueDescription = constRes (meta >>= metaDescription)- , s__InputValueType' = constRes ivType- , s__InputValueDefaultValue = constRes Nothing+ { s__InputValueName = pure (convertToJSONName name)+ , s__InputValueDescription = pure (meta >>= metaDescription)+ , s__InputValueType' = pure ivType+ , s__InputValueDefaultValue = pure Nothing }
src/Data/Morpheus/Schema/SchemaAPI.hs view
@@ -16,7 +16,7 @@ -- MORPHEUS import Data.Morpheus.Execution.Server.Introspect- ( objectFields+ ( introspectObjectFields , TypeUpdater , introspect , TypeScope(..)@@ -30,12 +30,11 @@ , S__Schema(..) , S__Type )-import Data.Morpheus.Types ( constRes ) import Data.Morpheus.Types.GQLType ( CUSTOM ) import Data.Morpheus.Types.ID ( ID ) import Data.Morpheus.Types.Internal.AST ( DataField(..)- , DataTypeLib(..)+ , Schema(..) , QUERY , DataType , allDataTypes@@ -48,7 +47,7 @@ convertTypes- :: Monad m => DataTypeLib -> Resolver QUERY e m [S__Type (Resolver QUERY e m)]+ :: Monad m => Schema -> Resolver QUERY e m [S__Type (Resolver QUERY e m)] convertTypes lib = traverse (`render` lib) (allDataTypes lib) buildSchemaLinkType@@ -58,7 +57,7 @@ findType :: Monad m => Text- -> DataTypeLib+ -> Schema -> Resolver QUERY e m (Maybe (S__Type (Resolver QUERY e m))) findType name lib = renderT (lookupDataType name lib) where@@ -67,20 +66,18 @@ initSchema :: Monad m- => DataTypeLib+ => Schema -> Resolver QUERY e m (S__Schema (Resolver QUERY e m)) initSchema lib = pure S__Schema- { s__SchemaTypes = const $ convertTypes lib- , s__SchemaQueryType = constRes $ buildSchemaLinkType $ query lib- , s__SchemaMutationType = constRes $ buildSchemaLinkType <$> mutation lib- , s__SchemaSubscriptionType = constRes- $ buildSchemaLinkType- <$> subscription lib- , s__SchemaDirectives = constRes []+ { s__SchemaTypes = convertTypes lib+ , s__SchemaQueryType = pure $ buildSchemaLinkType $ query lib+ , s__SchemaMutationType = pure $ buildSchemaLinkType <$> mutation lib+ , s__SchemaSubscriptionType = pure $ buildSchemaLinkType <$> subscription lib+ , s__SchemaDirectives = pure [] } hiddenRootFields :: [(Text, DataField)]-hiddenRootFields = fst $ objectFields+hiddenRootFields = fst $ introspectObjectFields (Proxy :: Proxy (CUSTOM (Root Maybe))) ("Root", OutputType, Proxy @(Root Maybe)) @@ -95,8 +92,6 @@ , introspect (Proxy @(S__Schema Maybe)) ] -schemaAPI :: Monad m => DataTypeLib -> Root (Resolver QUERY e m)-schemaAPI lib = Root { root__type, root__schema }- where- root__type (Root__typeArgs name) = findType name lib- root__schema _ = initSchema lib+schemaAPI :: Monad m => Schema -> Root (Resolver QUERY e m)+schemaAPI lib = Root { root__type, root__schema = initSchema lib }+ where root__type (Root__typeArgs name) = findType name lib
src/Data/Morpheus/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-} -- | GQL Types module Data.Morpheus.Types ( Event(..)@@ -24,16 +25,21 @@ , QUERY , MUTATION , SUBSCRIPTION- , liftEither , lift+ , liftEither , ResolveQ , ResolveM , ResolveS , failRes+ , WithOperation ) where import Data.Text ( pack )+import Data.Either (either)+import Control.Monad.Trans.Class ( MonadTrans(..) )++-- MORPHEUS import Data.Morpheus.Types.GQLScalar ( GQLScalar ( parseValue , serialize@@ -46,14 +52,16 @@ , QUERY , SUBSCRIPTION , ScalarValue(..)+ , Message ) import Data.Morpheus.Types.Internal.Resolving ( Event(..) , GQLRootResolver(..) , Resolver(..)- , LiftEither(..)+ , WithOperation , lift , failure+ , Failure ) import Data.Morpheus.Types.IO ( GQLRequest(..) , GQLResponse(..)@@ -74,11 +82,14 @@ type ResolveS e m a = SubRes e m (a (Res e m)) -- resolves constant value on any argument-constRes :: (LiftEither o Resolver, Monad m) => b -> a -> Resolver o e m b+constRes :: (WithOperation o, Monad m) => b -> a -> Resolver o e m b constRes = const . pure constMutRes :: Monad m => [e] -> a -> args -> MutRes e m a constMutRes events value = const $ MutResolver $ pure (events, value) -failRes :: (LiftEither o Resolver, Monad m) => String -> Resolver o e m a+failRes :: (WithOperation o, Monad m) => String -> Resolver o e m a failRes = failure . pack++liftEither :: (MonadTrans t, Monad (t m), Failure Message (t m)) => Monad m => m (Either String a) -> t m a+liftEither x = lift x >>= either (failure . pack) pure
src/Data/Morpheus/Types/Internal/AST.hs view
@@ -17,6 +17,7 @@ , RESOLVED , VALID , RAW+ , VALIDATION_MODE(..) -- VALUE , Value(..)@@ -53,7 +54,7 @@ , ValidArguments , RawSelectionRec , ValidSelectionRec-+ , isOutputType -- OPERATION , Operation(..) , Variable(..)@@ -77,16 +78,13 @@ , DataField(..) , DataTypeContent(..) , DataType(..)- , DataTypeLib(..)+ , Schema(..) , DataTypeWrapper(..) , DataValidator(..) , DataTypeKind(..) , DataFingerprint(..)- , RawDataType(..)- , ResolverKind(..) , TypeWrapper(..) , TypeRef(..)- , ArgsType(..) , DataEnumValue(..) , isTypeDefined , initTypeLib@@ -116,10 +114,7 @@ , isEntNode , lookupInputType , coerceDataObject- , getDataType- , lookupDataObject , lookupDataUnion- , lookupType , lookupField , lookupUnionTypes , lookupSelectionField@@ -148,6 +143,9 @@ , ClientType(..) , DataInputUnion , VariableContent(..)+ , checkForUnknownKeys+ , checkNameCollision+ , DataLookup(..) -- LOCAL , GQLQuery(..) , Variables
src/Data/Morpheus/Types/Internal/AST/Base.hs view
@@ -19,6 +19,9 @@ , Stage(..) , RESOLVED , TypeRef(..)+ , removeDuplicates+ , elementOfKeys+ , VALIDATION_MODE(..) ) where @@ -29,6 +32,7 @@ import GHC.Generics ( Generic ) import Language.Haskell.TH.Syntax ( Lift ) import Instances.TH.Lift ( )+import qualified Data.Set as S type Key = Text@@ -41,11 +45,11 @@ data Stage = RAW | RESOLVED | VALID -type VALID = 'RAW+type RAW = 'RAW type RESOLVED = 'RESOLVED -type RAW = 'VALID+type VALID = 'VALID data Position = Position { line :: Int@@ -80,3 +84,17 @@ , typeArgs :: Maybe Name , typeWrappers :: [TypeWrapper] } deriving (Show,Lift)+++data VALIDATION_MODE+ = WITHOUT_VARIABLES+ | FULL_VALIDATION+ deriving (Eq, Show)++removeDuplicates :: Ord a => [a] -> [a]+removeDuplicates = S.toList . S.fromList++elementOfKeys :: [Name] -> Ref -> Bool+elementOfKeys keys Ref { refName } = refName `elem` keys++
src/Data/Morpheus/Types/Internal/AST/Data.hs view
@@ -19,16 +19,13 @@ , DataField(..) , DataTypeContent(..) , DataType(..)- , DataTypeLib(..)+ , Schema(..) , DataTypeWrapper(..) , DataValidator(..) , DataTypeKind(..) , DataFingerprint(..)- , RawDataType(..)- , ResolverKind(..) , TypeWrapper(..) , TypeRef(..)- , ArgsType(..) , DataEnumValue(..) , isTypeDefined , initTypeLib@@ -58,10 +55,7 @@ , isEntNode , lookupInputType , coerceDataObject- , getDataType- , lookupDataObject , lookupDataUnion- , lookupType , lookupField , lookupUnionTypes , lookupSelectionField@@ -90,6 +84,10 @@ , ClientType(..) , DataInputUnion , isNullableWrapper+ , isOutputType+ , checkForUnknownKeys+ , checkNameCollision+ , DataLookup(..) ) where @@ -105,7 +103,7 @@ import Data.Semigroup ( (<>) ) import Language.Haskell.TH.Syntax ( Lift ) import Instances.TH.Lift ( )-import Data.List ( find )+import Data.List ( find , (\\)) -- MORPHEUS import Data.Morpheus.Error.Internal ( internalError )@@ -119,6 +117,9 @@ , Description , TypeWrapper(..) , TypeRef(..)+ , Ref(..)+ , elementOfKeys+ , removeDuplicates ) import Data.Morpheus.Types.Internal.Resolving.Core ( Validation@@ -147,6 +148,20 @@ isPrimitiveTypeName :: Key -> Bool isPrimitiveTypeName = (`elem` ["String", "Float", "Int", "Boolean", "ID"]) ++checkNameCollision :: (Failure e m, Ord a) => [a] -> ([a] -> e) -> m [a]+checkNameCollision enhancedKeys errorGenerator =+ case enhancedKeys \\ removeDuplicates enhancedKeys of+ [] -> pure enhancedKeys+ duplicates -> failure $ errorGenerator duplicates++checkForUnknownKeys :: Failure e m => [Ref] -> [Name] -> ([Ref] -> e) -> m [Ref]+checkForUnknownKeys enhancedKeys' keys' errorGenerator' =+ case filter (not . elementOfKeys keys') enhancedKeys' of+ [] -> pure enhancedKeys'+ unknownKeys' -> failure $ errorGenerator' unknownKeys' ++ sysTypes :: [Key] sysTypes = [ "__Schema"@@ -169,6 +184,11 @@ isSubscription (KindObject (Just Subscription)) = True isSubscription _ = False +isOutputType :: DataTypeKind -> Bool+isOutputType (KindObject _) = True+isOutputType KindUnion = True+isOutputType _ = False+ isOutputObject :: DataTypeKind -> Bool isOutputObject (KindObject _) = True isOutputObject _ = False@@ -193,14 +213,6 @@ | KindInputUnion deriving (Eq, Show, Lift) -data ResolverKind- = PlainResolver- | TypeVarResolver- | ExternalResolver- deriving (Show, Eq, Lift)--- isFieldNullable :: DataField -> Bool isFieldNullable = isNullable . fieldType @@ -255,11 +267,6 @@ | NonNullType deriving (Show, Lift) -data ArgsType = ArgsType- { argsTypeName :: Key- , resKind :: ResolverKind- } deriving (Show,Lift)- data Directive = Directive { directiveName :: Name, directiveArgs :: [(Name, ValidValue)]@@ -297,7 +304,7 @@ data DataField = DataField { fieldName :: Key , fieldArgs :: [(Key, DataArgument)]- , fieldArgsType :: Maybe ArgsType+ , fieldArgsType :: Maybe Name , fieldType :: TypeRef , fieldMeta :: Maybe Meta } deriving (Show,Lift)@@ -353,37 +360,9 @@ gqlError where gqlError = cannotQueryField fieldName typeName position ------ TYPE CONSTRUCTOR--------------------------------------------------------------------------------------------------- -data RawDataType- = FinalDataType DataType- | Interface {- interfaceName :: Key- , interfaceMeta :: Maybe Meta- , interfaceContent :: DataObject- }- | Implements {- implementsName :: Key- , implementsInterfaces :: [Key]- , implementsMeta :: Maybe Meta- , implementsContent :: DataObject- }- deriving (Show)---- -- DATA TYPE ---------------------------------------------------------------------------------------------------data DataTypeContent- = DataScalar DataScalar- | DataEnum DataEnum- | DataInputObject DataObject- | DataObject DataObject- | DataUnion DataUnion- | DataInputUnion [(Key,Bool)]- deriving (Show)- data DataType = DataType { typeName :: Key , typeFingerprint :: DataFingerprint@@ -391,6 +370,17 @@ , typeContent :: DataTypeContent } deriving (Show) +data DataTypeContent+ = DataScalar { dataScalar :: DataScalar }+ | DataEnum { enumMembers :: DataEnum }+ | DataInputObject { inputObjectFields :: DataObject }+ | DataObject { objectImplements :: [Name],+ objectFields :: DataObject }+ | DataUnion { unionMembers :: DataUnion }+ | DataInputUnion { inputUnionMembers :: [(Key,Bool)] }+ | DataInterface { interfaceFields :: DataObject }+ deriving (Show)+ createType :: Key -> DataTypeContent -> DataType createType typeName typeContent = DataType { typeName@@ -430,7 +420,7 @@ __isInput _ = False coerceDataObject :: Failure error m => error -> DataType -> m (Name,DataObject)-coerceDataObject _ DataType { typeContent = DataObject object , typeName } = pure (typeName,object)+coerceDataObject _ DataType { typeContent = DataObject { objectFields } , typeName } = pure (typeName, objectFields) coerceDataObject gqlError _ = failure gqlError coerceDataUnion :: Failure error m => error -> DataType -> m DataUnion@@ -440,39 +430,37 @@ kindOf :: DataType -> DataTypeKind kindOf DataType { typeContent } = __kind typeContent where- __kind (DataScalar _) = KindScalar- __kind (DataEnum _) = KindEnum- __kind (DataInputObject _) = KindInputObject- __kind (DataObject _) = KindObject Nothing- __kind (DataUnion _) = KindUnion- __kind (DataInputUnion _) = KindInputUnion-+ __kind DataScalar {} = KindScalar+ __kind DataEnum {} = KindEnum+ __kind DataInputObject {} = KindInputObject+ __kind DataObject {} = KindObject Nothing+ __kind DataUnion {} = KindUnion+ __kind DataInputUnion {} = KindInputUnion -- -- Type Register ---------------------------------------------------------------------------------------------------data DataTypeLib = DataTypeLib- { types :: HashMap Key DataType+data Schema = Schema+ { types :: HashMap Name DataType , query :: (Name,DataType)- , mutation :: Maybe (Name, DataType)- , subscription :: Maybe (Name, DataType)+ , mutation :: Maybe (Name,DataType)+ , subscription :: Maybe (Name,DataType) } deriving (Show) type TypeRegister = HashMap Key DataType -initTypeLib :: (Key, DataType) -> DataTypeLib-initTypeLib query = DataTypeLib { types = empty- , query = query- , mutation = Nothing- , subscription = Nothing- }+initTypeLib :: (Key, DataType) -> Schema+initTypeLib query = Schema { types = empty+ , query = query+ , mutation = Nothing+ , subscription = Nothing+ } -allDataTypes :: DataTypeLib -> [(Key, DataType)]-allDataTypes DataTypeLib { types, query, mutation, subscription } =- concatMap fromOperation [Just query, mutation, subscription] <> toList types+allDataTypes :: Schema -> [(Key, DataType)]+allDataTypes = toList . typeRegister -typeRegister :: DataTypeLib -> TypeRegister-typeRegister DataTypeLib { types, query, mutation, subscription } =+typeRegister :: Schema -> TypeRegister+typeRegister Schema { types, query, mutation, subscription } = types `union` fromList (concatMap fromOperation [Just query, mutation, subscription]) @@ -480,56 +468,59 @@ fromOperation (Just (key, datatype)) = [(key, datatype)] fromOperation Nothing = [] -lookupDataType :: Key -> DataTypeLib -> Maybe DataType-lookupDataType name lib = name `HM.lookup` typeRegister lib -getDataType :: Failure error m => Key -> DataTypeLib -> error -> m DataType-getDataType name lib gqlError = case lookupDataType name lib of- Just x -> pure x- _ -> failure gqlError+class DataLookup l a where + lookupResult :: (Failure e m, Monad m) => e -> Name -> l -> m a -lookupDataObject- :: (Monad m, Failure e m) => e -> Key -> DataTypeLib -> m (Name,DataObject)-lookupDataObject validationError name lib =- getDataType name lib validationError >>= coerceDataObject validationError+instance DataLookup Schema DataType where + lookupResult err name lib = case lookupDataType name lib of+ Nothing -> failure err+ Just x -> pure x +instance DataLookup Schema (Name,DataObject) where + lookupResult validationError name lib =+ lookupResult validationError name lib >>= coerceDataObject validationError+ lookupDataUnion- :: (Monad m, Failure e m) => e -> Key -> DataTypeLib -> m DataUnion+ :: (Monad m, Failure e m) => e -> Key -> Schema -> m DataUnion lookupDataUnion validationError name lib =- getDataType name lib validationError >>= coerceDataUnion validationError+ lookupResult validationError name lib >>= coerceDataUnion validationError +lookupDataType :: Key -> Schema -> Maybe DataType+lookupDataType name = HM.lookup name . typeRegister+ lookupUnionTypes :: (Monad m, Failure GQLErrors m) => Position -> Key- -> DataTypeLib+ -> Schema -> DataField -> m [(Name,DataObject)] lookupUnionTypes position key lib DataField { fieldType = TypeRef { typeConName = typeName } } = lookupDataUnion gqlError typeName lib- >>= mapM (flip (lookupDataObject gqlError) lib)+ >>= mapM (flip (lookupResult gqlError) lib) where gqlError = hasNoSubfields key typeName position lookupFieldAsSelectionSet :: (Monad m, Failure GQLErrors m) => Position -> Key- -> DataTypeLib+ -> Schema -> DataField -> m (Name,DataObject) lookupFieldAsSelectionSet position key lib DataField { fieldType = TypeRef { typeConName } }- = lookupDataObject gqlError typeConName lib+ = lookupResult gqlError typeConName lib where gqlError = hasNoSubfields key typeConName position -lookupInputType :: Failure e m => Key -> DataTypeLib -> e -> m DataType+lookupInputType :: Failure e m => Key -> Schema -> e -> m DataType lookupInputType name lib errors = case lookupDataType name lib of Just x | isInputDataType x -> pure x _ -> failure errors -isTypeDefined :: Key -> DataTypeLib -> Maybe DataFingerprint+isTypeDefined :: Key -> Schema -> Maybe DataFingerprint isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib -defineType :: (Key, DataType) -> DataTypeLib -> DataTypeLib+defineType :: (Key, DataType) -> Schema -> Schema defineType (key, datatype@DataType { typeName, typeContent = DataInputUnion enumKeys, typeFingerprint }) lib = lib { types = insert name unionTags (insert key datatype (types lib)) } where@@ -543,29 +534,24 @@ defineType (key, datatype) lib = lib { types = insert key datatype (types lib) } -lookupType :: Failure e m => e -> [(Key, a)] -> Key -> m a-lookupType err lib typeName = case lookup typeName lib of- Nothing -> failure err- Just x -> pure x -createDataTypeLib :: [(Key, DataType)] -> Validation DataTypeLib-createDataTypeLib types = case takeByKey "Query" types of- (Just query, lib1) -> case takeByKey "Mutation" lib1 of- (mutation, lib2) -> case takeByKey "Subscription" lib2 of- (subscription, lib3) ->- pure- ((foldr defineType (initTypeLib query) lib3) { mutation- , subscription- }- )- _ -> internalError "Query Not Defined"- where- takeByKey key lib = case lookup key lib of+-- lookups and removes DataType from hashmap +popByKey :: Name -> [(Key, DataType)] -> (Maybe (Name,DataType), [(Key, DataType)])+popByKey key lib = case lookup key lib of Just dt@DataType { typeContent = DataObject {} } -> (Just (key, dt), filter ((/= key) . fst) lib)- _ -> (Nothing, lib)+ _ -> (Nothing, lib) +createDataTypeLib :: [(Key, DataType)] -> Validation Schema+createDataTypeLib types = case popByKey "Query" types of+ (Nothing ,_ ) -> internalError "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}++ createInputUnionFields :: Key -> [Key] -> [(Key, DataField)] createInputUnionFields name members = fieldTag : map unionField members where@@ -597,7 +583,7 @@ TypeRef { typeConName, typeWrappers = [], typeArgs = Nothing } -type TypeUpdater = LibUpdater DataTypeLib+type TypeUpdater = LibUpdater Schema insertType :: (Key, DataType) -> TypeUpdater insertType nextType@(name, datatype) lib = case isTypeDefined name lib of@@ -631,13 +617,13 @@ } deriving (Show) data TypeD = TypeD- { tName :: String- , tNamespace :: [String]+ { tName :: Name+ , tNamespace :: [Name] , tCons :: [ConsD] , tMeta :: Maybe Meta } deriving (Show) data ConsD = ConsD- { cName :: String+ { cName :: Name , cFields :: [DataField] } deriving (Show)
src/Data/Morpheus/Types/Internal/AST/Selection.hs view
@@ -64,7 +64,7 @@ ) import Data.Morpheus.Types.Internal.AST.Data ( OperationType(..)- , DataTypeLib(..)+ , Schema(..) , DataType(..) , DataTypeContent(..) , DataObject@@ -154,18 +154,18 @@ getOperationName = fromMaybe "AnonymousOperation" getOperationObject- :: Operation a -> DataTypeLib -> Validation (Name, DataObject)+ :: Operation a -> Schema -> Validation (Name, DataObject) getOperationObject op lib = do dt <- getOperationDataType op lib case dt of- DataType { typeContent = DataObject x, typeName } -> pure (typeName, x)+ DataType { typeContent = DataObject { objectFields }, typeName } -> pure (typeName, objectFields) DataType { typeName } -> failure $ "Type Mismatch: operation \"" <> typeName <> "\" must be an Object" -getOperationDataType :: Operation a -> DataTypeLib -> Validation DataType+getOperationDataType :: Operation a -> Schema -> Validation DataType getOperationDataType Operation { operationType = Query } lib = pure $ snd $ query lib getOperationDataType Operation { operationType = Mutation, operationPosition } lib
src/Data/Morpheus/Types/Internal/Resolving.hs view
@@ -5,7 +5,7 @@ , Resolver(..) , ResolvingStrategy(..) , MapStrategy(..)- , LiftEither(..)+ , LiftOperation , resolveObject , toResponseRes , withObject@@ -31,6 +31,7 @@ , resolve__typename , DataResolver(..) , FieldRes+ , WithOperation ) where
src/Data/Morpheus/Types/Internal/Resolving/Core.hs view
@@ -36,9 +36,13 @@ , ToJSON ) import Data.Morpheus.Types.Internal.AST.Base- ( Position(..) )+ ( + Position(..)+ , Message + ) import Data.Text ( Text , pack+ , unpack ) import GHC.Generics ( Generic ) import Data.Semigroup ( (<>) )@@ -64,8 +68,8 @@ -- Result -- ---data Result events error (concurency :: Bool) a =- Success { result :: a , warnings :: [error] , events:: [events] }+data Result events error (concurency :: Bool) a + = Success { result :: a , warnings :: [error] , events:: [events] } | Failure [error] deriving (Functor) instance Applicative (Result e cocnurency error) where@@ -123,6 +127,9 @@ instance MonadTrans (ResultT event error concurency) where lift = ResultT . fmap pure++instance Monad m => Failure Message (ResultT event String concurency m) where+ failure message = ResultT $ pure $ Failure [unpack message] instance Applicative m => Failure String (ResultT ev GQLError con m) where failure x =
src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs view
@@ -12,6 +12,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-} module Data.Morpheus.Types.Internal.Resolving.Resolver ( Event(..)@@ -20,7 +21,7 @@ , Resolver(..) , ResolvingStrategy(..) , MapStrategy(..)- , LiftEither(..)+ , LiftOperation , resolveObject , resolveEnum , toResponseRes@@ -35,6 +36,7 @@ , resolve__typename , DataResolver(..) , FieldRes+ , WithOperation ) where @@ -94,10 +96,12 @@ ) -- MORPHEUS -class LiftEither (o::OperationType) res where+class LiftOperation (o::OperationType) res where type ResError res :: *- liftEither :: Monad m => m (Either (ResError res) a) -> res o event m a+ liftOperation :: Monad m => m (Either (ResError res) a) -> res o event m a +type WithOperation (o :: OperationType) = LiftOperation o Resolver+ type ResponseStream event m = ResultT (ResponseEvent m event) GQLError 'True m data ResponseEvent m event@@ -138,8 +142,8 @@ fmap f (ResolveS res) = ResolveS $ (<$>) f <$> res -- Applicative-instance (LiftEither o ResolvingStrategy, Monad m) => Applicative (ResolvingStrategy o e m) where- pure = liftEither . pure . pure+instance (LiftOperation o ResolvingStrategy, Monad m) => Applicative (ResolvingStrategy o e m) where+ pure = liftOperation . pure . pure ------------------------------------- (ResolveQ f) <*> (ResolveQ res) = ResolveQ (f <*> res) ------------------------------------------------------------------------@@ -147,22 +151,22 @@ -------------------------------------------------------------- (ResolveS f) <*> (ResolveS res) = ResolveS $ (<*>) <$> f <*> res --- LiftEither-instance LiftEither QUERY ResolvingStrategy where+-- LiftOperation+instance LiftOperation QUERY ResolvingStrategy where type ResError ResolvingStrategy = GQLErrors- liftEither = ResolveQ . ResultT . fmap fromEither+ liftOperation = ResolveQ . ResultT . fmap fromEither -instance LiftEither MUTATION ResolvingStrategy where+instance LiftOperation MUTATION ResolvingStrategy where type ResError ResolvingStrategy = GQLErrors- liftEither = ResolveM . ResultT . fmap fromEither+ liftOperation = ResolveM . ResultT . fmap fromEither -instance LiftEither SUBSCRIPTION ResolvingStrategy where+instance LiftOperation SUBSCRIPTION ResolvingStrategy where type ResError ResolvingStrategy = GQLErrors- liftEither = ResolveS . ResultT . fmap (fromEither . fmap pure)+ liftOperation = ResolveS . ResultT . fmap (fromEither . fmap pure) -- Failure-instance (LiftEither o ResolvingStrategy, Monad m) => Failure GQLErrors (ResolvingStrategy o e m) where- failure = liftEither . pure . Left+instance (LiftOperation o ResolvingStrategy, Monad m) => Failure GQLErrors (ResolvingStrategy o e m) where+ failure = liftOperation . pure . Left -- DataResolver data DataResolver o e m =@@ -177,7 +181,7 @@ _ <> _ = InvalidRes "can't merge: incompatible resolvers" withObject- :: (LiftEither o ResolvingStrategy, Monad m)+ :: (LiftOperation o ResolvingStrategy, Monad m) => (ValidSelectionSet -> ResolvingStrategy o e m value) -> (Key, ValidSelection) -> ResolvingStrategy o e m value@@ -187,7 +191,7 @@ failure (subfieldsNotSelected key "" selectionPosition) resolveObject- :: (Monad m, LiftEither o ResolvingStrategy)+ :: (Monad m, LiftOperation o ResolvingStrategy) => ValidSelectionSet -> DataResolver o e m -> ResolvingStrategy o e m ValidValue@@ -203,7 +207,7 @@ failure $ internalResolvingError "expected object as resolver" resolveEnum- :: (Monad m, LiftEither o ResolvingStrategy)+ :: (Monad m, LiftOperation o ResolvingStrategy) => Name -> Name -> ValidSelectionRec@@ -224,7 +228,7 @@ resolve__typename- :: (Monad m, LiftEither o ResolvingStrategy)+ :: (Monad m, LiftOperation o ResolvingStrategy) => Name -> (Key, (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue) resolve__typename name = ("__typename", const $ pure $ gqlString name)@@ -272,8 +276,8 @@ where eventFmap res event = fmap f (res event) -- Applicative-instance (LiftEither o Resolver ,Monad m) => Applicative (Resolver o e m) where- pure = liftEither . pure . pure+instance (LiftOperation o Resolver ,Monad m) => Applicative (Resolver o e m) where+ pure = liftOperation . pure . pure ------------------------------------- (QueryResolver f) <*> (QueryResolver res) = QueryResolver (f <*> res) ---------------------------------------------------------------------@@ -299,27 +303,27 @@ -- Monad Transformers instance MonadTrans (Resolver QUERY e) where- lift = liftEither . fmap pure+ lift = liftOperation . fmap pure instance MonadTrans (Resolver MUTATION e) where- lift = liftEither . fmap pure+ lift = liftOperation . fmap pure --- LiftEither-instance LiftEither QUERY Resolver where+-- LiftOperation+instance LiftOperation QUERY Resolver where type ResError Resolver = String- liftEither = QueryResolver . ResultT . fmap fromEitherSingle+ liftOperation = QueryResolver . ResultT . fmap fromEitherSingle -instance LiftEither MUTATION Resolver where+instance LiftOperation MUTATION Resolver where type ResError Resolver = String- liftEither = MutResolver . ResultT . fmap (fromEitherSingle . fmap ([], ))+ liftOperation = MutResolver . ResultT . fmap (fromEitherSingle . fmap ([], )) -instance LiftEither SUBSCRIPTION Resolver where+instance LiftOperation SUBSCRIPTION Resolver where type ResError Resolver = String- liftEither = SubResolver [] . const . liftEither+ liftOperation = SubResolver [] . const . liftOperation -- Failure-instance (LiftEither o Resolver, Monad m) => Failure Message (Resolver o e m) where- failure = liftEither . pure . Left . unpack+instance (LiftOperation o Resolver, Monad m) => Failure Message (Resolver o e m) where+ failure = liftOperation . pure . Left . unpack -- Type Helpers type family UnSubResolver (a :: * -> *) :: (* -> *)@@ -332,7 +336,7 @@ = (Key, (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue) toResolver- :: (LiftEither o Resolver, Monad m)+ :: (LiftOperation o Resolver, Monad m) => Validation a -> (a -> Resolver o e m b) -> Resolver o e m b@@ -399,7 +403,7 @@ ------------------------------------------------------------------- -- | GraphQL Root resolver, also the interpreter generates a GQL schema from it. -- 'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional,--- if your schema does not supports __mutation__ or __subscription__ , you acn use __()__ for it.+-- if your schema does not supports __mutation__ or __subscription__ , you can use __()__ for it. data GQLRootResolver (m :: * -> *) event (query :: (* -> *) -> * ) (mut :: (* -> *) -> * ) (sub :: (* -> *) -> * ) = GQLRootResolver { queryResolver :: query (Resolver QUERY event m) , mutationResolver :: mut (Resolver MUTATION event m)
src/Data/Morpheus/Types/Internal/TH.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Types.Internal.TH where import Language.Haskell.TH+import Data.Text (Text,unpack) apply :: Name -> [Q Exp] -> Q Exp apply n = foldl appE (conE n)@@ -11,25 +13,25 @@ applyT :: Name -> [Q Type] -> Q Type applyT name = foldl appT (conT name) -typeT :: Name -> [String] -> Q Type-typeT name li = applyT name (map (varT . mkName) li)+typeT :: Name -> [Text] -> Q Type+typeT name li = applyT name (map (varT . mkName . unpack) li) -instanceHeadT :: Name -> String -> [String] -> Q Type-instanceHeadT cName iType tArgs = applyT cName [applyT (mkName iType) (map (varT . mkName) tArgs)]+instanceHeadT :: Name -> Text -> [Text] -> Q Type+instanceHeadT cName iType tArgs = applyT cName [applyT (mkName $ unpack iType) (map (varT . mkName . unpack) tArgs)] instanceProxyFunD :: (Name,ExpQ) -> DecQ instanceProxyFunD (name,body) = instanceFunD name ["_"] body -instanceFunD :: Name -> [String] -> ExpQ -> Q Dec-instanceFunD name args body = funD name [clause (map (varP . mkName) args) (normalB body) []]+instanceFunD :: Name -> [Text] -> ExpQ -> Q Dec+instanceFunD name args body = funD name [clause (map (varP . mkName. unpack) args) (normalB body) []] instanceHeadMultiT :: Name -> Q Type -> [Q Type] -> Q Type instanceHeadMultiT className iType li = applyT className (iType : li) -- "User" -> ["name","id"] -> (User name id)-destructRecord :: String -> [String] -> PatQ-destructRecord conName fields = conP (mkName conName) (map (varP . mkName) fields)+destructRecord :: Text -> [Text] -> PatQ+destructRecord conName fields = conP (mkName $ unpack conName) (map (varP . mkName .unpack) fields) typeInstanceDec :: Name -> Type -> Type -> Dec #if MIN_VERSION_template_haskell(2,15,0)@@ -39,3 +41,14 @@ -- typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res) #endif+++infoTyVars :: Info -> [TyVarBndr]+infoTyVars (TyConI x) = decArgs x+infoTyVars _ = []+ +decArgs :: Dec -> [TyVarBndr]+decArgs (DataD _ _ args _ _ _) = args +decArgs (NewtypeD _ _ args _ _ _) = args +decArgs (TySynD _ args _) = args+decArgs _ = []
src/Data/Morpheus/Validation/Document/Validation.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TupleSections #-} + module Data.Morpheus.Validation.Document.Validation ( validatePartialDocument )@@ -23,45 +25,28 @@ , DataTypeContent(..) , Name , Key- , RawDataType(..) , TypeRef(..)- , DataFingerprint(..)- , Meta , isWeaker- , isWeaker ) import Data.Morpheus.Types.Internal.Resolving ( Validation , Failure(..) ) -validatePartialDocument :: [(Key, RawDataType)] -> Validation [(Key, DataType)]+validatePartialDocument :: [(Key, DataType)] -> Validation [(Key, DataType)] validatePartialDocument lib = catMaybes <$> traverse validateType lib where- validateType :: (Key, RawDataType) -> Validation (Maybe (Key, DataType))- validateType (name, FinalDataType x) = pure $ Just (name, x)- validateType (name, Implements { implementsName, implementsInterfaces, implementsMeta, implementsContent })- = asTuple name- <$> (implementsName, implementsMeta, implementsContent)- `mustImplement` implementsInterfaces- validateType _ = pure Nothing- ------------------------------------ asTuple name x = Just (name, x)- ------------------------------------ mustImplement :: (Name, Maybe Meta, DataObject) -> [Key] -> Validation DataType- mustImplement (typeName, typeMeta, object) interfaceKey = do- interface <- traverse getInterfaceByKey interfaceKey- case concatMap (mustBeSubset object) interface of- [] -> pure $ DataType { typeName- , typeFingerprint = DataFingerprint typeName []- , typeMeta- , typeContent = DataObject object- }- errors -> failure $ partialImplements typeName errors- -------------------------------+ validateType :: (Key, DataType) -> Validation (Maybe (Key, DataType))+ validateType (name, dt@DataType { typeName , typeContent = DataObject { objectImplements , objectFields} }) = do + interface <- traverse getInterfaceByKey objectImplements+ case concatMap (mustBeSubset objectFields) interface of+ [] -> pure $ Just (name, dt) + errors -> failure $ partialImplements typeName errors+ validateType (_,DataType { typeContent = DataInterface {}}) = pure Nothing+ validateType (name, x) = pure $ Just (name, x) mustBeSubset :: DataObject -> (Name, DataObject) -> [(Key, Key, ImplementsError)]- mustBeSubset objFields (typeName, interfaceFields) = concatMap+ mustBeSubset objFields (typeName, interfaceFields ) = concatMap checkField interfaceFields where@@ -84,5 +69,5 @@ ------------------------------- getInterfaceByKey :: Key -> Validation (Name,DataObject) getInterfaceByKey key = case lookup key lib of- Just Interface { interfaceContent } -> pure (key,interfaceContent)+ Just DataType { typeContent = DataInterface { interfaceFields } } -> pure (key,interfaceFields) _ -> failure $ unknownInterface key
− src/Data/Morpheus/Validation/Internal/Utils.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}---module Data.Morpheus.Validation.Internal.Utils- ( differKeys- , checkNameCollision- , checkForUnknownKeys- , VALIDATION_MODE(..)- )-where--import Data.List ( (\\) )-import Data.Morpheus.Types.Internal.AST- ( Ref(..)- , Key- , anonymousRef- )-import qualified Data.Set as S-import Data.Text ( Text )-import Data.Morpheus.Types.Internal.Resolving- ( Failure(..) )--data VALIDATION_MODE- = WITHOUT_VARIABLES- | FULL_VALIDATION- deriving (Eq, Show)--differKeys :: [Ref] -> [Key] -> [Ref]-differKeys enhanced keys = enhanced \\ map anonymousRef keys--removeDuplicates :: Ord a => [a] -> [a]-removeDuplicates = S.toList . S.fromList--elementOfKeys :: [Text] -> Ref -> Bool-elementOfKeys keys Ref { refName } = refName `elem` keys--checkNameCollision :: Failure e m => [Ref] -> ([Ref] -> e) -> m [Ref]-checkNameCollision enhancedKeys errorGenerator =- case enhancedKeys \\ removeDuplicates enhancedKeys of- [] -> pure enhancedKeys- duplicates -> failure $ errorGenerator duplicates--checkForUnknownKeys :: Failure e m => [Ref] -> [Text] -> ([Ref] -> e) -> m [Ref]-checkForUnknownKeys enhancedKeys' keys' errorGenerator' =- case filter (not . elementOfKeys keys') enhancedKeys' of- [] -> pure enhancedKeys'- unknownKeys' -> failure $ errorGenerator' unknownKeys'
src/Data/Morpheus/Validation/Internal/Value.hs view
@@ -20,7 +20,7 @@ ( DataField(..) , DataTypeContent(..) , DataType(..)- , DataTypeLib(..)+ , Schema(..) , DataValidator(..) , Key , TypeRef(..)@@ -75,7 +75,7 @@ -- Validate Variable Argument or all Possible input Values validateInputValue- :: DataTypeLib+ :: Schema -> [Prop] -> [TypeWrapper] -> DataType
src/Data/Morpheus/Validation/Query/Arguments.hs view
@@ -31,7 +31,7 @@ , Position , DataArgument , DataField(..)- , DataTypeLib+ , Schema , TypeRef(..) , isFieldNullable , lookupInputType@@ -41,15 +41,13 @@ , ResolvedValue , RESOLVED , VALID+ , checkForUnknownKeys+ , checkNameCollision ) import Data.Morpheus.Types.Internal.Resolving ( Validation , Failure(..) )-import Data.Morpheus.Validation.Internal.Utils- ( checkForUnknownKeys- , checkNameCollision- ) import Data.Morpheus.Validation.Internal.Value ( validateInputValue ) import Data.Text ( Text )@@ -97,7 +95,7 @@ pure (key, Argument constValue position) validateArgument- :: DataTypeLib+ :: Schema -> Position -> Arguments RESOLVED -> (Text, DataArgument)@@ -136,7 +134,7 @@ handleInputError (Right x) = pure x validateArguments- :: DataTypeLib+ :: Schema -> Text -> ValidVariables -> (Text, DataField)
src/Data/Morpheus/Validation/Query/Fragment.hs view
@@ -30,19 +30,20 @@ , Selection(..) , Ref(..) , Position- , DataTypeLib- , lookupDataObject+ , Schema+ , DataLookup(..)+ , checkNameCollision+ , DataObject+ , Name ) import Data.Morpheus.Types.Internal.Resolving ( Validation , Failure(..) )-import Data.Morpheus.Validation.Internal.Utils- ( checkNameCollision ) validateFragments- :: DataTypeLib -> FragmentLib -> [(Text, RawSelection)] -> Validation ()+ :: Schema -> FragmentLib -> [(Text, RawSelection)] -> Validation () validateFragments lib fragments operatorSel = validateNameCollision >> checkLoop >> checkUnusedFragments where@@ -105,9 +106,9 @@ scanForSpread (_, Spread Ref { refName = name', refPosition = position' }) = [Ref name' position'] -validateFragment :: DataTypeLib -> (Text, Fragment) -> Validation NodeEdges+validateFragment :: Schema -> (Text, Fragment) -> Validation NodeEdges validateFragment lib (fName, Fragment { fragmentSelection, fragmentType, fragmentPosition })- = lookupDataObject validationError fragmentType lib >> pure+ = (lookupResult validationError fragmentType lib :: Validation ( Name, DataObject) )>> pure (Ref fName fragmentPosition, concatMap scanForSpread fragmentSelection) where validationError = unknownType fragmentType fragmentPosition
src/Data/Morpheus/Validation/Query/Selection.hs view
@@ -37,22 +37,20 @@ , DataObject , DataTypeContent(..) , DataType(..)- , DataTypeLib(..)+ , Schema(..) , TypeRef(..) , Name- , allDataTypes , isEntNode , lookupFieldAsSelectionSet , lookupSelectionField- , lookupType+ , DataLookup(..) , lookupUnionTypes+ , checkNameCollision ) import Data.Morpheus.Types.Internal.Resolving ( Validation , Failure(..) )-import Data.Morpheus.Validation.Internal.Utils- ( checkNameCollision ) import Data.Morpheus.Validation.Query.Arguments ( validateArguments ) import Data.Morpheus.Validation.Query.Fragment@@ -122,7 +120,7 @@ -} validateSelectionSet- :: DataTypeLib+ :: Schema -> FragmentLib -> Text -> ValidVariables@@ -138,11 +136,6 @@ <$> mapM validateSelection selectionSet >>= checkDuplicatesOn typeName where- validateFragment Fragment { fragmentSelection = selection' } =- __validate dataType selection'- {-- get dataField and validated arguments for RawSelection- -} -- getValidationData :: Name -> ValidSelection -> (DataField, DataTypeContent, ValidArguments) getValidationData key (selectionArguments, selectionPosition) = do selectionField <- lookupSelectionField selectionPosition@@ -157,14 +150,16 @@ selectionPosition selectionArguments -- check field Type existence ------ fieldDataType <- lookupType- (unknownType (typeConName $fieldType selectionField) selectionPosition)- (allDataTypes lib)+ fieldDataType <- lookupResult+ (unknownType (typeConName $fieldType selectionField) selectionPosition) (typeConName $ fieldType selectionField)+ lib return (selectionField, fieldDataType, arguments) -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet -- validateSelection :: (Text, RawSelection) -> Validation ValidSelectionSet+ validateSelection ("__typename", sel@Selection { selectionArguments = [], selectionContent = SelectionField}) = + pure [("__typename", sel { selectionArguments = [], selectionContent = SelectionField })] validateSelection (key', fullRawSelection@Selection { selectionArguments = selArgs, selectionContent = SelectionSet rawSelection, selectionPosition }) = do (dataField, datatype, arguments) <- getValidationData@@ -201,7 +196,7 @@ selection' <- __validate type' (concatMap fragmentSelection frags') return (fst type', sysSelection' ++ selection')- DataObject _ -> do+ DataObject {} -> do fieldType' <- lookupFieldAsSelectionSet selectionPosition key' lib@@ -236,3 +231,4 @@ validateSelection (_, InlineFragment fragment') = castFragmentType Nothing (fragmentPosition fragment') [typeName] fragment' >>= validateFragment+ validateFragment Fragment { fragmentSelection } = __validate dataType fragmentSelection
src/Data/Morpheus/Validation/Query/Validation.hs view
@@ -14,14 +14,12 @@ , ValidOperation , getOperationName , getOperationObject- , DataTypeLib(..)+ , Schema(..) , GQLQuery(..)+ , VALIDATION_MODE ) import Data.Morpheus.Types.Internal.Resolving ( Validation )--import Data.Morpheus.Validation.Internal.Utils- ( VALIDATION_MODE ) import Data.Morpheus.Validation.Query.Fragment ( validateFragments ) import Data.Morpheus.Validation.Query.Selection@@ -31,7 +29,7 @@ validateRequest- :: DataTypeLib -> VALIDATION_MODE -> GQLQuery -> Validation ValidOperation+ :: Schema -> VALIDATION_MODE -> GQLQuery -> Validation ValidOperation validateRequest lib validationMode GQLQuery { fragments, inputVariables, operation = rawOperation@Operation { operationName, operationType, operationSelection, operationPosition } } = do operationDataType <- getOperationObject rawOperation lib
src/Data/Morpheus/Validation/Query/Variable.hs view
@@ -40,7 +40,7 @@ , Ref(..) , Position , DataType- , DataTypeLib+ , Schema , lookupInputType , Variables , Value(..)@@ -53,19 +53,18 @@ , VariableContent(..) , isNullable , TypeRef(..)+ , VALIDATION_MODE(..) ) import Data.Morpheus.Types.Internal.Resolving ( Validation , Failure(..) )-import Data.Morpheus.Validation.Internal.Utils- ( VALIDATION_MODE(..) ) import Data.Morpheus.Validation.Internal.Value ( validateInputValue ) import Data.Morpheus.Validation.Query.Fragment ( getFragment ) -getVariableType :: Text -> Position -> DataTypeLib -> Validation DataType+getVariableType :: Text -> Position -> Schema -> Validation DataType getVariableType type' position' lib' = lookupInputType type' lib' error' where error' = unknownType type' position' @@ -106,7 +105,7 @@ . fragmentSelection resolveOperationVariables- :: DataTypeLib+ :: Schema -> FragmentLib -> Variables -> VALIDATION_MODE@@ -128,7 +127,7 @@ failure $ unusedVariables (getOperationName operationName) unused' lookupAndValidateValueOnBody- :: DataTypeLib+ :: Schema -> Variables -> VALIDATION_MODE -> (Text, Variable RAW)
test/Feature/Holistic/API.hs view
@@ -27,7 +27,6 @@ , ID(..) , ScalarValue(..) , Resolver(..)- , constRes , failRes , liftEither )@@ -64,29 +63,32 @@ rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription rootResolver = GQLRootResolver { queryResolver = Query { user- , testUnion = constRes Nothing- , fail1 = const $ liftEither alwaysFail- , fail2 = const $ failRes "fail with failRes"+ , testUnion = pure Nothing+ , fail1 = liftEither alwaysFail+ , fail2 = failRes "fail with failRes" }- , mutationResolver = Mutation { createUser = user }+ , mutationResolver = Mutation { createUser = const user } , subscriptionResolver = Subscription- { newUser = const SubResolver++ { newUser = SubResolver { subChannels = [Channel]- , subResolver = user+ , subResolver = const user } } } where- user _ = pure User { name = constRes "testName"- , email = constRes ""+ user :: Applicative m => m (User m)+ user = pure User { name = pure "testName"+ , email = pure "" , address = resolveAddress , office = resolveAddress- , friend = constRes Nothing+ , friend = pure Nothing } where- resolveAddress _ = pure Address { city = constRes ""- , houseNumber = constRes 0- , street = constRes Nothing+ resolveAddress :: Applicative m => a -> m (Address m)+ resolveAddress _ = pure Address { city = pure ""+ , houseNumber = pure 0+ , street = const $ pure Nothing } api :: GQLRequest -> IO GQLResponse
test/Feature/Holistic/cases.json view
@@ -230,5 +230,9 @@ { "path": "failure/resolveFailure", "description": "test failed resolvers"+ },+ {+ "path": "selection/__typename",+ "description": "test __typename on object types" } ]
+ test/Feature/Holistic/selection/__typename/query.gql view
@@ -0,0 +1,5 @@+{+ user {+ __typename+ }+}
+ test/Feature/Holistic/selection/__typename/response.json view
@@ -0,0 +1,7 @@+{+ "data": {+ "user": {+ "__typename": "User"+ }+ }+}
test/Feature/InputType/API.hs view
@@ -10,7 +10,6 @@ where import Data.Morpheus ( interpreter )-import Data.Morpheus.Kind ( OBJECT ) import Data.Morpheus.Types ( GQLRequest , GQLResponse , GQLRootResolver(..)@@ -34,10 +33,7 @@ data A = A { a1 :: F1Args -> IORes () Text , a2 :: F2Args -> IORes () Int- } deriving (Generic)--instance GQLType A where- type KIND A = OBJECT+ } deriving (Generic, GQLType) newtype Query (m :: * -> *) = Query { q1 :: A
test/Feature/Schema/A2.hs view
@@ -1,17 +1,14 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveAnyClass #-} module Feature.Schema.A2 ( A(..) ) where -import Data.Morpheus.Kind (OBJECT)-import Data.Morpheus.Types (GQLType (..))+import Data.Morpheus.Types (GQLType) import GHC.Generics (Generic) newtype A = A { bla :: Int- } deriving (Generic)--instance GQLType A where- type KIND A = OBJECT+ } deriving (Generic, GQLType)
test/Feature/Schema/API.hs view
@@ -9,7 +9,6 @@ ) where import Data.Morpheus (interpreter)-import Data.Morpheus.Kind (OBJECT) import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..)) import Data.Text (Text) import qualified Feature.Schema.A2 as A2 (A (..))@@ -18,10 +17,7 @@ data A = A { aText :: Text , aInt :: Int- } deriving (Generic)--instance GQLType A where- type KIND A = OBJECT+ } deriving (Generic, GQLType) data Query (m :: * -> * ) = Query { a1 :: A
test/Feature/UnionType/API.hs view
@@ -10,9 +10,6 @@ where import Data.Morpheus ( interpreter )-import Data.Morpheus.Kind ( OBJECT- , UNION- ) import Data.Morpheus.Types ( GQLRequest , GQLResponse , GQLRootResolver(..)@@ -23,37 +20,25 @@ import Data.Text ( Text ) import GHC.Generics ( Generic ) -instance GQLType A where- type KIND A = OBJECT--instance GQLType B where- type KIND B = OBJECT--instance GQLType C where- type KIND C = OBJECT--instance GQLType Sum where- type KIND Sum = UNION- data A = A { aText :: Text , aInt :: Int- } deriving (Generic)+ } deriving (Generic, GQLType) data B = B { bText :: Text , bInt :: Int- } deriving (Generic)+ } deriving (Generic, GQLType) data C = C { cText :: Text , cInt :: Int- } deriving (Generic)+ } deriving (Generic, GQLType) data Sum = SumA A | SumB B- deriving (Generic)+ deriving (Generic, GQLType) data Query m = Query { union :: () -> m [Sum]
test/Feature/WrappedTypeName/API.hs view
@@ -9,28 +9,20 @@ ) where import Data.Morpheus (interpreter)-import Data.Morpheus.Kind (OBJECT) import Data.Morpheus.Types (Event, GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes, Resolver (..), constRes) import Data.Text (Text)-import Data.Typeable (Typeable) import GHC.Generics (Generic) -instance Typeable a => GQLType (WA a) where- type KIND (WA a) = OBJECT--instance (Typeable a, Typeable b) => GQLType (Wrapped a b) where- type KIND (Wrapped a b) = OBJECT- data Wrapped a b = Wrapped { fieldA :: a , fieldB :: b- } deriving (Generic)+ } deriving (Generic, GQLType) data WA m = WA { aText :: () -> m Text , aInt :: Int- } deriving (Generic)+ } deriving (Generic,GQLType) data Query m = Query { a1 :: WA m
test/Rendering/TestSchemaRendering.hs view
@@ -16,4 +16,4 @@ where schema = toGraphQLDocument schemaProxy expected =- "type Query { \n user: User!\n testUnion: TestUnion\n}\n\nenum TestEnum { \n EnumA\n EnumB\n EnumC\n}\n\ntype Address { \n street: [[[[String!]!]!]]\n}\n\ninput Coordinates { \n latitude: TestScalar!\n longitude: Int!\n}\n\ntype User { \n type: String!\n address(coordinates: Coordinates!, type: String): Int!\n friend(id: ID!, cityID: TestEnum): User!\n}\n\nunion TestUnion =\n User\n | Address\n\nscalar TestScalar"+ "enum TestEnum { \n EnumA\n EnumB\n EnumC\n}\n\ntype Address { \n street: [[[[String!]!]!]]\n}\n\ninput Coordinates { \n latitude: TestScalar!\n longitude: Int!\n}\n\ntype User { \n type: String!\n address(coordinates: Coordinates!, type: String): Int!\n friend(id: ID!, cityID: TestEnum): User!\n}\n\ntype Query { \n user: User!\n testUnion: TestUnion\n}\n\nunion TestUnion =\n User\n | Address\n\nscalar TestScalar"