morpheus-graphql 0.12.0 → 0.13.0
raw patch · 71 files changed
+1876/−1173 lines, 71 filesdep ~morpheus-graphql-core
Dependency ranges changed: morpheus-graphql-core
Files
- README.md +38/−41
- changelog.md +24/−9
- morpheus-graphql.cabal +36/−13
- src/Data/Morpheus/Document.hs +4/−4
- src/Data/Morpheus/Server/Deriving/Decode.hs +2/−2
- src/Data/Morpheus/Server/Deriving/Encode.hs +4/−4
- src/Data/Morpheus/Server/Deriving/Interpreter.hs +2/−2
- src/Data/Morpheus/Server/Deriving/Introspect.hs +149/−137
- src/Data/Morpheus/Server/Deriving/Resolve.hs +10/−9
- src/Data/Morpheus/Server/Document/Compile.hs +0/−64
- src/Data/Morpheus/Server/Document/Convert.hs +0/−205
- src/Data/Morpheus/Server/Document/Declare.hs +0/−83
- src/Data/Morpheus/Server/Document/Decode.hs +0/−51
- src/Data/Morpheus/Server/Document/Encode.hs +0/−131
- src/Data/Morpheus/Server/Document/GQLType.hs +0/−110
- src/Data/Morpheus/Server/Document/Introspect.hs +0/−135
- src/Data/Morpheus/Server/Internal/TH/Decode.hs +5/−2
- src/Data/Morpheus/Server/Internal/TH/Types.hs +25/−0
- src/Data/Morpheus/Server/TH/Compile.hs +64/−0
- src/Data/Morpheus/Server/TH/Declare.hs +82/−0
- src/Data/Morpheus/Server/TH/Declare/Decode.hs +51/−0
- src/Data/Morpheus/Server/TH/Declare/Encode.hs +131/−0
- src/Data/Morpheus/Server/TH/Declare/GQLType.hs +106/−0
- src/Data/Morpheus/Server/TH/Declare/Introspect.hs +171/−0
- src/Data/Morpheus/Server/TH/Declare/Type.hs +120/−0
- src/Data/Morpheus/Server/TH/Transform.hs +216/−0
- src/Data/Morpheus/Server/Types/GQLScalar.hs +0/−72
- src/Data/Morpheus/Server/Types/GQLType.hs +5/−0
- src/Data/Morpheus/Server/Types/ID.hs +0/−46
- src/Data/Morpheus/Types.hs +10/−9
- test/Feature/Holistic/API.hs +3/−3
- test/Feature/Holistic/introspection/schemaTypes/__Type/response.json +2/−2
- test/Feature/Holistic/parsing/complex/response.json +2/−2
- test/Feature/Holistic/selection/directives/default/wrongArgumentType/response.json +1/−1
- test/Feature/Input/DefaultValue/API.hs +51/−0
- test/Feature/Input/DefaultValue/cases.json +22/−0
- test/Feature/Input/DefaultValue/intorspection/arguments/query.gql +76/−0
- test/Feature/Input/DefaultValue/intorspection/arguments/response.json +61/−0
- test/Feature/Input/DefaultValue/intorspection/input-compound/query.gql +76/−0
- test/Feature/Input/DefaultValue/intorspection/input-compound/response.json +61/−0
- test/Feature/Input/DefaultValue/intorspection/input-simple/query.gql +76/−0
- test/Feature/Input/DefaultValue/intorspection/input-simple/response.json +36/−0
- test/Feature/Input/DefaultValue/resolving/compound/query.gql +5/−0
- test/Feature/Input/DefaultValue/resolving/compound/response.json +7/−0
- test/Feature/Input/DefaultValue/resolving/simple/query.gql +3/−0
- test/Feature/Input/DefaultValue/resolving/simple/response.json +5/−0
- test/Feature/Input/DefaultValue/schema.gql +34/−0
- test/Feature/Input/Enum/API.hs +3/−3
- test/Feature/Input/Enum/cases.json +18/−2
- test/Feature/Input/Enum/decodeInvalidValue/response.json +1/−1
- test/Feature/Input/Enum/invalidEnumFromJSONVariable/query.gql +3/−0
- test/Feature/Input/Enum/invalidEnumFromJSONVariable/response.json +8/−0
- test/Feature/Input/Enum/invalidEnumFromJSONVariable/variables.json +1/−0
- test/Feature/Input/Enum/invalidStringDefaultValue/query.gql +3/−0
- test/Feature/Input/Enum/invalidStringDefaultValue/response.json +8/−0
- test/Feature/Input/Enum/invalidStringInput/query.gql +3/−0
- test/Feature/Input/Enum/invalidStringInput/response.json +8/−0
- test/Feature/Input/Enum/validEnumFromJSONVariable/query.gql +3/−0
- test/Feature/Input/Enum/validEnumFromJSONVariable/response.json +5/−0
- test/Feature/Input/Enum/validEnumFromJSONVariable/variables.json +1/−0
- test/Feature/Input/Object/API.hs +3/−3
- test/Feature/Input/Scalar/API.hs +3/−3
- test/Feature/InputType/API.hs +3/−3
- test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json +1/−1
- test/Feature/Schema/API.hs +3/−3
- test/Feature/TypeInference/API.hs +3/−3
- test/Feature/UnionType/API.hs +3/−3
- test/Feature/WrappedTypeName/API.hs +3/−3
- test/Rendering/Schema.hs +4/−4
- test/Spec.hs +6/−1
- test/Subscription/API.hs +3/−3
README.md view
@@ -1,4 +1,4 @@-# Morpheus GraphQL [](https://hackage.haskell.org/package/morpheus-graphql) [](https://circleci.com/gh/morpheusgraphql/morpheus-graphql)+# Morpheus GraphQL [](https://hackage.haskell.org/package/morpheus-graphql)  Build GraphQL APIs with your favourite functional language! @@ -26,10 +26,10 @@ _stack.yml_ ```yaml-resolver: lts-14.8+resolver: lts-15.13 extra-deps:- - morpheus-graphql-0.12.0+ - morpheus-graphql-0.13.0 ``` As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update`@@ -42,7 +42,7 @@ ```gql type Query {- deity(name: String!): Deity!+ deity(name: String! = "Morpheus"): Deity! } """@@ -76,14 +76,14 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Document (importGQLDocumentWithNamespace)-import Data.Morpheus.Types (GQLRootResolver (..), ResolverQ, Undefined(..))+import Data.Morpheus.Types (RootResolver (..), ResolverQ, Undefined(..)) import Data.Text (Text) importGQLDocumentWithNamespace "schema.gql" -rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query {queryDeity}, mutationResolver = Undefined,@@ -150,12 +150,12 @@ askDB = ... ``` -To make this `Query` type available as an API, we define a `GQLRootResolver` and feed it to the Morpheus `interpreter`. A `GQLRootResolver` consists of `query`, `mutation` and `subscription` definitions, while we omit the latter for this example:+To make this `Query` type available as an API, we define a `RootResolver` and feed it to the Morpheus `interpreter`. A `RootResolver` consists of `query`, `mutation` and `subscription` definitions, while we omit the latter for this example: ```haskell-rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query {deity = resolveDeity} , mutationResolver = Undefined , subscriptionResolver = Undefined@@ -259,7 +259,6 @@ | CharacterInt | SomeMutli | CharacterEnumObject # no-argument constructors all wrapped into an enum- type Creature { creatureName: String! creatureAge: Int!@@ -313,7 +312,6 @@ You will get the following schema: ```gql- # has wrapper types union WrappedNode = WrappedSong | WrappedSkit @@ -337,7 +335,6 @@ skitDuration: Float! skitName: String! }- ``` - for all other unions will be generated new object type. for types without record syntax, fields will be automatally indexed.@@ -417,9 +414,9 @@ { createDeity :: MutArgs -> m Deity } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO () Query Mutation Undefined+rootResolver :: RootResolver IO () Query Mutation Undefined rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query {...} , mutationResolver = Mutation { createDeity } , subscriptionResolver = Undefined@@ -465,8 +462,8 @@ type APIEvent = Event Channel Content -rootResolver :: GQLRootResolver IO APIEvent Query Mutation Subscription-rootResolver = GQLRootResolver+rootResolver :: RootResolver IO APIEvent Query Mutation Subscription+rootResolver = RootResolver { queryResolver = Query { deity = fetchDeity } , mutationResolver = Mutation { createDeity } , subscriptionResolver = Subscription { newDeity }@@ -488,33 +485,33 @@ ``` ### Interface- + 1. defining interface with Haskell Types (runtime validation):- - ```hs- -- interface is just regular type derived as interface- newtype Person m = Person {name :: m Text}- deriving (Generic) - instance GQLType (Person m) where- type KIND (Person m) = INTERFACE+ ```haskell+ -- interface is just regular type derived as interface+ newtype Person m = Person {name :: m Text}+ deriving (Generic) - -- with GQLType user can links interfaces to implementing object- instance GQLType Deity where- implements _ = [interface (Proxy @Person)]- ```+ instance GQLType (Person m) where+ type KIND (Person m) = INTERFACE + -- with GQLType user can links interfaces to implementing object+ instance GQLType Deity where+ implements _ = [interface (Proxy @Person)]+ ```+ 2. defining with `importGQLDocument` and `DSL` (compile time validation): - ```gql- interface Account {- name: String!- }+ ```graphql+ interface Account {+ name: String!+ } - type User implements Account {- name: String!- }- ```+ type User implements Account {+ name: String!+ }+ ``` ## Morpheus `GraphQL Client` with Template haskell QuasiQuotes @@ -583,11 +580,11 @@ | PowerOmniscience data GetHeroArgs = GetHeroArgs {- getHeroArgsCharacter: Character+ character: Character } data Character = Character {- characterName: Person+ name: Person } ``` @@ -599,7 +596,7 @@ fetchHero :: Args GetHero -> m (Either String GetHero) fetchHero = fetch jsonRes args where- args = GetHeroArgs {getHeroArgsCharacter = Person {characterName = "Zeus"}}+ args = GetHeroArgs {character = Person {name = "Zeus"}} jsonRes :: ByteString -> m ByteString jsonRes = <GraphQL APi> ```@@ -643,7 +640,7 @@ - https://github.com/dandoh/web-haskell - Modern webserver boilerplate in Haskell: Morpheus Graphql + Postgresql + Authentication + DB migration + Dotenv and more -*Edit this section and send PR if you want to share your project*.+_Edit this section and send PR if you want to share your project_. # About
changelog.md view
@@ -1,5 +1,16 @@ # Changelog +## 0.13.0 - Unreleased Changes++### breaking changes++- renamed `GQLRootResolver` -> `RootResolver`++### new features++- `importGQLDocument` automatically defines `GQLType` instances for scalar definitions+- supports default values+ ## 0.12.0 - 21.05.2020 ### Breaking Changes@@ -7,6 +18,7 @@ Package was extracted as: - `morpheus-graphql-core`: core components like: parser, validator, executor, utils.+ - Data.Morpheus.Core - Data.Morpheus.QuasiQuoter - Data.Morpheus.Error@@ -18,6 +30,7 @@ - Data.Morpheus.Types.IO - `morpheus-graphql-client`: lightweight version of morpheus client without server implementation+ - Data.Morpheus.Client - `morpheus-graphql`: morpheus graphql server@@ -60,11 +73,11 @@ - flexible compsed Resolver Type alias: `ComposedResolver`. extends `ResolverO` with parameter `(f :: * -> *)`. so that you can compose Resolvers e.g:- + ```hs resolveList :: ComposedResolver o EVENT IO [] Object -- is alias to: Resolver o () IO [Object (Resolver o () IO))]- + resolveList :: ComposedResolver o EVENT IO Maybe Int -- is alias to: Resolver o () IO (Maybe Int) ```@@ -90,22 +103,24 @@ - Client generated enum data constructors are now prefixed with with the type name to avoid name conflicts. - for Variant selection inputUnion uses `inputname` insead of `__typename` -- in `Data.Morpheus.Server` +- in `Data.Morpheus.Server`+ - `gqlSocketApp` and `gqlSocketMonadIOApp` are replaced with `webSocketsApp` - removed `initGQLState`, `GQLState` - for better control of subscriptions- - replaced instance `interpreter gqlRoot state` with++ - replaced instance `interpreter gqlRoot state` with `interpreter gqlRoot`. - added: `Input`, `Stream`, `httpPubApp`- + from now on you can define API that can be used in websockets as well as in http servers ```hs api :: Input api -> Stream api EVENT IO api = interpreter gqlRoot- + server :: IO () server = do (wsApp, publish) <- webSocketsApp api@@ -113,10 +128,10 @@ ... runBoth wsApp httpApp ```- + where `publish :: e -> m ()` - websockets and http app do not have to be on the same server. + websockets and http app do not have to be on the same server. e.g. you can pass events between servers with webhooks. - subscription can select only one top level field (based on the GraphQL specification).@@ -131,7 +146,7 @@ ### minor - changes to internal types-- fixed validation of apollo websockets requests +- fixed validation of apollo websockets requests ## 0.10.0 - 07.01.2020
morpheus-graphql.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: c98d51df8567b3a33a0b9f3dcf93217534d9f3a1d666f1ac2ab69b5ce6cfe0b6+-- hash: 55c61a113411654d318235d761f68f5115a1c3ffcd5f287c90ddfcc38b9fd393 name: morpheus-graphql-version: 0.12.0+version: 0.13.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql@@ -108,6 +108,12 @@ test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/query.gql test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/query.gql test/Feature/Holistic/selection/unknownField/query.gql+ test/Feature/Input/DefaultValue/intorspection/arguments/query.gql+ test/Feature/Input/DefaultValue/intorspection/input-compound/query.gql+ test/Feature/Input/DefaultValue/intorspection/input-simple/query.gql+ test/Feature/Input/DefaultValue/resolving/compound/query.gql+ test/Feature/Input/DefaultValue/resolving/simple/query.gql+ test/Feature/Input/DefaultValue/schema.gql test/Feature/Input/Enum/decode2Con/query.gql test/Feature/Input/Enum/decode3Con/query.gql test/Feature/Input/Enum/decodeInvalidValue/query.gql@@ -118,6 +124,10 @@ test/Feature/Input/Enum/decodeMany/con4/query.gql test/Feature/Input/Enum/decodeMany/con5/query.gql test/Feature/Input/Enum/decodeMany/con6/query.gql+ test/Feature/Input/Enum/invalidEnumFromJSONVariable/query.gql+ test/Feature/Input/Enum/invalidStringDefaultValue/query.gql+ test/Feature/Input/Enum/invalidStringInput/query.gql+ test/Feature/Input/Enum/validEnumFromJSONVariable/query.gql test/Feature/Input/Object/nullableUndefinedField/query.gql test/Feature/Input/Object/resolveObject/query.gql test/Feature/Input/Object/resolveVariable/query.gql@@ -261,6 +271,12 @@ test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json test/Feature/Holistic/selection/unknownField/response.json+ test/Feature/Input/DefaultValue/cases.json+ test/Feature/Input/DefaultValue/intorspection/arguments/response.json+ test/Feature/Input/DefaultValue/intorspection/input-compound/response.json+ test/Feature/Input/DefaultValue/intorspection/input-simple/response.json+ test/Feature/Input/DefaultValue/resolving/compound/response.json+ test/Feature/Input/DefaultValue/resolving/simple/response.json test/Feature/Input/Enum/cases.json test/Feature/Input/Enum/decode2Con/response.json test/Feature/Input/Enum/decode3Con/response.json@@ -272,6 +288,12 @@ test/Feature/Input/Enum/decodeMany/con4/response.json test/Feature/Input/Enum/decodeMany/con5/response.json test/Feature/Input/Enum/decodeMany/con6/response.json+ test/Feature/Input/Enum/invalidEnumFromJSONVariable/response.json+ test/Feature/Input/Enum/invalidEnumFromJSONVariable/variables.json+ test/Feature/Input/Enum/invalidStringDefaultValue/response.json+ test/Feature/Input/Enum/invalidStringInput/response.json+ test/Feature/Input/Enum/validEnumFromJSONVariable/response.json+ test/Feature/Input/Enum/validEnumFromJSONVariable/variables.json test/Feature/Input/Object/cases.json test/Feature/Input/Object/nullableUndefinedField/response.json test/Feature/Input/Object/resolveObject/response.json@@ -368,17 +390,17 @@ Data.Morpheus.Server.Deriving.Introspect Data.Morpheus.Server.Deriving.Resolve Data.Morpheus.Server.Deriving.Utils- Data.Morpheus.Server.Document.Compile- Data.Morpheus.Server.Document.Convert- Data.Morpheus.Server.Document.Declare- Data.Morpheus.Server.Document.Decode- Data.Morpheus.Server.Document.Encode- Data.Morpheus.Server.Document.GQLType- Data.Morpheus.Server.Document.Introspect Data.Morpheus.Server.Internal.TH.Decode- Data.Morpheus.Server.Types.GQLScalar+ Data.Morpheus.Server.Internal.TH.Types+ Data.Morpheus.Server.TH.Compile+ Data.Morpheus.Server.TH.Declare+ Data.Morpheus.Server.TH.Declare.Decode+ Data.Morpheus.Server.TH.Declare.Encode+ Data.Morpheus.Server.TH.Declare.GQLType+ Data.Morpheus.Server.TH.Declare.Introspect+ Data.Morpheus.Server.TH.Declare.Type+ Data.Morpheus.Server.TH.Transform Data.Morpheus.Server.Types.GQLType- Data.Morpheus.Server.Types.ID Data.Morpheus.Server.Types.Types Data.Morpheus.Types.Internal.Subscription.Apollo Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore@@ -393,7 +415,7 @@ , bytestring >=0.10.4 && <0.11 , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <9.0.0- , morpheus-graphql-core >=0.12.0+ , morpheus-graphql-core >=0.13.0 , mtl >=2.0 && <=3.0 , scientific >=0.3.6.2 && <0.4 , template-haskell >=2.0 && <=3.0@@ -411,6 +433,7 @@ main-is: Spec.hs other-modules: Feature.Holistic.API+ Feature.Input.DefaultValue.API Feature.Input.Enum.API Feature.Input.Object.API Feature.Input.Scalar.API@@ -441,7 +464,7 @@ , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <9.0.0 , morpheus-graphql- , morpheus-graphql-core >=0.12.0+ , morpheus-graphql-core >=0.13.0 , mtl >=2.0 && <=3.0 , scientific >=0.3.6.2 && <0.4 , tasty
src/Data/Morpheus/Document.hs view
@@ -19,11 +19,11 @@ ( RootResCon, fullSchema, )-import Data.Morpheus.Server.Document.Compile+import Data.Morpheus.Server.TH.Compile ( compileDocument, gqlDocument, )-import Data.Morpheus.Types (GQLRootResolver)+import Data.Morpheus.Types (RootResolver) import Data.Morpheus.Types.Internal.Resolving ( resultOr, )@@ -40,10 +40,10 @@ importGQLDocumentWithNamespace src = runIO (readFile src) >>= compileDocument True --- | Generates schema.gql file from 'GQLRootResolver'+-- | Generates schema.gql file from 'RootResolver' toGraphQLDocument :: RootResCon m event query mut sub =>- proxy (GQLRootResolver m event query mut sub) ->+ proxy (RootResolver m event query mut sub) -> ByteString toGraphQLDocument = resultOr (pack . show) (encodeUtf8 . LT.fromStrict . render)
src/Data/Morpheus/Server/Deriving/Decode.hs view
@@ -46,11 +46,11 @@ withObject, withUnion, )-import Data.Morpheus.Server.Types.GQLScalar+import Data.Morpheus.Server.Types.GQLType (GQLType (KIND, __typeName))+import Data.Morpheus.Types.GQLScalar ( GQLScalar (..), toScalar, )-import Data.Morpheus.Server.Types.GQLType (GQLType (KIND, __typeName)) import Data.Morpheus.Types.Internal.AST ( Argument (..), Arguments,
src/Data/Morpheus/Server/Deriving/Encode.hs view
@@ -44,7 +44,6 @@ datatypeNameProxy, isRecordProxy, )-import Data.Morpheus.Server.Types.GQLScalar (GQLScalar (..)) import Data.Morpheus.Server.Types.GQLType (GQLType (..)) import Data.Morpheus.Server.Types.Types ( MapKind,@@ -52,8 +51,9 @@ mapKindFromList, ) import Data.Morpheus.Types- ( GQLRootResolver (..),+ ( RootResolver (..), )+import Data.Morpheus.Types.GQLScalar (GQLScalar (..)) import Data.Morpheus.Types.Internal.AST ( FieldName, FieldName (..),@@ -238,10 +238,10 @@ Applicative m, Monad m ) =>- GQLRootResolver m e query mut sub ->+ RootResolver m e query mut sub -> RootResModel e m deriveModel- GQLRootResolver+ RootResolver { queryResolver, mutationResolver, subscriptionResolver
src/Data/Morpheus/Server/Deriving/Interpreter.hs view
@@ -16,7 +16,7 @@ statelessResolver, ) import Data.Morpheus.Types- ( GQLRootResolver (..),+ ( RootResolver (..), ) import Data.Morpheus.Types.IO ( GQLRequest,@@ -50,7 +50,7 @@ interpreter :: Monad m => (RootResCon m e query mut sub) =>- GQLRootResolver m e query mut sub ->+ RootResolver m e query mut sub -> a -> b
src/Data/Morpheus/Server/Deriving/Introspect.hs view
@@ -22,12 +22,14 @@ ( TypeUpdater, Introspect (..), DeriveTypeContent (..),+ introspectOUT, IntroCon, updateLib, buildType, introspectObjectFields, deriveCustomInputObjectType, TypeScope (..),+ ProxyRep (..), ) where @@ -55,25 +57,24 @@ isRecordProxy, selNameProxy, )-import Data.Morpheus.Server.Types.GQLScalar (GQLScalar (..)) import Data.Morpheus.Server.Types.GQLType (GQLType (..)) import Data.Morpheus.Server.Types.Types ( MapKind, Pair, )+import Data.Morpheus.Types.GQLScalar (GQLScalar (..)) import Data.Morpheus.Types.Internal.AST- ( ANY,- ArgumentsDefinition (..),+ ( ArgumentsDefinition (..), DataFingerprint (..), DataUnion, FALSE,+ FieldContent (..), FieldDefinition (..), FieldName, FieldName (..), FieldsDefinition, IN, Message,- Meta (..), OUT, TRUE, TypeCategory,@@ -82,13 +83,14 @@ TypeName (..), TypeRef (..), TypeUpdater,+ UnionMember (..), createAlias, createEnumValue, defineType, fieldsToArguments,+ mkField,+ mkUnionMember, msg,- toAny,- toAny, toListField, toNullableField, unsafeFromFields,@@ -107,83 +109,90 @@ ) import GHC.Generics -type IntroCon a = (GQLType a, DeriveTypeContent (CUSTOM a) a)+type IntroCon a = (GQLType a, DeriveTypeContent OUT (CUSTOM a) a) +data ProxyRep (cat :: TypeCategory) a+ = ProxyRep++introspectOUT :: forall a. (GQLType a, Introspect OUT a) => Proxy a -> TypeUpdater+introspectOUT _ = introspect (ProxyRep :: ProxyRep OUT a)++instance {-# OVERLAPPABLE #-} (GQLType a, IntrospectKind (KIND a) a) => Introspect cat a where+ introspect _ = introspectKind (Context :: Context (KIND a) a)+ -- | Generates internal GraphQL Schema for query validation and introspection rendering-class Introspect a where- isObject :: proxy a -> Bool- default isObject :: GQLType a => proxy a -> Bool+class Introspect (cat :: TypeCategory) a where+ introspect :: proxy cat a -> TypeUpdater+ isObject :: proxy cat a -> Bool+ default isObject :: GQLType a => proxy cat a -> Bool isObject _ = isObjectKind (Proxy @a)- field :: proxy a -> FieldName -> FieldDefinition cat- introspect :: proxy a -> TypeUpdater-+ field :: proxy cat a -> FieldName -> FieldDefinition cat ----------------------------------------------- default field :: GQLType a =>- proxy a ->+ proxy cat a -> FieldName -> FieldDefinition cat- field _ = buildField (Proxy @a) NoArguments--instance {-# OVERLAPPABLE #-} (GQLType a, IntrospectKind (KIND a) a) => Introspect a where- introspect _ = introspectKind (Context :: Context (KIND a) a)+ field _ = buildField (Proxy @a) Nothing -- Maybe-instance Introspect a => Introspect (Maybe a) where+instance Introspect cat a => Introspect cat (Maybe a) where isObject _ = False- field _ = toNullableField . field (Proxy @a)- introspect _ = introspect (Proxy @a)+ field _ = toNullableField . field (ProxyRep :: ProxyRep cat a)+ introspect _ = introspect (ProxyRep :: ProxyRep cat a) -- List-instance Introspect a => Introspect [a] where+instance Introspect cat a => Introspect cat [a] where isObject _ = False- field _ = toListField . field (Proxy @a)- introspect _ = introspect (Proxy @a)+ field _ = toListField . field (ProxyRep :: ProxyRep cat a)+ introspect _ = introspect (ProxyRep :: ProxyRep cat a) -- Tuple-instance Introspect (Pair k v) => Introspect (k, v) where+instance Introspect cat (Pair k v) => Introspect cat (k, v) where isObject _ = True- field _ = field (Proxy @(Pair k v))- introspect _ = introspect (Proxy @(Pair k v))+ field _ = field (ProxyRep :: ProxyRep cat (Pair k v))+ introspect _ = introspect (ProxyRep :: ProxyRep cat (Pair k v)) -- Set-instance Introspect [a] => Introspect (Set a) where+instance Introspect cat [a] => Introspect cat (Set a) where isObject _ = False- field _ = field (Proxy @[a])- introspect _ = introspect (Proxy @[a])+ field _ = field (ProxyRep :: ProxyRep cat [a])+ introspect _ = introspect (ProxyRep :: ProxyRep cat [a]) -- Map-instance Introspect (MapKind k v Maybe) => Introspect (Map k v) where+instance Introspect cat (MapKind k v Maybe) => Introspect cat (Map k v) where isObject _ = True- field _ = field (Proxy @(MapKind k v Maybe))- introspect _ = introspect (Proxy @(MapKind k v Maybe))+ field _ = field (ProxyRep :: ProxyRep cat (MapKind k v Maybe))+ introspect _ = introspect (ProxyRep :: ProxyRep cat (MapKind k v Maybe)) -- Resolver : a -> Resolver b-instance (GQLType b, DeriveTypeContent 'False a, Introspect b) => Introspect (a -> m b) where+instance (GQLType b, DeriveTypeContent IN 'False a, Introspect OUT b) => Introspect OUT (a -> m b) where isObject _ = False- field _ name = fieldObj {fieldArgs}+ field _ name = fieldObj {fieldContent = Just (FieldArgs fieldArgs)} where- fieldObj = field (Proxy @b) name+ fieldObj = field (ProxyRep :: ProxyRep OUT b) name+ fieldArgs :: ArgumentsDefinition fieldArgs =- fieldsToArguments $ mockFieldsDefinition $ fst $- introspectObjectFields+ fieldsToArguments+ $ fst+ $ introspectInputObjectFields (Proxy :: Proxy 'False)- (__typeName (Proxy @b), InputType, Proxy @a)+ (__typeName (Proxy @b), Proxy @a) introspect _ typeLib = resolveUpdates typeLib- (introspect (Proxy @b) : inputs)+ (introspect (ProxyRep :: ProxyRep OUT b) : inputs) where name = "Arguments for " <> __typeName (Proxy @b) inputs :: [TypeUpdater] inputs =- snd $ introspectObjectFields (Proxy :: Proxy 'False) (name, InputType, Proxy @a)+ snd $ introspectInputObjectFields (Proxy :: Proxy 'False) (name, Proxy @a) -- GQL Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance (GQLType b, Introspect b) => Introspect (Resolver fo e m b) where+instance (GQLType b, Introspect cat b) => Introspect cat (Resolver fo e m b) where isObject _ = False- field _ = field (Proxy @b)- introspect _ = introspect (Proxy @b)+ field _ = field (ProxyRep :: ProxyRep cat b)+ introspect _ = introspect (ProxyRep :: ProxyRep cat b) -- | Introspect With specific Kind: 'kind': object, scalar, enum ... class IntrospectKind (kind :: GQL_KIND) a where@@ -202,24 +211,24 @@ enumType = buildType $ DataEnum $ map (createEnumValue . TypeName) $ enumTags (Proxy @(Rep a)) -instance (GQL_TYPE a, DeriveTypeContent (CUSTOM a) a) => IntrospectKind INPUT a where+instance (GQL_TYPE a, DeriveTypeContent IN (CUSTOM a) a) => IntrospectKind INPUT a where introspectKind _ = derivingData (Proxy @a) InputType -instance (GQL_TYPE a, DeriveTypeContent (CUSTOM a) a) => IntrospectKind OUTPUT a where+instance (GQL_TYPE a, DeriveTypeContent OUT (CUSTOM a) a) => IntrospectKind OUTPUT a where introspectKind _ = derivingData (Proxy @a) OutputType -instance (GQL_TYPE a, DeriveTypeContent (CUSTOM a) a) => IntrospectKind INTERFACE a where- introspectKind _ = updateLib (buildType (DataInterface (mockFieldsDefinition fields) :: TypeContent TRUE OUT)) types (Proxy @a)+instance (GQL_TYPE a, DeriveTypeContent OUT (CUSTOM a) a) => IntrospectKind INTERFACE a where+ introspectKind _ = updateLibOUT (buildType (DataInterface fields)) types (Proxy @a) where (fields, types) = introspectObjectFields (Proxy @(CUSTOM a))- (baseName, OutputType, Proxy @a)+ (baseName, Proxy @a) baseName = __typeName (Proxy @a) derivingData :: forall a cat.- (GQLType a, DeriveTypeContent (CUSTOM a) a) =>+ (GQLType a, DeriveTypeContent cat (CUSTOM a) a) => Proxy a -> TypeScope cat -> TypeUpdater@@ -235,56 +244,65 @@ type GQL_TYPE a = (Generic a, GQLType a) deriveCustomInputObjectType ::- DeriveTypeContent TRUE a =>+ DeriveTypeContent IN TRUE a => (TypeName, proxy a) -> TypeUpdater deriveCustomInputObjectType (name, proxy) = flip resolveUpdates- (deriveCustomObjectType (name, InputType, proxy))+ (snd $ introspectInputObjectFields (Proxy :: Proxy TRUE) (name, proxy)) -deriveCustomObjectType ::- DeriveTypeContent TRUE a =>- (TypeName, TypeScope cat, proxy a) ->- [TypeUpdater]-deriveCustomObjectType = snd . introspectObjectFields (Proxy :: Proxy TRUE)+introspectInputObjectFields ::+ DeriveTypeContent IN custom a =>+ proxy1 (custom :: Bool) ->+ (TypeName, proxy2 a) ->+ (FieldsDefinition IN, [TypeUpdater])+introspectInputObjectFields p1 (name, proxy) =+ withObject (deriveTypeContent p1 (proxy, ([], []), InputType, "", DataFingerprint "" []))+ where+ withObject (DataInputObject {inputObjectFields}, ts) = (inputObjectFields, ts)+ withObject _ = (empty, [introspectFailure (msg name <> " should have only one nonempty constructor")]) introspectObjectFields ::- DeriveTypeContent custom a =>+ DeriveTypeContent OUT custom a => proxy1 (custom :: Bool) ->- (TypeName, TypeScope cat, proxy2 a) ->- (FieldsDefinition cat, [TypeUpdater])-introspectObjectFields p1 (name, scope, proxy) =- withObject name (deriveTypeContent p1 (proxy, ([], []), scope, "", DataFingerprint "" []))--withObject :: TypeName -> (TypeContent TRUE (cat :: TypeCategory), [TypeUpdater]) -> (FieldsDefinition cat2, [TypeUpdater])-withObject _ (DataObject {objectFields}, ts) = (mockFieldsDefinition objectFields, ts)-withObject _ (DataInputObject {inputObjectFields}, ts) = (mockFieldsDefinition inputObjectFields, ts)-withObject name _ = (empty, [introspectFailure (msg name <> " should have only one nonempty constructor")])+ (TypeName, proxy2 a) ->+ (FieldsDefinition OUT, [TypeUpdater])+introspectObjectFields p1 (name, proxy) =+ withObject (deriveTypeContent p1 (proxy, ([], []), OutputType, "", DataFingerprint "" []))+ where+ withObject (DataObject {objectFields}, ts) = (objectFields, ts)+ withObject _ = (empty, [introspectFailure (msg name <> " should have only one nonempty constructor")]) introspectFailure :: Message -> TypeUpdater introspectFailure = const . failure . globalErrorMessage . ("invalid schema: " <>) -- Object Fields-class DeriveTypeContent (custom :: Bool) a where- deriveTypeContent :: proxy1 custom -> (proxy2 a, ([TypeName], [TypeUpdater]), TypeScope cat, TypeName, DataFingerprint) -> (TypeContent TRUE ANY, [TypeUpdater])+class DeriveTypeContent cat (custom :: Bool) a where+ deriveTypeContent :: proxy1 custom -> (proxy2 a, ([TypeName], [TypeUpdater]), TypeScope cat, TypeName, DataFingerprint) -> (TypeContent TRUE cat, [TypeUpdater]) -instance (TypeRep (Rep a), Generic a) => DeriveTypeContent FALSE a where+instance (TypeRep cat (Rep a), Generic a) => DeriveTypeContent cat FALSE a where deriveTypeContent _ (_, interfaces, scope, baseName, baseFingerprint) =- fa $ builder $ typeRep $ Proxy @(Rep a)+ builder $ typeRep (ProxyRep :: ProxyRep cat (Rep a)) where- fa (x, y) = (toAny x, y) builder [ConsRep {consFields}] = buildObject interfaces scope consFields builder cons = genericUnion scope cons where genericUnion InputType = buildInputUnion (baseName, baseFingerprint) genericUnion OutputType = buildUnionType (baseName, baseFingerprint) DataUnion (DataObject []) -buildField :: GQLType a => Proxy a -> ArgumentsDefinition -> FieldName -> FieldDefinition cat-buildField proxy fieldArgs fieldName =+buildField ::+ GQLType a =>+ Proxy a ->+ Maybe (FieldContent TRUE cat) ->+ FieldName ->+ FieldDefinition cat+buildField proxy fieldContent fieldName = FieldDefinition- { fieldType = createAlias $ __typeName proxy,- fieldMeta = Nothing,+ { fieldType = createAlias (__typeName proxy),+ fieldDescription = Nothing,+ fieldDirectives = empty,+ fieldContent = fieldContent, .. } @@ -293,12 +311,8 @@ TypeDefinition { typeName = __typeName proxy, typeFingerprint = __typeFingerprint proxy,- typeMeta =- Just- Meta- { metaDescription = description proxy,- metaDirectives = []- },+ typeDescription = description proxy,+ typeDirectives = [], typeContent } @@ -310,37 +324,45 @@ TypeUpdater updateLib f stack proxy = updateSchema (__typeName proxy) (__typeFingerprint proxy) stack f proxy +updateLibOUT ::+ GQLType a =>+ (Proxy a -> TypeDefinition OUT) ->+ [TypeUpdater] ->+ Proxy a ->+ TypeUpdater+updateLibOUT f stack proxy = updateSchema (__typeName proxy) (__typeFingerprint proxy) stack f proxy+ -- NEW AUTOMATIC DERIVATION SYSTEM -data ConsRep = ConsRep+data ConsRep cat = ConsRep { consName :: TypeName, consIsRecord :: Bool,- consFields :: [FieldRep]+ consFields :: [FieldRep cat] } -data FieldRep = FieldRep+data FieldRep cat = FieldRep { fieldTypeName :: TypeName,- fieldData :: FieldDefinition ANY,+ fieldData :: FieldDefinition cat, fieldTypeUpdater :: TypeUpdater, fieldIsObject :: Bool } -data ResRep = ResRep+data ResRep cat = ResRep { enumCons :: [TypeName], unionRef :: [TypeName],- unionRecordRep :: [ConsRep]+ unionRecordRep :: [ConsRep cat] } -isEmpty :: ConsRep -> Bool+isEmpty :: ConsRep cat -> Bool isEmpty ConsRep {consFields = []} = True isEmpty _ = False -isUnionRef :: TypeName -> ConsRep -> Bool+isUnionRef :: TypeName -> ConsRep cat -> Bool isUnionRef baseName ConsRep {consName, consFields = [FieldRep {fieldIsObject = True, fieldTypeName}]} = consName == baseName <> fieldTypeName isUnionRef _ _ = False -setFieldNames :: ConsRep -> ConsRep+setFieldNames :: ConsRep cat -> ConsRep cat setFieldNames cons@ConsRep {consFields} = cons { consFields = zipWith setFieldName ([0 ..] :: [Int]) consFields@@ -350,7 +372,7 @@ where fieldName = FieldName ("_" <> pack (show i)) -analyseRep :: TypeName -> [ConsRep] -> ResRep+analyseRep :: TypeName -> [ConsRep cat] -> ResRep cat analyseRep baseName cons = ResRep { enumCons = map consName enumRep,@@ -363,20 +385,19 @@ (unionRecordRep, anyonimousUnionRep) = partition consIsRecord left2 buildInputUnion ::- (TypeName, DataFingerprint) -> [ConsRep] -> (TypeContent TRUE IN, [TypeUpdater])+ (TypeName, DataFingerprint) -> [ConsRep IN] -> (TypeContent TRUE IN, [TypeUpdater]) buildInputUnion (baseName, baseFingerprint) cons = datatype (analyseRep baseName cons) where- datatype :: ResRep -> (TypeContent TRUE IN, [TypeUpdater])+ datatype :: ResRep IN -> (TypeContent TRUE IN, [TypeUpdater]) datatype ResRep {unionRef = [], unionRecordRep = [], enumCons} = (DataEnum (map createEnumValue enumCons), types) datatype ResRep {unionRef, unionRecordRep, enumCons} = (DataInputUnion typeMembers, types <> unionTypes) where- typeMembers :: [(TypeName, Bool)]- typeMembers =- map (,True) (unionRef <> unionMembers) <> map (,False) enumCons+ typeMembers :: [UnionMember IN]+ typeMembers = map mkUnionMember (unionRef <> unionMembers) <> map (`UnionMember` False) enumCons (unionMembers, unionTypes) = buildUnions wrapInputObject baseFingerprint unionRecordRep types = map fieldTypeUpdater $ concatMap consFields cons@@ -387,7 +408,7 @@ (TypeName, DataFingerprint) -> (DataUnion -> TypeContent TRUE cat) -> (FieldsDefinition cat -> TypeContent TRUE cat) ->- [ConsRep] ->+ [ConsRep cat] -> (TypeContent TRUE cat, [TypeUpdater]) buildUnionType (baseName, baseFingerprint) wrapUnion wrapObject cons = datatype@@ -397,7 +418,7 @@ datatype ResRep {unionRef = [], unionRecordRep = [], enumCons} = (DataEnum (map createEnumValue enumCons), types) datatype ResRep {unionRef, unionRecordRep, enumCons} =- (wrapUnion typeMembers, types <> enumTypes <> unionTypes)+ (wrapUnion (map mkUnionMember typeMembers), types <> enumTypes <> unionTypes) where typeMembers = unionRef <> enumMembers <> unionMembers (enumMembers, enumTypes) =@@ -406,9 +427,9 @@ buildUnions wrapObject baseFingerprint unionRecordRep types = map fieldTypeUpdater $ concatMap consFields cons -buildObject :: ([TypeName], [TypeUpdater]) -> TypeScope cat -> [FieldRep] -> (TypeContent TRUE cat, [TypeUpdater])+buildObject :: ([TypeName], [TypeUpdater]) -> TypeScope cat -> [FieldRep cat] -> (TypeContent TRUE cat, [TypeUpdater]) buildObject (interfaces, interfaceTypes) scope consFields =- ( wrapWith scope (mockFieldsDefinition fields),+ ( wrapWith scope fields, types <> interfaceTypes ) where@@ -418,7 +439,7 @@ wrapWith InputType = DataInputObject wrapWith OutputType = DataObject interfaces -buildDataObject :: [FieldRep] -> (FieldsDefinition ANY, [TypeUpdater])+buildDataObject :: [FieldRep cat] -> (FieldsDefinition cat, [TypeUpdater]) buildDataObject consFields = (fields, types) where fields = unsafeFromFields $ map fieldData consFields@@ -427,7 +448,7 @@ buildUnions :: (FieldsDefinition cat -> TypeContent TRUE cat) -> DataFingerprint ->- [ConsRep] ->+ [ConsRep cat] -> ([TypeName], [TypeUpdater]) buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons) where@@ -437,22 +458,16 @@ (buildUnionRecord wrapObject baseFingerprint consRep) members = map consName cons -mockFieldsDefinition :: FieldsDefinition a -> FieldsDefinition b-mockFieldsDefinition = fmap mockFieldDefinition--mockFieldDefinition :: FieldDefinition a -> FieldDefinition b-mockFieldDefinition FieldDefinition {..} = FieldDefinition {..}- buildUnionRecord ::- (FieldsDefinition cat -> TypeContent TRUE cat) -> DataFingerprint -> ConsRep -> TypeDefinition cat+ (FieldsDefinition cat -> TypeContent TRUE cat) -> DataFingerprint -> ConsRep cat -> TypeDefinition cat buildUnionRecord wrapObject typeFingerprint ConsRep {consName, consFields} = TypeDefinition { typeName = consName, typeFingerprint,- typeMeta = Nothing,+ typeDescription = Nothing,+ typeDirectives = empty, typeContent = wrapObject- $ mockFieldsDefinition $ unsafeFromFields $ map fieldData consFields }@@ -489,7 +504,8 @@ pure . defineType TypeDefinition- { typeMeta = Nothing,+ { typeDescription = Nothing,+ typeDirectives = empty, typeContent = DataEnum $ map createEnumValue tags, .. }@@ -506,16 +522,12 @@ TypeDefinition { typeName, typeFingerprint,- typeMeta = Nothing,+ typeDescription = Nothing,+ typeDirectives = empty, typeContent = wrapObject $ singleton- FieldDefinition- { fieldName = "enum",- fieldArgs = NoArguments,- fieldType = createAlias enumTypeName,- fieldMeta = Nothing- }+ (mkField "enum" ([], enumTypeName)) } data TypeScope (cat :: TypeCategory) where@@ -529,44 +541,44 @@ deriving instance Ord (TypeScope cat) -- GENERIC UNION-class TypeRep f where- typeRep :: Proxy f -> [ConsRep]+class TypeRep (cat :: TypeCategory) f where+ typeRep :: ProxyRep cat f -> [ConsRep cat] -instance TypeRep f => TypeRep (M1 D d f) where- typeRep _ = typeRep (Proxy @f)+instance TypeRep cat f => TypeRep cat (M1 D d f) where+ typeRep _ = typeRep (ProxyRep :: ProxyRep cat f) -- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'-instance (TypeRep a, TypeRep b) => TypeRep (a :+: b) where- typeRep _ = typeRep (Proxy @a) <> typeRep (Proxy @b)+instance (TypeRep cat a, TypeRep cat b) => TypeRep cat (a :+: b) where+ typeRep _ = typeRep (ProxyRep :: ProxyRep cat a) <> typeRep (ProxyRep :: ProxyRep cat b) -instance (ConRep f, Constructor c) => TypeRep (M1 C c f) where+instance (ConRep cat f, Constructor c) => TypeRep cat (M1 C c f) where typeRep _ = [ ConsRep { consName = conNameProxy (Proxy @c),- consFields = conRep (Proxy @f),+ consFields = conRep (ProxyRep :: ProxyRep cat f), consIsRecord = isRecordProxy (Proxy @c) } ] -class ConRep f where- conRep :: Proxy f -> [FieldRep]+class ConRep cat f where+ conRep :: ProxyRep cat f -> [FieldRep cat] -- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION'-instance (ConRep a, ConRep b) => ConRep (a :*: b) where- conRep _ = conRep (Proxy @a) <> conRep (Proxy @b)+instance (ConRep cat a, ConRep cat b) => ConRep cat (a :*: b) where+ conRep _ = conRep (ProxyRep :: ProxyRep cat a) <> conRep (ProxyRep :: ProxyRep cat b) -instance (Selector s, Introspect a) => ConRep (M1 S s (Rec0 a)) where+instance (Selector s, Introspect cat a) => ConRep cat (M1 S s (Rec0 a)) where conRep _ = [ FieldRep { fieldTypeName = typeConName $ fieldType fieldData, fieldData = fieldData,- fieldTypeUpdater = introspect (Proxy @a),- fieldIsObject = isObject (Proxy @a)+ fieldTypeUpdater = introspect (ProxyRep :: ProxyRep cat a),+ fieldIsObject = isObject (ProxyRep :: ProxyRep cat a) } ] where name = selNameProxy (Proxy @s)- fieldData = field (Proxy @a) name+ fieldData = field (ProxyRep :: ProxyRep cat a) name -instance ConRep U1 where+instance ConRep cat U1 where conRep _ = []
src/Data/Morpheus/Server/Deriving/Resolve.hs view
@@ -22,18 +22,20 @@ import Data.Morpheus.Core ( runApi, )+import Data.Morpheus.Internal.Utils+ ( empty,+ ) import Data.Morpheus.Server.Deriving.Encode ( EncodeCon, deriveModel, ) import Data.Morpheus.Server.Deriving.Introspect ( IntroCon,- TypeScope (..), introspectObjectFields, ) import Data.Morpheus.Server.Types.GQLType (GQLType (CUSTOM)) import Data.Morpheus.Types- ( GQLRootResolver (..),+ ( RootResolver (..), ) import Data.Morpheus.Types.IO ( GQLRequest (..),@@ -90,7 +92,7 @@ statelessResolver :: (Monad m, RootResCon m event query mut sub) =>- GQLRootResolver m event query mut sub ->+ RootResolver m event query mut sub -> GQLRequest -> m GQLResponse statelessResolver root req =@@ -99,7 +101,7 @@ coreResolver :: forall event m query mut sub. (Monad m, RootResCon m event query mut sub) =>- GQLRootResolver m event query mut sub ->+ RootResolver m event query mut sub -> GQLRequest -> ResponseStream event m ValidValue coreResolver root request =@@ -115,7 +117,7 @@ fullSchema :: forall proxy m event query mutation subscription. (IntrospectConstraint m event query mutation subscription) =>- proxy (GQLRootResolver m event query mutation subscription) ->+ proxy (RootResolver m event query mutation subscription) -> Eventless Schema fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema where@@ -125,7 +127,7 @@ (fields, types) = introspectObjectFields (Proxy @(CUSTOM (query (Resolver QUERY event m))))- ("type for query", OutputType, Proxy @(query (Resolver QUERY event m)))+ ("type for query", Proxy @(query (Resolver QUERY event m))) ------------------------------ mutationSchema lib = resolveUpdates@@ -136,7 +138,6 @@ introspectObjectFields (Proxy @(CUSTOM (mutation (Resolver MUTATION event m)))) ( "type for mutation",- OutputType, Proxy @(mutation (Resolver MUTATION event m)) ) ------------------------------@@ -149,7 +150,6 @@ introspectObjectFields (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION event m)))) ( "type for subscription",- OutputType, Proxy @(subscription (Resolver SUBSCRIPTION event m)) ) maybeOperator :: FieldsDefinition OUT -> TypeName -> Maybe (TypeDefinition OUT)@@ -163,5 +163,6 @@ { typeContent = DataObject [] fields, typeName, typeFingerprint = DataFingerprint typeName [],- typeMeta = Nothing+ typeDescription = Nothing,+ typeDirectives = empty }
− src/Data/Morpheus/Server/Document/Compile.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Server.Document.Compile- ( compileDocument,- gqlDocument,- gqlDocumentNamespace,- )-where------- Morpheus--import Data.Morpheus.Core- ( parseTypeDefinitions,- )-import Data.Morpheus.Error- ( gqlWarnings,- renderGQLErrors,- )-import Data.Morpheus.Server.Document.Convert- ( toTHDefinitions,- )-import Data.Morpheus.Server.Document.Declare- ( declare,- )-import Data.Morpheus.Types.Internal.Resolving- ( Result (..),- )-import qualified Data.Text as T- ( pack,- )-import Language.Haskell.TH-import Language.Haskell.TH.Quote--gqlDocumentNamespace :: QuasiQuoter-gqlDocumentNamespace =- QuasiQuoter- { quoteExp = notHandled "Expressions",- quotePat = notHandled "Patterns",- quoteType = notHandled "Types",- quoteDec = compileDocument True- }- where- notHandled things =- error $ things ++ " are not supported by the GraphQL QuasiQuoter"--gqlDocument :: QuasiQuoter-gqlDocument =- QuasiQuoter- { quoteExp = notHandled "Expressions",- quotePat = notHandled "Patterns",- quoteType = notHandled "Types",- quoteDec = compileDocument False- }- where- notHandled things =- error $ things ++ " are not supported by the GraphQL QuasiQuoter"--compileDocument :: Bool -> String -> Q [Dec]-compileDocument namespace documentTXT =- case parseTypeDefinitions (T.pack documentTXT) of- Failure errors -> fail (renderGQLErrors errors)- Success {result = schema, warnings} ->- gqlWarnings warnings >> toTHDefinitions namespace schema >>= declare namespace
− src/Data/Morpheus/Server/Document/Convert.hs
@@ -1,205 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module Data.Morpheus.Server.Document.Convert- ( toTHDefinitions,- )-where---- MORPHEUS-import Data.Morpheus.Internal.TH- ( infoTyVars,- mkTypeName,- )-import Data.Morpheus.Internal.Utils- ( capitalTypeName,- elems,- singleton,- )-import Data.Morpheus.Types.Internal.AST- ( ANY,- ArgumentsDefinition (..),- ConsD,- DataTypeKind (..),- FieldDefinition (..),- FieldName,- FieldsDefinition,- GQLTypeD (..),- OUT,- TRUE,- TypeContent (..),- TypeD (..),- TypeDefinition (..),- TypeName,- TypeRef (..),- argumentsToFields,- hasArguments,- hsTypeName,- kindOf,- lookupWith,- mkCons,- mkConsEnum,- toFieldName,- )-import Data.Semigroup ((<>))-import Language.Haskell.TH--m_ :: TypeName-m_ = "m"--getTypeArgs :: TypeName -> [TypeDefinition ANY] -> Q (Maybe TypeName)-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 <$> lookupWith typeName key lib of- Just x -> pure (kindToTyArgs x)- Nothing -> getTyArgs <$> reify (mkTypeName key)--getTyArgs :: Info -> Maybe TypeName-getTyArgs x- | null (infoTyVars x) = Nothing- | otherwise = Just m_--kindToTyArgs :: TypeContent TRUE ANY -> Maybe TypeName-kindToTyArgs DataObject {} = Just m_-kindToTyArgs DataUnion {} = Just m_-kindToTyArgs DataInterface {} = Just m_-kindToTyArgs _ = Nothing--toTHDefinitions :: Bool -> [TypeDefinition ANY] -> Q [GQLTypeD]-toTHDefinitions namespace lib = traverse renderTHType lib- where- renderTHType :: TypeDefinition ANY -> Q GQLTypeD- renderTHType x = generateType x- where- genArgsTypeName :: FieldName -> TypeName- genArgsTypeName fieldName- | namespace = hsTypeName (typeName x) <> argTName- | otherwise = argTName- where- argTName = capitalTypeName (fieldName <> "Args")- ---------------------------------------------------------------------------------------------- genResField :: FieldDefinition OUT -> Q (FieldDefinition OUT)- genResField field@FieldDefinition {fieldName, fieldArgs, fieldType = typeRef@TypeRef {typeConName}} =- do- typeArgs <- getTypeArgs typeConName lib- pure $- field- { fieldType = typeRef {typeConName = hsTypeName typeConName, typeArgs},- fieldArgs = fieldArguments- }- where- fieldArguments- | hasArguments fieldArgs = fieldArgs {argumentsTypename = Just $ genArgsTypeName fieldName}- | otherwise = fieldArgs- --------------------------------------------- generateType :: TypeDefinition ANY -> Q GQLTypeD- generateType typeOriginal@TypeDefinition {typeName, typeContent, typeMeta} =- genType- typeContent- where- buildType :: [ConsD] -> TypeD- buildType tCons =- TypeD- { tName = hsTypeName typeName,- tMeta = typeMeta,- tNamespace = [],- tCons,- tKind- }- buildObjectCons :: FieldsDefinition cat -> [ConsD]- buildObjectCons fields = [mkCons typeName fields]- tKind = kindOf typeOriginal- genType :: TypeContent TRUE ANY -> Q GQLTypeD- genType (DataEnum tags) =- pure- GQLTypeD- { typeD =- TypeD- { tName = hsTypeName typeName,- tNamespace = [],- tCons = map mkConsEnum tags,- tMeta = typeMeta,- tKind- },- typeArgD = [],- ..- }- genType DataScalar {} = fail "Scalar Types should defined By Native Haskell Types"- genType DataInputUnion {} = fail "Input Unions not Supported"- genType DataInterface {interfaceFields} = do- typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) (elems interfaceFields)- objCons <- buildObjectCons <$> traverse genResField interfaceFields- pure- GQLTypeD- { typeD = buildType objCons,- typeArgD,- ..- }- genType (DataInputObject fields) =- pure- GQLTypeD- { typeD = buildType $ buildObjectCons fields,- typeArgD = [],- ..- }- genType DataObject {objectFields} = do- typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) (elems objectFields)- objCons <- buildObjectCons <$> traverse genResField objectFields- pure- GQLTypeD- { typeD = buildType objCons,- typeArgD,- ..- }- genType (DataUnion members) =- pure- GQLTypeD- { typeD = buildType (map unionCon members),- typeArgD = [],- ..- }- where- unionCon memberName =- mkCons- cName- ( singleton- FieldDefinition- { fieldName = "un" <> toFieldName cName,- fieldType =- TypeRef- { typeConName = utName,- typeArgs = Just m_,- typeWrappers = []- },- fieldMeta = Nothing,- fieldArgs = NoArguments- }- )- where- cName = hsTypeName typeName <> utName- utName = hsTypeName memberName--genArgumentType :: (FieldName -> TypeName) -> FieldDefinition OUT -> Q [TypeD]-genArgumentType _ FieldDefinition {fieldArgs = NoArguments} = pure []-genArgumentType namespaceWith FieldDefinition {fieldName, fieldArgs} =- pure- [ TypeD- { tName,- tNamespace = [],- tCons =- [ mkCons tName (argumentsToFields fieldArgs)- ],- tMeta = Nothing,- tKind = KindInputObject- }- ]- where- tName = hsTypeName (namespaceWith fieldName)
− src/Data/Morpheus/Server/Document/Declare.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Server.Document.Declare- ( declare,- )-where---- MORPHEUS--import Data.Morpheus.Internal.TH- ( Scope (..),- declareType,- )-import Data.Morpheus.Server.Document.Decode- ( deriveDecode,- )-import Data.Morpheus.Server.Document.Encode- ( deriveEncode,- )-import Data.Morpheus.Server.Document.GQLType- ( deriveGQLType,- )-import Data.Morpheus.Server.Document.Introspect- ( deriveObjectRep,- instanceIntrospect,- )-import Data.Morpheus.Types.Internal.AST- ( GQLTypeD (..),- TypeD (..),- isInput,- isObject,- )-import Data.Semigroup ((<>))-import Language.Haskell.TH--class Declare a where- type DeclareCtx a :: *- declare :: DeclareCtx a -> a -> Q [Dec]--instance Declare a => Declare [a] where- type DeclareCtx [a] = DeclareCtx a- declare namespace = fmap concat . traverse (declare namespace)--instance Declare GQLTypeD where- type DeclareCtx GQLTypeD = Bool- declare namespace gqlType@GQLTypeD {typeD = typeD@TypeD {tKind}, typeArgD, typeOriginal} =- do- mainType <- declareMainType- argTypes <- declareArgTypes- gqlInstances <- deriveGQLInstances- typeClasses <- deriveGQLType gqlType- introspectEnum <- instanceIntrospect typeOriginal- pure $ mainType <> typeClasses <> argTypes <> gqlInstances <> introspectEnum- where- deriveGQLInstances = concat <$> sequence gqlInstances- where- gqlInstances- | isObject tKind && isInput tKind =- [deriveObjectRep (typeD, Just typeOriginal, Nothing), deriveDecode typeD]- | isObject tKind =- [deriveObjectRep (typeD, Just typeOriginal, Just tKind), deriveEncode typeD]- | otherwise =- []- --------------------------------------------------- declareArgTypes = do- introspectArgs <- concat <$> traverse deriveArgsRep typeArgD- decodeArgs <- concat <$> traverse deriveDecode typeArgD- return $ argsTypeDecs <> decodeArgs <> introspectArgs- where- deriveArgsRep args = deriveObjectRep (args, Nothing, Nothing)- ----------------------------------------------------- argsTypeDecs = map (declareType SERVER namespace Nothing []) typeArgD- --------------------------------------------------- declareMainType = declareT- where- declareT =- pure [declareType SERVER namespace (Just tKind) derivingClasses typeD]- derivingClasses- | isInput tKind = [''Show]- | otherwise = []
− src/Data/Morpheus/Server/Document/Decode.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Server.Document.Decode- ( deriveDecode,- )-where------- MORPHEUS--import Data.Morpheus.Internal.TH- ( instanceHeadT,- nameVarP,- )-import Data.Morpheus.Server.Deriving.Decode- ( Decode (..),- DecodeType (..),- )-import Data.Morpheus.Server.Internal.TH.Decode- ( decodeFieldWith,- decodeObjectExpQ,- withObject,- )-import Data.Morpheus.Types.Internal.AST- ( FieldName,- TypeD (..),- ValidValue,- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless,- )-import Language.Haskell.TH--(.:) :: Decode a => ValidValue -> FieldName -> Eventless a-value .: selectorName = withObject (decodeFieldWith decode selectorName) value--deriveDecode :: TypeD -> Q [Dec]-deriveDecode TypeD {tName, tCons = [cons]} =- pure <$> instanceD (cxt []) appHead methods- where- appHead = instanceHeadT ''DecodeType tName []- methods = [funD 'decodeType [clause argsE (normalB body) []]]- where- argsE = map nameVarP ["o"]- body = decodeObjectExpQ [|(.:)|] cons-deriveDecode _ = pure []
− src/Data/Morpheus/Server/Document/Encode.hs
@@ -1,131 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Server.Document.Encode- ( deriveEncode,- )-where------- MORPHEUS--import Data.Morpheus.Internal.TH- ( applyT,- destructRecord,- instanceHeadMultiT,- mkTypeName,- nameStringE,- nameVarE,- nameVarP,- nameVarT,- typeT,- )-import Data.Morpheus.Server.Deriving.Encode- ( Encode (..),- ExploreResolvers (..),- )-import Data.Morpheus.Server.Types.GQLType (TRUE)-import Data.Morpheus.Types.Internal.AST- ( ConsD (..),- FieldDefinition (..),- QUERY,- SUBSCRIPTION,- TypeD (..),- TypeName (..),- isSubscription,- )-import Data.Morpheus.Types.Internal.Resolving- ( LiftOperation,- MapStrategy (..),- ObjectResModel (..),- ResModel (..),- Resolver,- )-import Data.Semigroup ((<>))-import Data.Typeable (Typeable)-import Language.Haskell.TH--m_ :: TypeName-m_ = "m"--fo_ :: TypeName-fo_ = "fieldOperationKind"--po_ :: TypeName-po_ = "parentOparation"--e_ :: TypeName-e_ = "encodeEvent"--encodeVars :: [TypeName]-encodeVars = [e_, m_]--encodeVarsT :: [TypeQ]-encodeVarsT = map nameVarT encodeVars--deriveEncode :: TypeD -> Q [Dec]-deriveEncode TypeD {tName, tCons = [ConsD {cFields}], tKind} =- pure <$> instanceD (cxt constrains) appHead methods- where- subARgs = conT ''SUBSCRIPTION : encodeVarsT- instanceArgs- | isSubscription tKind = subARgs- | otherwise = map nameVarT (po_ : encodeVars)- mainType = applyT (mkTypeName tName) [mainTypeArg]- where- mainTypeArg- | isSubscription tKind = applyT ''Resolver subARgs- | otherwise = typeT ''Resolver (fo_ : encodeVars)- ------------------------------------------------------------------------------------------ typeables- | isSubscription tKind =- [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]]- | otherwise =- [ iLiftOp po_,- iLiftOp fo_,- typeT ''MapStrategy [fo_, po_],- iTypeable fo_,- iTypeable po_- ]- -------------------------- iLiftOp op = applyT ''LiftOperation [nameVarT op]- -------------------------- iTypeable name = typeT ''Typeable [name]- -------------------------------------------- -- defines Constraint: (Typeable m, Monad m)- constrains =- typeables- <> [ typeT ''Monad [m_],- applyT ''Encode (mainType : instanceArgs),- iTypeable e_,- iTypeable m_- ]- -------------------------------------------------------------------- -- defines: instance <constraint> => ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value) where- appHead =- instanceHeadMultiT- ''ExploreResolvers- (conT ''TRUE)- (mainType : instanceArgs)- ------------------------------------------------------------------- -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...]- methods = [funD 'exploreResolvers [clause argsE (normalB body) []]]- where- argsE = [nameVarP "_", destructRecord tName varNames]- body =- appE (varE 'pure)- $ appE- (conE 'ResObject)- $ appE- ( appE- (conE 'ObjectResModel)- (nameStringE tName)- )- (listE $ map decodeVar varNames)- decodeVar name = [|(name, encode $(varName))|]- where- varName = nameVarE name- varNames = map fieldName cFields-deriveEncode _ = pure []
− src/Data/Morpheus/Server/Document/GQLType.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Server.Document.GQLType- ( deriveGQLType,- )-where------- MORPHEUS-import Data.Morpheus.Internal.TH- ( instanceHeadT,- instanceProxyFunD,- mkTypeName,- tyConArgs,- typeInstanceDec,- typeT,- )-import Data.Morpheus.Kind- ( ENUM,- INPUT,- INTERFACE,- OUTPUT,- SCALAR,- WRAPPER,- )-import Data.Morpheus.Server.Types.GQLType- ( GQLType (..),- TRUE,- )-import Data.Morpheus.Types (Resolver, interface)-import Data.Morpheus.Types.Internal.AST- ( ANY,- DataTypeKind (..),- GQLTypeD (..),- Meta (..),- QUERY,- TypeContent (..),- TypeD (..),- TypeDefinition (..),- TypeName,- isObject,- )-import Data.Proxy (Proxy (..))-import Data.Semigroup ((<>))-import Data.Typeable (Typeable)-import Language.Haskell.TH--interfaceF :: Name -> ExpQ-interfaceF name = [|interface (Proxy :: (Proxy ($(conT name) (Resolver QUERY () Maybe))))|]--introspectInterface :: TypeName -> ExpQ-introspectInterface = interfaceF . mkTypeName--deriveGQLType :: GQLTypeD -> Q [Dec]-deriveGQLType GQLTypeD {typeD = TypeD {tName, tMeta, tKind}, typeOriginal} =- pure <$> instanceD (cxt constrains) iHead (functions <> typeFamilies)- where- functions =- map- instanceProxyFunD- [ ('__typeName, [|tName|]),- ('description, descriptionValue),- ('implements, implementsFunc)- ]- where- implementsFunc = listE $ map introspectInterface (interfacesFrom (Just typeOriginal))- descriptionValue = case tMeta >>= metaDescription of- Nothing -> [|Nothing|]- Just desc -> [|Just desc|]- --------------------------------- typeArgs = tyConArgs tKind- --------------------------------- iHead = instanceHeadT ''GQLType tName typeArgs- headSig = typeT (mkTypeName tName) typeArgs- ---------------------------------------------------- constrains = map conTypeable typeArgs- where- conTypeable name = typeT ''Typeable [name]- -------------------------------------------------- typeFamilies- | isObject tKind = [deriveKIND, deriveCUSTOM]- | otherwise = [deriveKIND]- where- deriveCUSTOM = deriveInstance ''CUSTOM ''TRUE- deriveKIND = deriveInstance ''KIND (kindName tKind)- -------------------------------------------------------- deriveInstance :: Name -> Name -> Q Dec- deriveInstance insName tyName = do- typeN <- headSig- pure $ typeInstanceDec insName typeN (ConT tyName)--kindName :: DataTypeKind -> Name-kindName KindObject {} = ''OUTPUT-kindName KindScalar = ''SCALAR-kindName KindEnum = ''ENUM-kindName KindUnion = ''OUTPUT-kindName KindInputObject = ''INPUT-kindName KindList = ''WRAPPER-kindName KindNonNull = ''WRAPPER-kindName KindInputUnion = ''INPUT-kindName KindInterface = ''INTERFACE--interfacesFrom :: Maybe (TypeDefinition ANY) -> [TypeName]-interfacesFrom (Just TypeDefinition {typeContent = DataObject {objectImplements}}) = objectImplements-interfacesFrom _ = []
− src/Data/Morpheus/Server/Document/Introspect.hs
@@ -1,135 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Server.Document.Introspect- ( deriveObjectRep,- instanceIntrospect,- )-where--import Data.Maybe (maybeToList)--- MORPHEUS-import Data.Morpheus.Internal.TH- ( instanceFunD,- instanceHeadMultiT,- instanceHeadT,- instanceProxyFunD,- mkTypeName,- nameConT,- nameVarT,- tyConArgs,- typeT,- )-import Data.Morpheus.Server.Deriving.Introspect- ( DeriveTypeContent (..),- Introspect (..),- deriveCustomInputObjectType,- )-import Data.Morpheus.Server.Types.GQLType- ( GQLType (__typeName, implements),- TRUE,- )-import Data.Morpheus.Types.Internal.AST- ( ANY,- ArgumentsDefinition (..),- ConsD (..),- DataTypeKind (..),- FieldDefinition (..),- TypeContent (..),- TypeD (..),- TypeDefinition (..),- TypeName,- TypeRef (..),- TypeUpdater,- insertType,- unsafeFromFields,- )-import Data.Morpheus.Types.Internal.Resolving- ( resolveUpdates,- )-import Data.Proxy (Proxy (..))-import Data.Typeable (Typeable)-import Language.Haskell.TH--instanceIntrospect :: TypeDefinition cat -> Q [Dec]-instanceIntrospect TypeDefinition {typeName, typeContent = DataEnum enumType, ..}- -- FIXME: dirty fix for introspection- | typeName `elem` ["__DirectiveLocation", "__TypeKind"] = pure []- | otherwise = pure <$> instanceD (cxt []) iHead [defineIntrospect]- where- iHead = instanceHeadT ''Introspect typeName []- defineIntrospect = instanceProxyFunD ('introspect, body)- where- body = [|insertType TypeDefinition {typeContent = DataEnum enumType, ..}|]-instanceIntrospect _ = pure []---- [(FieldDefinition, TypeUpdater)]-deriveObjectRep :: (TypeD, Maybe (TypeDefinition ANY), Maybe DataTypeKind) -> Q [Dec]-deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, _, tKind) =- pure <$> instanceD (cxt constrains) iHead methods- where- mainTypeName = typeT (mkTypeName tName) typeArgs- typeArgs = concatMap tyConArgs (maybeToList tKind)- constrains = map conTypeable typeArgs- where- conTypeable name = typeT ''Typeable [name]- ------------------------------------------------ iHead = instanceHeadMultiT ''DeriveTypeContent (conT ''TRUE) [mainTypeName]- methods = [instanceFunD 'deriveTypeContent ["_proxy1", "_proxy2"] body]- where- body- | tKind == Just KindInputObject || null tKind =- [|- ( DataInputObject- (unsafeFromFields $(buildFields cFields)),- $(typeUpdates)- )- |]- | otherwise =- [|- ( DataObject- (interfaceNames $(proxy))- (unsafeFromFields $(buildFields cFields)),- interfaceTypes $(proxy)- : $(typeUpdates)- )- |]- -------------------------------------------------------------- typeUpdates = buildTypes cFields- proxy = [|(Proxy :: Proxy $(mainTypeName))|]-deriveObjectRep _ = pure []--interfaceNames :: GQLType a => Proxy a -> [TypeName]-interfaceNames = map fst . implements--interfaceTypes :: GQLType a => Proxy a -> TypeUpdater-interfaceTypes = flip resolveUpdates . map snd . implements--buildTypes :: [FieldDefinition cat] -> ExpQ-buildTypes = listE . concatMap introspectField--introspectField :: FieldDefinition cat -> [ExpQ]-introspectField FieldDefinition {fieldType, fieldArgs} =- [|introspect $(proxyT fieldType)|] : inputTypes fieldArgs- where- inputTypes :: ArgumentsDefinition -> [ExpQ]- inputTypes ArgumentsDefinition {argumentsTypename = Just argsTypeName}- | argsTypeName /= "()" = [[|deriveCustomInputObjectType (argsTypeName, $(proxyT tAlias))|]]- where- tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing}- inputTypes _ = []--proxyT :: TypeRef -> Q Exp-proxyT TypeRef {typeConName, typeArgs} = [|(Proxy :: Proxy $(genSig typeArgs))|]- where- genSig (Just m) = appT (nameConT typeConName) (nameVarT m)- genSig _ = nameConT typeConName--buildFields :: [FieldDefinition cat] -> ExpQ-buildFields = listE . map buildField- where- buildField f@FieldDefinition {fieldType} = [|f {fieldType = fieldType {typeConName = __typeName $(proxyT fieldType)}}|]
src/Data/Morpheus/Server/Internal/TH/Decode.hs view
@@ -32,31 +32,34 @@ FieldDefinition (..), FieldName, Message,+ Message, ObjectEntry (..), TypeName (..), ValidObject, ValidValue, Value (..),+ msg, toFieldName, ) import Data.Morpheus.Types.Internal.Resolving ( Eventless, Failure (..), )+import Data.Semigroup ((<>)) import Language.Haskell.TH ( ExpQ, uInfixE, varE, ) -decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ+decodeObjectExpQ :: ExpQ -> ConsD cat -> ExpQ decodeObjectExpQ fieldDecoder ConsD {cName, cFields} = handleFields cFields where consName = nameConE cName ---------------------------------------------------------------------------------- handleFields fNames = uInfixE consName (varE '(<$>)) (applyFields fNames) where- applyFields [] = fail "No Empty fields"+ applyFields [] = fail $ show ("No Empty fields on " <> msg cName :: Message) applyFields [x] = defField x applyFields (x : xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs) ------------------------------------------------------------------------
+ src/Data/Morpheus/Server/Internal/TH/Types.hs view
@@ -0,0 +1,25 @@+module Data.Morpheus.Server.Internal.TH.Types+ ( ServerTypeDefinition (..),+ )+where++import Data.Morpheus.Types.Internal.AST+ ( ANY,+ ConsD (..),+ FieldName,+ IN,+ TypeDefinition,+ TypeKind,+ TypeName,+ )++--- Core+data ServerTypeDefinition cat = ServerTypeDefinition+ { tName :: TypeName,+ tNamespace :: [FieldName],+ typeArgD :: [ServerTypeDefinition IN],+ tCons :: [ConsD cat],+ tKind :: TypeKind,+ typeOriginal :: Maybe (TypeDefinition ANY)+ }+ deriving (Show)
+ src/Data/Morpheus/Server/TH/Compile.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Server.TH.Compile+ ( compileDocument,+ gqlDocument,+ gqlDocumentNamespace,+ )+where++--+-- Morpheus++import Data.Morpheus.Core+ ( parseTypeDefinitions,+ )+import Data.Morpheus.Error+ ( gqlWarnings,+ renderGQLErrors,+ )+import Data.Morpheus.Server.TH.Declare+ ( declare,+ )+import Data.Morpheus.Server.TH.Transform+ ( toTHDefinitions,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Result (..),+ )+import qualified Data.Text as T+ ( pack,+ )+import Language.Haskell.TH+import Language.Haskell.TH.Quote++gqlDocumentNamespace :: QuasiQuoter+gqlDocumentNamespace =+ QuasiQuoter+ { quoteExp = notHandled "Expressions",+ quotePat = notHandled "Patterns",+ quoteType = notHandled "Types",+ quoteDec = compileDocument True+ }+ where+ notHandled things =+ error $ things ++ " are not supported by the GraphQL QuasiQuoter"++gqlDocument :: QuasiQuoter+gqlDocument =+ QuasiQuoter+ { quoteExp = notHandled "Expressions",+ quotePat = notHandled "Patterns",+ quoteType = notHandled "Types",+ quoteDec = compileDocument False+ }+ where+ notHandled things =+ error $ things ++ " are not supported by the GraphQL QuasiQuoter"++compileDocument :: Bool -> String -> Q [Dec]+compileDocument namespace documentTXT =+ case parseTypeDefinitions (T.pack documentTXT) of+ Failure errors -> fail (renderGQLErrors errors)+ Success {result = schema, warnings} ->+ gqlWarnings warnings >> toTHDefinitions namespace schema >>= declare namespace
+ src/Data/Morpheus/Server/TH/Declare.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Server.TH.Declare+ ( declare,+ )+where++-- MORPHEUS++import Data.Morpheus.Server.Internal.TH.Types+ ( ServerTypeDefinition (..),+ )+import Data.Morpheus.Server.TH.Declare.Decode+ ( deriveDecode,+ )+import Data.Morpheus.Server.TH.Declare.Encode+ ( deriveEncode,+ )+import Data.Morpheus.Server.TH.Declare.GQLType+ ( deriveGQLType,+ )+import Data.Morpheus.Server.TH.Declare.Introspect+ ( deriveObjectRep,+ instanceIntrospect,+ )+import Data.Morpheus.Server.TH.Declare.Type+ ( declareType,+ )+import Data.Morpheus.Server.TH.Transform+import Data.Morpheus.Types.Internal.AST+ ( IN,+ isInput,+ isObject,+ )+import Data.Semigroup ((<>))+import Language.Haskell.TH++class Declare a where+ type DeclareCtx a :: *+ declare :: DeclareCtx a -> a -> Q [Dec]++instance Declare a => Declare [a] where+ type DeclareCtx [a] = DeclareCtx a+ declare namespace = fmap concat . traverse (declare namespace)++instance Declare TypeDec where+ type DeclareCtx TypeDec = Bool+ declare namespace (InputType typeD) = declare namespace typeD+ declare namespace (OutputType typeD) = declare namespace typeD++instance Declare (ServerTypeDefinition cat) where+ type DeclareCtx (ServerTypeDefinition cat) = Bool+ declare namespace typeD@ServerTypeDefinition {tKind, typeArgD, typeOriginal} =+ do+ let mainType = declareType namespace typeD+ argTypes <- declareArgTypes namespace typeArgD+ gqlInstances <- deriveGQLInstances+ typeClasses <- deriveGQLType typeD+ introspectEnum <- instanceIntrospect typeOriginal+ pure $ mainType <> typeClasses <> argTypes <> gqlInstances <> introspectEnum+ where+ deriveGQLInstances = concat <$> sequence gqlInstances+ where+ gqlInstances+ | isObject tKind && isInput tKind =+ [deriveObjectRep typeD, deriveDecode typeD]+ | isObject tKind =+ [deriveObjectRep typeD, deriveEncode typeD]+ | otherwise =+ []++declareArgTypes :: Bool -> [ServerTypeDefinition IN] -> Q [Dec]+declareArgTypes namespace types = do+ introspectArgs <- concat <$> traverse deriveObjectRep types+ decodeArgs <- concat <$> traverse deriveDecode types+ return $ argsTypeDecs <> decodeArgs <> introspectArgs+ where+ ----------------------------------------------------+ argsTypeDecs = concatMap (declareType namespace) types
+ src/Data/Morpheus/Server/TH/Declare/Decode.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.TH.Declare.Decode+ ( deriveDecode,+ )+where++--+-- MORPHEUS++import Data.Morpheus.Internal.TH+ ( instanceHeadT,+ nameVarP,+ )+import Data.Morpheus.Server.Deriving.Decode+ ( Decode (..),+ DecodeType (..),+ )+import Data.Morpheus.Server.Internal.TH.Decode+ ( decodeFieldWith,+ decodeObjectExpQ,+ withObject,+ )+import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))+import Data.Morpheus.Types.Internal.AST+ ( FieldName,+ ValidValue,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Eventless,+ )+import Language.Haskell.TH++(.:) :: Decode a => ValidValue -> FieldName -> Eventless a+value .: selectorName = withObject (decodeFieldWith decode selectorName) value++deriveDecode :: ServerTypeDefinition cat -> Q [Dec]+deriveDecode ServerTypeDefinition {tName, tCons = [cons]} =+ pure <$> instanceD (cxt []) appHead methods+ where+ appHead = instanceHeadT ''DecodeType tName []+ methods = [funD 'decodeType [clause argsE (normalB body) []]]+ where+ argsE = map nameVarP ["o"]+ body = decodeObjectExpQ [|(.:)|] cons+deriveDecode _ = pure []
+ src/Data/Morpheus/Server/TH/Declare/Encode.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.TH.Declare.Encode+ ( deriveEncode,+ )+where++--+-- MORPHEUS++import Data.Morpheus.Internal.TH+ ( applyT,+ destructRecord,+ instanceHeadMultiT,+ mkTypeName,+ nameStringE,+ nameVarE,+ nameVarP,+ nameVarT,+ typeT,+ )+import Data.Morpheus.Server.Deriving.Encode+ ( Encode (..),+ ExploreResolvers (..),+ )+import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))+import Data.Morpheus.Server.Types.GQLType (TRUE)+import Data.Morpheus.Types.Internal.AST+ ( ConsD (..),+ FieldDefinition (..),+ QUERY,+ SUBSCRIPTION,+ TypeName (..),+ isSubscription,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( LiftOperation,+ MapStrategy (..),+ ObjectResModel (..),+ ResModel (..),+ Resolver,+ )+import Data.Semigroup ((<>))+import Data.Typeable (Typeable)+import Language.Haskell.TH++m_ :: TypeName+m_ = "m"++fo_ :: TypeName+fo_ = "fieldOperationKind"++po_ :: TypeName+po_ = "parentOparation"++e_ :: TypeName+e_ = "encodeEvent"++encodeVars :: [TypeName]+encodeVars = [e_, m_]++encodeVarsT :: [TypeQ]+encodeVarsT = map nameVarT encodeVars++deriveEncode :: ServerTypeDefinition cat -> Q [Dec]+deriveEncode ServerTypeDefinition {tName, tCons = [ConsD {cFields}], tKind} =+ pure <$> instanceD (cxt constrains) appHead methods+ where+ subARgs = conT ''SUBSCRIPTION : encodeVarsT+ instanceArgs+ | isSubscription tKind = subARgs+ | otherwise = map nameVarT (po_ : encodeVars)+ mainType = applyT (mkTypeName tName) [mainTypeArg]+ where+ mainTypeArg+ | isSubscription tKind = applyT ''Resolver subARgs+ | otherwise = typeT ''Resolver (fo_ : encodeVars)+ -----------------------------------------------------------------------------------------+ typeables+ | isSubscription tKind =+ [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]]+ | otherwise =+ [ iLiftOp po_,+ iLiftOp fo_,+ typeT ''MapStrategy [fo_, po_],+ iTypeable fo_,+ iTypeable po_+ ]+ -------------------------+ iLiftOp op = applyT ''LiftOperation [nameVarT op]+ -------------------------+ iTypeable name = typeT ''Typeable [name]+ -------------------------------------------+ -- defines Constraint: (Typeable m, Monad m)+ constrains =+ typeables+ <> [ typeT ''Monad [m_],+ applyT ''Encode (mainType : instanceArgs),+ iTypeable e_,+ iTypeable m_+ ]+ -------------------------------------------------------------------+ -- defines: instance <constraint> => ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value) where+ appHead =+ instanceHeadMultiT+ ''ExploreResolvers+ (conT ''TRUE)+ (mainType : instanceArgs)+ ------------------------------------------------------------------+ -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...]+ methods = [funD 'exploreResolvers [clause argsE (normalB body) []]]+ where+ argsE = [nameVarP "_", destructRecord tName varNames]+ body =+ appE (varE 'pure)+ $ appE+ (conE 'ResObject)+ $ appE+ ( appE+ (conE 'ObjectResModel)+ (nameStringE tName)+ )+ (listE $ map decodeVar varNames)+ decodeVar name = [|(name, encode $(varName))|]+ where+ varName = nameVarE name+ varNames = map fieldName cFields+deriveEncode _ = pure []
+ src/Data/Morpheus/Server/TH/Declare/GQLType.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.TH.Declare.GQLType+ ( deriveGQLType,+ )+where++--+-- MORPHEUS+import Data.Morpheus.Internal.TH+ ( instanceHeadT,+ instanceProxyFunD,+ mkTypeName,+ tyConArgs,+ typeInstanceDec,+ typeT,+ )+import Data.Morpheus.Kind+ ( ENUM,+ INPUT,+ INTERFACE,+ OUTPUT,+ SCALAR,+ WRAPPER,+ )+import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))+import Data.Morpheus.Server.Types.GQLType+ ( GQLType (..),+ TRUE,+ )+import Data.Morpheus.Types (Resolver, interface)+import Data.Morpheus.Types.Internal.AST+ ( ANY,+ QUERY,+ TypeContent (..),+ TypeDefinition (..),+ TypeKind (..),+ TypeName,+ isObject,+ )+import Data.Proxy (Proxy (..))+import Data.Semigroup ((<>))+import Data.Typeable (Typeable)+import Language.Haskell.TH++interfaceF :: Name -> ExpQ+interfaceF name = [|interface (Proxy :: (Proxy ($(conT name) (Resolver QUERY () Maybe))))|]++introspectInterface :: TypeName -> ExpQ+introspectInterface = interfaceF . mkTypeName++deriveGQLType :: ServerTypeDefinition cat -> Q [Dec]+deriveGQLType ServerTypeDefinition {tName, tKind, typeOriginal} =+ pure <$> instanceD (cxt constrains) iHead (functions <> typeFamilies)+ where+ functions =+ map+ instanceProxyFunD+ [ ('__typeName, [|tName|]),+ ('description, [|tDescription|]),+ ('implements, implementsFunc)+ ]+ where+ tDescription = typeOriginal >>= typeDescription+ implementsFunc = listE $ map introspectInterface (interfacesFrom typeOriginal)+ --------------------------------+ typeArgs = tyConArgs tKind+ --------------------------------+ iHead = instanceHeadT ''GQLType tName typeArgs+ headSig = typeT (mkTypeName tName) typeArgs+ ---------------------------------------------------+ constrains = map conTypeable typeArgs+ where+ conTypeable name = typeT ''Typeable [name]+ -------------------------------------------------+ typeFamilies+ | isObject tKind = [deriveKIND, deriveCUSTOM]+ | otherwise = [deriveKIND]+ where+ deriveCUSTOM = deriveInstance ''CUSTOM ''TRUE+ deriveKIND = deriveInstance ''KIND (kindName tKind)+ -------------------------------------------------------+ deriveInstance :: Name -> Name -> Q Dec+ deriveInstance insName tyName = do+ typeN <- headSig+ pure $ typeInstanceDec insName typeN (ConT tyName)++kindName :: TypeKind -> Name+kindName KindObject {} = ''OUTPUT+kindName KindScalar = ''SCALAR+kindName KindEnum = ''ENUM+kindName KindUnion = ''OUTPUT+kindName KindInputObject = ''INPUT+kindName KindList = ''WRAPPER+kindName KindNonNull = ''WRAPPER+kindName KindInputUnion = ''INPUT+kindName KindInterface = ''INTERFACE++interfacesFrom :: Maybe (TypeDefinition ANY) -> [TypeName]+interfacesFrom (Just TypeDefinition {typeContent = DataObject {objectImplements}}) = objectImplements+interfacesFrom _ = []
+ src/Data/Morpheus/Server/TH/Declare/Introspect.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.TH.Declare.Introspect+ ( deriveObjectRep,+ instanceIntrospect,+ )+where++-- MORPHEUS+import Data.Morpheus.Internal.TH+ ( instanceFunD,+ instanceHeadMultiT,+ instanceProxyFunD,+ mkTypeName,+ nameConT,+ nameVarT,+ tyConArgs,+ typeT,+ )+import Data.Morpheus.Server.Deriving.Introspect+ ( DeriveTypeContent (..),+ Introspect (..),+ ProxyRep (..),+ deriveCustomInputObjectType,+ )+import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))+import Data.Morpheus.Server.Types.GQLType+ ( GQLType (__typeName, implements),+ TRUE,+ )+import Data.Morpheus.Types.Internal.AST+ ( ArgumentsDefinition (..),+ ConsD (..),+ FieldContent (..),+ FieldDefinition (..),+ IN,+ OUT,+ TypeContent (..),+ TypeDefinition (..),+ TypeKind (..),+ TypeName,+ TypeRef (..),+ TypeUpdater,+ insertType,+ unsafeFromFields,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( resolveUpdates,+ )+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable)+import Language.Haskell.TH++cat_ :: TypeQ+cat_ = varT (mkName "cat")++instanceIntrospect :: Maybe (TypeDefinition cat) -> Q [Dec]+instanceIntrospect (Just typeDef@TypeDefinition {typeName, typeContent = DataEnum {}}) =+ pure <$> instanceD (cxt []) iHead [defineIntrospect]+ where+ iHead = instanceHeadMultiT ''Introspect cat_ [conT $ mkTypeName typeName]+ defineIntrospect = instanceProxyFunD ('introspect, body)+ where+ body = [|insertType typeDef|]+instanceIntrospect _ = pure []++-- [(FieldDefinition, TypeUpdater)]+deriveObjectRep :: ServerTypeDefinition cat -> Q [Dec]+deriveObjectRep+ ServerTypeDefinition+ { tName,+ tCons = [ConsD {cFields}],+ tKind+ } =+ pure <$> instanceD (cxt constrains) iHead methods+ where+ mainTypeName = typeT (mkTypeName tName) typeArgs+ typeArgs = tyConArgs tKind+ constrains = map conTypeable typeArgs+ where+ conTypeable name = typeT ''Typeable [name]+ -----------------------------------------------+ iHead = instanceHeadMultiT ''DeriveTypeContent instCat [conT ''TRUE, mainTypeName]+ instCat+ | tKind == KindInputObject =+ conT ''IN+ | otherwise = conT ''OUT+ methods = [instanceFunD 'deriveTypeContent ["_proxy1", "_proxy2"] body]+ where+ body+ | tKind == KindInputObject =+ [|+ deriveInputObject+ $(buildFields cFields)+ $(buildTypes instCat cFields)+ |]+ | otherwise =+ [|+ deriveOutputObject+ $(proxy)+ $(buildFields cFields)+ $(buildTypes instCat cFields)+ |]+ proxy = [|(Proxy :: Proxy $(mainTypeName))|]+deriveObjectRep _ = pure []++deriveInputObject ::+ [FieldDefinition IN] ->+ [TypeUpdater] ->+ ( TypeContent TRUE IN,+ [TypeUpdater]+ )+deriveInputObject fields typeUpdates =+ (DataInputObject (unsafeFromFields fields), typeUpdates)++deriveOutputObject ::+ (GQLType a) =>+ Proxy a ->+ [FieldDefinition OUT] ->+ [TypeUpdater] ->+ ( TypeContent TRUE OUT,+ [TypeUpdater]+ )+deriveOutputObject proxy fields typeUpdates =+ ( DataObject+ (interfaceNames proxy)+ (unsafeFromFields fields),+ interfaceTypes proxy : typeUpdates+ )++interfaceNames :: GQLType a => Proxy a -> [TypeName]+interfaceNames = map fst . implements++interfaceTypes :: GQLType a => Proxy a -> TypeUpdater+interfaceTypes = flip resolveUpdates . map snd . implements++buildTypes :: TypeQ -> [FieldDefinition cat] -> ExpQ+buildTypes cat = listE . concatMap (introspectField cat)++introspectField :: TypeQ -> FieldDefinition cat -> [ExpQ]+introspectField cat FieldDefinition {fieldType, fieldContent} =+ [|introspect $(proxyRepT cat fieldType)|] : inputTypes fieldContent+ where+ inputTypes :: Maybe (FieldContent TRUE cat) -> [ExpQ]+ inputTypes (Just (FieldArgs ArgumentsDefinition {argumentsTypename = Just argsTypeName}))+ | argsTypeName /= "()" = [[|deriveCustomInputObjectType (argsTypeName, $(proxyT tAlias))|]]+ where+ tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing}+ inputTypes _ = []++proxyRepT :: TypeQ -> TypeRef -> Q Exp+proxyRepT cat TypeRef {typeConName, typeArgs} = [|(ProxyRep :: ProxyRep $(cat) $(genSig typeArgs))|]+ where+ genSig (Just m) = appT (nameConT typeConName) (nameVarT m)+ genSig _ = nameConT typeConName++proxyT :: TypeRef -> Q Exp+proxyT TypeRef {typeConName, typeArgs} = [|(Proxy :: Proxy $(genSig typeArgs))|]+ where+ genSig (Just m) = appT (nameConT typeConName) (nameVarT m)+ genSig _ = nameConT typeConName++buildFields :: [FieldDefinition cat] -> ExpQ+buildFields = listE . map buildField+ where+ buildField f@FieldDefinition {fieldType} = [|f {fieldType = fieldType {typeConName = __typeName $(proxyT fieldType)}}|]
+ src/Data/Morpheus/Server/TH/Declare/Type.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.TH.Declare.Type+ ( declareType,+ )+where++import Data.Morpheus.Internal.TH+ ( declareTypeRef,+ m',+ mkFieldName,+ mkTypeName,+ nameSpaceField,+ nameSpaceType,+ tyConArgs,+ )+import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))+import Data.Morpheus.Types.Internal.AST+ ( ArgumentsDefinition (..),+ ConsD (..),+ FieldContent (..),+ FieldDefinition (..),+ FieldName,+ TRUE,+ TypeKind (..),+ TypeName,+ isOutput,+ isOutputObject,+ isSubscription,+ )+import GHC.Generics (Generic)+import Language.Haskell.TH++declareType :: Bool -> ServerTypeDefinition cat -> [Dec]+declareType _ ServerTypeDefinition {tKind = KindScalar} = []+declareType namespace ServerTypeDefinition {tName, tCons, tKind, tNamespace} =+ [ DataD+ []+ (mkNamespace tNamespace tName)+ tVars+ Nothing+ cons+ (derive tKind)+ ]+ where+ tVars = declareTyVar (tyConArgs tKind)+ where+ declareTyVar = map (PlainTV . mkTypeName)+ cons = declareCons namespace tKind (tNamespace, tName) tCons++derive :: TypeKind -> [DerivClause]+derive tKind = [deriveClasses (''Generic : derivingList)]+ where+ derivingList+ | isOutput tKind = []+ | otherwise = [''Show]++deriveClasses :: [Name] -> DerivClause+deriveClasses classNames = DerivClause Nothing (map ConT classNames)++mkNamespace :: [FieldName] -> TypeName -> Name+mkNamespace tNamespace = mkTypeName . nameSpaceType tNamespace++declareCons ::+ Bool ->+ TypeKind ->+ ([FieldName], TypeName) ->+ [ConsD cat] ->+ [Con]+declareCons namespace tKind (tNamespace, tName) = map consR+ where+ consR ConsD {cName, cFields} =+ RecC+ (mkNamespace tNamespace cName)+ (map (declareField namespace tKind tName) cFields)++declareField ::+ Bool ->+ TypeKind ->+ TypeName ->+ FieldDefinition cat ->+ (Name, Bang, Type)+declareField namespace tKind tName field@FieldDefinition {fieldName} =+ ( fieldTypeName namespace tName fieldName,+ Bang NoSourceUnpackedness NoSourceStrictness,+ renderFieldType tKind field+ )++renderFieldType ::+ TypeKind ->+ FieldDefinition cat ->+ Type+renderFieldType tKind FieldDefinition {fieldContent, fieldType} =+ genFieldT+ (declareTypeRef (isSubscription tKind) fieldType)+ tKind+ fieldContent++fieldTypeName :: Bool -> TypeName -> FieldName -> Name+fieldTypeName namespace tName fieldName+ | namespace = mkFieldName (nameSpaceField tName fieldName)+ | otherwise = mkFieldName fieldName++------------------------------------------------+genFieldT :: Type -> TypeKind -> Maybe (FieldContent TRUE cat) -> Type+genFieldT result _ (Just (FieldArgs ArgumentsDefinition {argumentsTypename = Just argsTypename})) =+ AppT+ (AppT arrowType argType)+ (AppT m' result)+ where+ argType = ConT $ mkTypeName argsTypename+ arrowType = ConT ''Arrow+genFieldT result kind _+ | isOutputObject kind = AppT m' result+ | otherwise = result++type Arrow = (->)
+ src/Data/Morpheus/Server/TH/Transform.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Server.TH.Transform+ ( toTHDefinitions,+ TypeDec (..),+ )+where++-- MORPHEUS+import Data.Morpheus.Internal.TH+ ( infoTyVars,+ mkTypeName,+ )+import Data.Morpheus.Internal.Utils+ ( capitalTypeName,+ elems,+ empty,+ singleton,+ )+import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))+import Data.Morpheus.Types.Internal.AST+ ( ANY,+ ArgumentsDefinition (..),+ ConsD,+ FieldContent (..),+ FieldDefinition (..),+ FieldName,+ Fields (..),+ FieldsDefinition,+ IN,+ OUT,+ TRUE,+ TypeContent (..),+ TypeDefinition (..),+ TypeKind (..),+ TypeName,+ TypeRef (..),+ UnionMember (..),+ hsTypeName,+ kindOf,+ lookupWith,+ mkCons,+ mkConsEnum,+ toFieldName,+ )+import Data.Semigroup ((<>))+import Language.Haskell.TH++m_ :: TypeName+m_ = "m"++getTypeArgs :: TypeName -> [TypeDefinition ANY] -> Q (Maybe TypeName)+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 <$> lookupWith typeName key lib of+ Just x -> pure (kindToTyArgs x)+ Nothing -> getTyArgs <$> reify (mkTypeName key)++getTyArgs :: Info -> Maybe TypeName+getTyArgs x+ | null (infoTyVars x) = Nothing+ | otherwise = Just m_++kindToTyArgs :: TypeContent TRUE ANY -> Maybe TypeName+kindToTyArgs DataObject {} = Just m_+kindToTyArgs DataUnion {} = Just m_+kindToTyArgs DataInterface {} = Just m_+kindToTyArgs _ = Nothing++data TypeDec = InputType (ServerTypeDefinition IN) | OutputType (ServerTypeDefinition OUT)++toTHDefinitions :: Bool -> [TypeDefinition ANY] -> Q [TypeDec]+toTHDefinitions namespace schema = traverse generateType schema+ where+ --------------------------------------------+ generateType :: TypeDefinition ANY -> Q TypeDec+ generateType+ typeDef@TypeDefinition+ { typeName,+ typeContent+ } =+ withType <$> genTypeContent schema toArgsTypeName typeName typeContent+ where+ toArgsTypeName :: FieldName -> TypeName+ toArgsTypeName = mkArgsTypeName namespace typeName+ tKind = kindOf typeDef+ typeOriginal = Just typeDef+ -------------------------+ withType (ConsIN tCons) =+ InputType+ ServerTypeDefinition+ { tName = hsTypeName typeName,+ tNamespace = [],+ tCons,+ typeArgD = empty,+ ..+ }+ withType (ConsOUT typeArgD tCons) =+ OutputType+ ServerTypeDefinition+ { tName = hsTypeName typeName,+ tNamespace = [],+ tCons,+ ..+ }++mkObjectCons :: TypeName -> FieldsDefinition cat -> [ConsD cat]+mkObjectCons typeName fields = [mkCons typeName fields]++mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName+mkArgsTypeName namespace typeName fieldName+ | namespace = hsTypeName typeName <> argTName+ | otherwise = argTName+ where+ argTName = capitalTypeName (fieldName <> "Args")++mkObjectField :: [TypeDefinition ANY] -> (FieldName -> TypeName) -> FieldDefinition OUT -> Q (FieldDefinition OUT)+mkObjectField schema genArgsTypeName FieldDefinition {fieldName, fieldContent = cont, fieldType = typeRef@TypeRef {typeConName}, ..} =+ do+ typeArgs <- getTypeArgs typeConName schema+ pure+ FieldDefinition+ { fieldName,+ fieldType = typeRef {typeConName = hsTypeName typeConName, typeArgs},+ fieldContent = cont >>= fieldCont,+ ..+ }+ where+ fieldCont :: FieldContent TRUE OUT -> Maybe (FieldContent TRUE OUT)+ fieldCont (FieldArgs ArgumentsDefinition {arguments})+ | not (null arguments) =+ Just $ FieldArgs $+ ArgumentsDefinition+ { argumentsTypename = Just $ genArgsTypeName fieldName,+ arguments = arguments+ }+ fieldCont _ = Nothing++data BuildPlan+ = ConsIN [ConsD IN]+ | ConsOUT [ServerTypeDefinition IN] [ConsD OUT]++genTypeContent ::+ [TypeDefinition ANY] ->+ (FieldName -> TypeName) ->+ TypeName ->+ TypeContent TRUE ANY ->+ Q BuildPlan+genTypeContent _ _ _ DataScalar {} = pure (ConsIN [])+genTypeContent _ _ _ (DataEnum tags) = pure $ ConsIN (map mkConsEnum tags)+genTypeContent _ _ typeName (DataInputObject fields) =+ pure $ ConsIN (mkObjectCons typeName fields)+genTypeContent _ _ _ DataInputUnion {} = fail "Input Unions not Supported"+genTypeContent schema toArgsTyName typeName DataInterface {interfaceFields} = do+ typeArgD <- genArgumentTypes toArgsTyName interfaceFields+ objCons <- mkObjectCons typeName <$> traverse (mkObjectField schema toArgsTyName) interfaceFields+ pure $ ConsOUT typeArgD objCons+genTypeContent schema toArgsTyName typeName DataObject {objectFields} = do+ typeArgD <- genArgumentTypes toArgsTyName objectFields+ objCons <-+ mkObjectCons typeName+ <$> traverse (mkObjectField schema toArgsTyName) objectFields+ pure $ ConsOUT typeArgD objCons+genTypeContent _ _ typeName (DataUnion members) =+ pure $ ConsOUT [] (map unionCon members)+ where+ unionCon UnionMember {memberName} =+ mkCons+ cName+ ( singleton+ FieldDefinition+ { fieldName = "un" <> toFieldName cName,+ fieldType =+ TypeRef+ { typeConName = utName,+ typeArgs = Just m_,+ typeWrappers = []+ },+ fieldDescription = Nothing,+ fieldDirectives = empty,+ fieldContent = Nothing+ }+ )+ where+ cName = hsTypeName typeName <> utName+ utName = hsTypeName memberName++genArgumentTypes :: (FieldName -> TypeName) -> FieldsDefinition OUT -> Q [ServerTypeDefinition IN]+genArgumentTypes genArgsTypeName fields =+ concat <$> traverse (genArgumentType genArgsTypeName) (elems fields)++genArgumentType :: (FieldName -> TypeName) -> FieldDefinition OUT -> Q [ServerTypeDefinition IN]+genArgumentType namespaceWith FieldDefinition {fieldName, fieldContent = Just (FieldArgs ArgumentsDefinition {arguments})}+ | not (null arguments) =+ pure+ [ ServerTypeDefinition+ { tName,+ tNamespace = empty,+ tCons = [mkCons tName (Fields arguments)],+ tKind = KindInputObject,+ typeArgD = [],+ typeOriginal = Nothing+ }+ ]+ where+ tName = hsTypeName (namespaceWith fieldName)+genArgumentType _ _ = pure []
− src/Data/Morpheus/Server/Types/GQLScalar.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Morpheus.Server.Types.GQLScalar- ( GQLScalar (..),- toScalar,- )-where--import Data.Morpheus.Types.Internal.AST- ( ScalarDefinition (..),- ScalarValue (..),- ValidValue,- Value (..),- )-import Data.Proxy (Proxy (..))-import Data.Text (Text)--toScalar :: ValidValue -> Either Text ScalarValue-toScalar (Scalar x) = pure x-toScalar _ = Left ""---- | GraphQL Scalar------ 'parseValue' and 'serialize' should be provided for every instances manually-class GQLScalar a where- -- | value parsing and validating- --- -- for exhaustive pattern matching should be handled all scalar types : 'Int', 'Float', 'String', 'Boolean'- --- -- invalid values can be reported with 'Left' constructor :- --- -- @- -- parseValue String _ = Left "" -- without error message- -- -- or- -- parseValue String _ = Left "Error Message"- -- @- parseValue :: ScalarValue -> Either Text a-- -- | serialization of haskell type into scalar value- serialize :: a -> ScalarValue-- scalarValidator :: Proxy a -> ScalarDefinition- scalarValidator _ = ScalarDefinition {validateValue = validator}- where- validator value = do- scalarValue' <- toScalar value- (_ :: a) <- parseValue scalarValue'- return value--instance GQLScalar Text where- parseValue (String x) = pure x- parseValue _ = Left ""- serialize = String--instance GQLScalar Bool where- parseValue (Boolean x) = pure x- parseValue _ = Left ""- serialize = Boolean--instance GQLScalar Int where- parseValue (Int x) = pure x- parseValue _ = Left ""- serialize = Int--instance GQLScalar Float where- parseValue (Float x) = pure x- parseValue (Int x) = pure $ fromInteger $ toInteger x- parseValue _ = Left ""- serialize = Float
src/Data/Morpheus/Server/Types/GQLType.hs view
@@ -24,6 +24,7 @@ Pair, Undefined (..), )+import Data.Morpheus.Types.ID (ID) import Data.Morpheus.Types.Internal.AST ( DataFingerprint (..), QUERY,@@ -212,3 +213,7 @@ type KIND (a -> b) = WRAPPER __typeName _ = __typeName (Proxy @b) __typeFingerprint _ = __typeFingerprint (Proxy @b)++instance GQLType ID where+ type KIND ID = SCALAR+ __typeFingerprint _ = internalFingerprint "ID" []
− src/Data/Morpheus/Server/Types/ID.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Server.Types.ID- ( ID (..),- )-where--import qualified Data.Aeson as A-import Data.Morpheus.Kind (SCALAR)-import Data.Morpheus.Server.Types.GQLScalar (GQLScalar (..))-import Data.Morpheus.Server.Types.GQLType (GQLType (..))-import Data.Morpheus.Types.Internal.AST- ( ScalarValue (..),- internalFingerprint,- )-import Data.Text- ( Text,- pack,- )-import GHC.Generics (Generic)---- | default GraphQL type,--- parses only 'String' and 'Int' values,--- serialized always as 'String'-newtype ID = ID- { unpackID :: Text- }- deriving (Show, Generic)--instance GQLType ID where- type KIND ID = SCALAR- __typeFingerprint _ = internalFingerprint "ID" []--instance A.ToJSON ID where- toJSON = A.toJSON . unpackID--instance A.FromJSON ID where- parseJSON = fmap ID . A.parseJSON--instance GQLScalar ID where- parseValue (Int x) = return (ID $ pack $ show x)- parseValue (String x) = return (ID x)- parseValue _ = Left ""- serialize (ID x) = String x
src/Data/Morpheus/Types.hs view
@@ -16,7 +16,7 @@ GQLResponse (..), ID (..), ScalarValue (..),- GQLRootResolver (..),+ RootResolver (..), constRes, constMutRes, Undefined (..),@@ -62,16 +62,16 @@ import Data.Either (either) -- MORPHEUS -import Data.Morpheus.Server.Deriving.Introspect (Introspect (..))-import Data.Morpheus.Server.Types.GQLScalar+import Data.Morpheus.Server.Deriving.Introspect (Introspect (..), introspectOUT)+import Data.Morpheus.Server.Types.GQLType (GQLType (..))+import Data.Morpheus.Server.Types.Types (Undefined (..))+import Data.Morpheus.Types.GQLScalar ( GQLScalar ( parseValue, serialize ), )-import Data.Morpheus.Server.Types.GQLType (GQLType (..))-import Data.Morpheus.Server.Types.ID (ID (..))-import Data.Morpheus.Server.Types.Types (Undefined (..))+import Data.Morpheus.Types.ID (ID (..)) import Data.Morpheus.Types.IO ( GQLRequest (..), GQLResponse (..),@@ -79,6 +79,7 @@ import Data.Morpheus.Types.Internal.AST ( MUTATION, Message,+ OUT, QUERY, SUBSCRIPTION, ScalarValue (..),@@ -203,11 +204,11 @@ -- | 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 can use __()__ for it.-data GQLRootResolver (m :: * -> *) event (query :: (* -> *) -> *) (mut :: (* -> *) -> *) (sub :: (* -> *) -> *) = GQLRootResolver+data RootResolver (m :: * -> *) event (query :: (* -> *) -> *) (mut :: (* -> *) -> *) (sub :: (* -> *) -> *) = RootResolver { queryResolver :: query (Resolver QUERY event m), mutationResolver :: mut (Resolver MUTATION event m), subscriptionResolver :: sub (Resolver SUBSCRIPTION event m) } -interface :: (GQLType a, Introspect a) => Proxy a -> (TypeName, TypeUpdater)-interface x = (__typeName x, introspect x)+interface :: (GQLType a, Introspect OUT a) => Proxy a -> (TypeName, TypeUpdater)+interface x = (__typeName x, introspectOUT x)
test/Feature/Holistic/API.hs view
@@ -23,10 +23,10 @@ ( Event, GQLRequest, GQLResponse,- GQLRootResolver (..), GQLScalar (..), GQLType (..), ID (..),+ RootResolver (..), ScalarValue (..), liftEither, subscribe,@@ -58,9 +58,9 @@ alwaysFail :: IO (Either String a) alwaysFail = pure $ Left "fail with Either" -rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription+rootResolver :: RootResolver IO EVENT Query Mutation Subscription rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query { user,
test/Feature/Holistic/introspection/schemaTypes/__Type/response.json view
@@ -51,7 +51,7 @@ "name": "Boolean", "ofType": null },- "defaultValue": null+ "defaultValue": "false" } ], "type": {@@ -118,7 +118,7 @@ "name": "Boolean", "ofType": null },- "defaultValue": null+ "defaultValue": "false" } ], "type": {
test/Feature/Holistic/parsing/complex/response.json view
@@ -1,7 +1,7 @@ { "errors": [ {- "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [null,[[],[{\"uid\":\"1\"}]]].",+ "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [null, [[], [{uid: \"1\"}]]].", "locations": [{ "line": 8, "column": 23 }] }, {@@ -9,7 +9,7 @@ "locations": [{ "line": 11, "column": 23 }] }, {- "message": "Argument \"cityID\" got invalid value. Expected type \"TestEnum!\" found \"HH\".",+ "message": "Argument \"cityID\" got invalid value. Expected type \"TestEnum!\" found HH.", "locations": [{ "line": 15, "column": 25 }] }, {
test/Feature/Holistic/selection/directives/default/wrongArgumentType/response.json view
@@ -17,7 +17,7 @@ "locations": [{ "line": 7, "column": 31 }] }, {- "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found \"SomeEnum\".",+ "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found SomeEnum.", "locations": [{ "line": 8, "column": 29 }] }, {
+ test/Feature/Input/DefaultValue/API.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Feature.Input.DefaultValue.API+ ( api,+ rootResolver,+ )+where++import Data.Morpheus (interpreter)+import Data.Morpheus.Document (importGQLDocument)+import Data.Morpheus.Types+ ( GQLRequest,+ GQLResponse,+ ID (..),+ RootResolver (..),+ Undefined (..),+ )+import Data.Text (Text, pack)++importGQLDocument "test/Feature/Input/DefaultValue/schema.gql"++rootResolver :: RootResolver IO () Query Undefined Undefined+rootResolver =+ RootResolver+ { queryResolver = Query {user, testSimple},+ mutationResolver = Undefined,+ subscriptionResolver = Undefined+ }+ where+ user :: Applicative m => m (Maybe (User m))+ user =+ pure+ $ Just+ $ User+ { inputs = pure . pack . show+ }+ testSimple = pure . pack . show++-----------------------------------+api :: GQLRequest -> IO GQLResponse+api = interpreter rootResolver
+ test/Feature/Input/DefaultValue/cases.json view
@@ -0,0 +1,22 @@+[+ {+ "path": "intorspection/input-simple",+ "description": "test introspection of input Object"+ },+ {+ "path": "intorspection/input-compound",+ "description": "test introspection of input Object with inputObject as field"+ },+ {+ "path": "intorspection/arguments",+ "description": "test introspection of argument default values"+ },+ {+ "path": "resolving/simple",+ "description": "missing fields must be filled with default values"+ },+ {+ "path": "resolving/compound",+ "description": "missing fields must be filled with default values"+ }+]
+ test/Feature/Input/DefaultValue/intorspection/arguments/query.gql view
@@ -0,0 +1,76 @@+query Get__Type {+ type2: __type(name: "User") {+ ...FullType+ }+}++fragment FullType on __Type {+ kind+ name+ fields(includeDeprecated: true) {+ name+ args {+ ...InputValue+ }+ type {+ ...TypeRef+ }+ isDeprecated+ deprecationReason+ }+ inputFields {+ ...InputValue+ }+ interfaces {+ ...TypeRef+ }+ enumValues(includeDeprecated: true) {+ name+ isDeprecated+ deprecationReason+ }+ possibleTypes {+ ...TypeRef+ }+}++fragment InputValue on __InputValue {+ name+ type {+ ...TypeRef+ }+ defaultValue+}++fragment TypeRef on __Type {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ }+ }+ }+ }+ }+ }+ }+}
+ test/Feature/Input/DefaultValue/intorspection/arguments/response.json view
@@ -0,0 +1,61 @@+{+ "data": {+ "type2": {+ "kind": "OBJECT",+ "name": "User",+ "fields": [+ {+ "name": "inputs",+ "args": [+ {+ "name": "inputCompound",+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": {+ "kind": "INPUT_OBJECT",+ "name": "InputCompound",+ "ofType": null+ }+ },+ "defaultValue": "{inputField2: \"value from argument inputCompound\", inputField3: [{fieldWithDefault: \"value2 from inputField3\", simpleField: EnumA}, {fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumA}], inputField4: [{fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumB}]}"+ },+ {+ "name": "input",+ "type": {+ "kind": "INPUT_OBJECT",+ "name": "InputSimple",+ "ofType": null+ },+ "defaultValue": null+ },+ {+ "name": "comment",+ "type": {+ "kind": "SCALAR",+ "name": "String",+ "ofType": null+ },+ "defaultValue": "\"test string\""+ }+ ],+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": {+ "kind": "SCALAR",+ "name": "String",+ "ofType": null+ }+ },+ "isDeprecated": false,+ "deprecationReason": null+ }+ ],+ "inputFields": null,+ "interfaces": [],+ "enumValues": null,+ "possibleTypes": null+ }+ }+}
+ test/Feature/Input/DefaultValue/intorspection/input-compound/query.gql view
@@ -0,0 +1,76 @@+query Get__Type {+ type2: __type(name: "InputCompound") {+ ...FullType+ }+}++fragment FullType on __Type {+ kind+ name+ fields(includeDeprecated: true) {+ name+ args {+ ...InputValue+ }+ type {+ ...TypeRef+ }+ isDeprecated+ deprecationReason+ }+ inputFields {+ ...InputValue+ }+ interfaces {+ ...TypeRef+ }+ enumValues(includeDeprecated: true) {+ name+ isDeprecated+ deprecationReason+ }+ possibleTypes {+ ...TypeRef+ }+}++fragment InputValue on __InputValue {+ name+ type {+ ...TypeRef+ }+ defaultValue+}++fragment TypeRef on __Type {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ }+ }+ }+ }+ }+ }+ }+}
+ test/Feature/Input/DefaultValue/intorspection/input-compound/response.json view
@@ -0,0 +1,61 @@+{+ "data": {+ "type2": {+ "kind": "INPUT_OBJECT",+ "name": "InputCompound",+ "fields": null,+ "inputFields": [+ {+ "name": "inputField2",+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": {+ "kind": "SCALAR",+ "name": "String",+ "ofType": null+ }+ },+ "defaultValue": "\"value from inputField2\""+ },+ {+ "name": "inputField3",+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": {+ "kind": "LIST",+ "name": null,+ "ofType": {+ "kind": "INPUT_OBJECT",+ "name": "InputSimple",+ "ofType": null+ }+ }+ },+ "defaultValue": "[{fieldWithDefault: \"value2 from inputField3\", simpleField: EnumA}, {fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumA}]"+ },+ {+ "name": "inputField4",+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": {+ "kind": "LIST",+ "name": null,+ "ofType": {+ "kind": "INPUT_OBJECT",+ "name": "InputSimple",+ "ofType": null+ }+ }+ },+ "defaultValue": "[{fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumB}]"+ }+ ],+ "interfaces": null,+ "enumValues": null,+ "possibleTypes": null+ }+ }+}
+ test/Feature/Input/DefaultValue/intorspection/input-simple/query.gql view
@@ -0,0 +1,76 @@+query Get__Type {+ type2: __type(name: "InputSimple") {+ ...FullType+ }+}++fragment FullType on __Type {+ kind+ name+ fields(includeDeprecated: true) {+ name+ args {+ ...InputValue+ }+ type {+ ...TypeRef+ }+ isDeprecated+ deprecationReason+ }+ inputFields {+ ...InputValue+ }+ interfaces {+ ...TypeRef+ }+ enumValues(includeDeprecated: true) {+ name+ isDeprecated+ deprecationReason+ }+ possibleTypes {+ ...TypeRef+ }+}++fragment InputValue on __InputValue {+ name+ type {+ ...TypeRef+ }+ defaultValue+}++fragment TypeRef on __Type {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ }+ }+ }+ }+ }+ }+ }+}
+ test/Feature/Input/DefaultValue/intorspection/input-simple/response.json view
@@ -0,0 +1,36 @@+{+ "data": {+ "type2": {+ "kind": "INPUT_OBJECT",+ "name": "InputSimple",+ "fields": null,+ "inputFields": [+ {+ "name": "fieldWithDefault",+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": {+ "kind": "SCALAR",+ "name": "ID",+ "ofType": null+ }+ },+ "defaultValue": "\"value from fieldWithDefault\""+ },+ {+ "name": "simpleField",+ "type": {+ "kind": "ENUM",+ "name": "TestEnum",+ "ofType": null+ },+ "defaultValue": null+ }+ ],+ "interfaces": null,+ "enumValues": null,+ "possibleTypes": null+ }+ }+}
+ test/Feature/Input/DefaultValue/resolving/compound/query.gql view
@@ -0,0 +1,5 @@+query Compound {+ user {+ inputs(input: { simpleField: EnumA })+ }+}
+ test/Feature/Input/DefaultValue/resolving/compound/response.json view
@@ -0,0 +1,7 @@+{+ "data": {+ "user": {+ "inputs": "InputsArgs {inputCompound = InputCompound {inputField2 = \"value from argument inputCompound\", inputField3 = [Just (InputSimple {fieldWithDefault = ID {unpackID = \"value2 from inputField3\"}, simpleField = Just EnumA}),Just (InputSimple {fieldWithDefault = ID {unpackID = \"value from fieldWithDefault\"}, simpleField = Just EnumA})], inputField4 = [Just (InputSimple {fieldWithDefault = ID {unpackID = \"value from fieldWithDefault\"}, simpleField = Just EnumB})]}, input = Just (InputSimple {fieldWithDefault = ID {unpackID = \"value from fieldWithDefault\"}, simpleField = Just EnumA}), comment = Just \"test string\"}"+ }+ }+}
+ test/Feature/Input/DefaultValue/resolving/simple/query.gql view
@@ -0,0 +1,3 @@+query Simple {+ testSimple(i1: { simpleField: EnumA })+}
+ test/Feature/Input/DefaultValue/resolving/simple/response.json view
@@ -0,0 +1,5 @@+{+ "data": {+ "testSimple": "TestSimpleArgs {i1 = Just (InputSimple {fieldWithDefault = ID {unpackID = \"value from fieldWithDefault\"}, simpleField = Just EnumA}), i2 = Just \"test string\"}"+ }+}
+ test/Feature/Input/DefaultValue/schema.gql view
@@ -0,0 +1,34 @@+enum TestEnum {+ EnumA+ EnumB+ EnumC+}++input InputSimple {+ fieldWithDefault: ID! = "value from fieldWithDefault"+ simpleField: TestEnum+}++input InputCompound {+ inputField2: String! = "value from inputField2"+ inputField3: [InputSimple]! = [+ { fieldWithDefault: "value2 from inputField3", simpleField: EnumA }+ { simpleField: EnumA }+ ]+ inputField4: [InputSimple]! = [{ simpleField: EnumB }]+}++type User {+ inputs(+ inputCompound: InputCompound! = {+ inputField2: "value from argument inputCompound"+ }+ input: InputSimple+ comment: String = "test string"+ ): String!+}++type Query {+ user: User+ testSimple(i1: InputSimple, i2: String = "test string"): String!+}
test/Feature/Input/Enum/API.hs view
@@ -11,7 +11,7 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Kind (ENUM)-import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..))+import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLType (..), RootResolver (..), Undefined (..)) import GHC.Generics (Generic) data TwoCon@@ -62,9 +62,9 @@ } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query {test = testRes, test2 = testRes, test3 = testRes}, mutationResolver = Undefined, subscriptionResolver = Undefined
test/Feature/Input/Enum/cases.json view
@@ -36,7 +36,23 @@ "description": "decode string to correct Haskell Enum Representation" }, {- "path":"decodeInvalidValue",- "description":"fail on invalid enum value"+ "path": "decodeInvalidValue",+ "description": "fail on invalid enum value"+ },+ {+ "path": "invalidStringInput",+ "description": "fail on String inputs for Enum Values"+ },+ {+ "path": "invalidStringDefaultValue",+ "description": "fail on String inputs for Enum Values"+ },+ {+ "path": "validEnumFromJSONVariable",+ "description": "accept strings as enum if it is received from json variable"+ },+ {+ "path": "invalidEnumFromJSONVariable",+ "description": "reject invalid strings as enum from json variable" } ]
test/Feature/Input/Enum/decodeInvalidValue/response.json view
@@ -1,7 +1,7 @@ { "errors": [ {- "message": "Argument \"level\" got invalid value. Expected type \"TwoCon!\" found \"LK\".",+ "message": "Argument \"level\" got invalid value. Expected type \"TwoCon!\" found LK.", "locations": [ { "line": 2,
+ test/Feature/Input/Enum/invalidEnumFromJSONVariable/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding($x: TwoCon!) {+ test2(level: $x)+}
+ test/Feature/Input/Enum/invalidEnumFromJSONVariable/response.json view
@@ -0,0 +1,8 @@+{+ "errors": [+ {+ "message": "Variable \"$x\" got invalid value. Expected type \"TwoCon!\" found \"BLA\".",+ "locations": [{ "line": 1, "column": 21 }]+ }+ ]+}
+ test/Feature/Input/Enum/invalidEnumFromJSONVariable/variables.json view
@@ -0,0 +1,1 @@+{ "x": "BLA" }
+ test/Feature/Input/Enum/invalidStringDefaultValue/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding($x: TwoCon! = "LA") {+ test2(level: $x)+}
+ test/Feature/Input/Enum/invalidStringDefaultValue/response.json view
@@ -0,0 +1,8 @@+{+ "errors": [+ {+ "message": "Variable \"$x\" got invalid value. Expected type \"TwoCon!\" found \"LA\".",+ "locations": [{ "line": 1, "column": 21 }]+ }+ ]+}
+ test/Feature/Input/Enum/invalidStringInput/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+ test2(level: "LA")+}
+ test/Feature/Input/Enum/invalidStringInput/response.json view
@@ -0,0 +1,8 @@+{+ "errors": [+ {+ "message": "Argument \"level\" got invalid value. Expected type \"TwoCon!\" found \"LA\".",+ "locations": [{ "line": 2, "column": 9 }]+ }+ ]+}
+ test/Feature/Input/Enum/validEnumFromJSONVariable/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding($x: TwoCon!) {+ test2(level: $x)+}
+ test/Feature/Input/Enum/validEnumFromJSONVariable/response.json view
@@ -0,0 +1,5 @@+{+ "data": {+ "test2": "LA"+ }+}
+ test/Feature/Input/Enum/validEnumFromJSONVariable/variables.json view
@@ -0,0 +1,1 @@+{ "x": "LA" }
test/Feature/Input/Object/API.hs view
@@ -14,8 +14,8 @@ import Data.Morpheus.Types ( GQLRequest, GQLResponse,- GQLRootResolver (..), GQLType (..),+ RootResolver (..), Undefined (..), ) import Data.Text@@ -50,9 +50,9 @@ } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query {input = testRes}, mutationResolver = Undefined, subscriptionResolver = Undefined
test/Feature/Input/Scalar/API.hs view
@@ -13,8 +13,8 @@ import Data.Morpheus.Types ( GQLRequest, GQLResponse,- GQLRootResolver (..), GQLType,+ RootResolver (..), Undefined (..), ) import GHC.Generics (Generic)@@ -36,9 +36,9 @@ } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query {testFloat = testRes, testInt = testRes}, mutationResolver = Undefined, subscriptionResolver = Undefined
test/Feature/InputType/API.hs view
@@ -13,9 +13,9 @@ import Data.Morpheus.Types ( GQLRequest, GQLResponse,- GQLRootResolver (..), GQLType (..), ResolverQ,+ RootResolver (..), Undefined (..), ) import Data.Text (Text)@@ -44,9 +44,9 @@ } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query { q1 =
test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json view
@@ -1,7 +1,7 @@ { "errors": [ {- "message": "Variable \"$v1\" got invalid value. Expected type \"[[[Int!]!]]!\" found {\"id\":\"12\"}.",+ "message": "Variable \"$v1\" got invalid value. Expected type \"[[[Int!]!]]!\" found {id: \"12\"}.", "locations": [ { "line": 1,
test/Feature/Schema/API.hs view
@@ -10,7 +10,7 @@ where import Data.Morpheus (interpreter)-import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..))+import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLType (..), RootResolver (..), Undefined (..)) import Data.Text (Text) import qualified Feature.Schema.A2 as A2 (A (..)) import GHC.Generics (Generic)@@ -27,9 +27,9 @@ } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query {a1 = A "" 0, a2 = A2.A 0}, mutationResolver = Undefined, subscriptionResolver = Undefined
test/Feature/TypeInference/API.hs view
@@ -16,8 +16,8 @@ import Data.Morpheus.Types ( GQLRequest, GQLResponse,- GQLRootResolver (..), GQLType (..),+ RootResolver (..), Undefined (..), ) import Data.Text@@ -84,9 +84,9 @@ } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query {deity = deityRes, character, showMonster}, mutationResolver = Undefined, subscriptionResolver = Undefined
test/Feature/UnionType/API.hs view
@@ -13,9 +13,9 @@ import Data.Morpheus.Types ( GQLRequest, GQLResponse,- GQLRootResolver (..), GQLType (..), ResolverQ,+ RootResolver (..), Undefined (..), ) import Data.Text (Text)@@ -54,9 +54,9 @@ resolveUnion _ = return [SumA A {aText = "at", aInt = 1}, SumB B {bText = "bt", bInt = 2}] -rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query { union = resolveUnion,
test/Feature/WrappedTypeName/API.hs view
@@ -15,8 +15,8 @@ Event, GQLRequest, GQLResponse,- GQLRootResolver (..), GQLType (..),+ RootResolver (..), constRes, subscribe, )@@ -66,9 +66,9 @@ } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription+rootResolver :: RootResolver IO EVENT Query Mutation Subscription rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query {a1 = WA {aText = const $ pure "test1", aInt = 0}, a2 = Nothing, a3 = Nothing}, mutationResolver = Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing}, subscriptionResolver =
test/Rendering/Schema.hs view
@@ -18,10 +18,10 @@ import Data.Morpheus.Document (importGQLDocumentWithNamespace) import Data.Morpheus.Kind (SCALAR) import Data.Morpheus.Types- ( GQLRootResolver (..),- GQLScalar (..),+ ( GQLScalar (..), GQLType (..), ID (..),+ RootResolver (..), ScalarValue (..), Undefined (..), )@@ -42,5 +42,5 @@ importGQLDocumentWithNamespace "test/Rendering/schema.gql" -schemaProxy :: Proxy (GQLRootResolver IO () Query Undefined Undefined)-schemaProxy = Proxy @(GQLRootResolver IO () Query Undefined Undefined)+schemaProxy :: Proxy (RootResolver IO () Query Undefined Undefined)+schemaProxy = Proxy @(RootResolver IO () Query Undefined Undefined)
test/Spec.hs view
@@ -8,6 +8,9 @@ import qualified Feature.Holistic.API as Holistic ( api, )+import qualified Feature.Input.DefaultValue.API as DefaultValue+ ( api,+ ) import qualified Feature.Input.Enum.API as InputEnum ( api, )@@ -50,6 +53,7 @@ inputEnum <- testFeature InputEnum.api "Feature/Input/Enum" inputScalar <- testFeature InputScalar.api "Feature/Input/Scalar" inputObject <- testFeature InputObject.api "Feature/Input/Object"+ defaultValue <- testFeature DefaultValue.api "Feature/Input/DefaultValue" inference <- testFeature Inference.api "Feature/TypeInference" subscription <- testSubsriptions defaultMain@@ -65,6 +69,7 @@ inputObject, testSchemaRendering, inference,- subscription+ subscription,+ defaultValue ] )
test/Subscription/API.hs view
@@ -16,8 +16,8 @@ import Data.Morpheus.Document (importGQLDocument) import Data.Morpheus.Types ( Event (..),- GQLRootResolver (..), Input,+ RootResolver (..), Stream, subscribe, )@@ -49,9 +49,9 @@ age = pure age } -rootResolver :: GQLRootResolver (SubM EVENT) EVENT Query Mutation Subscription+rootResolver :: RootResolver (SubM EVENT) EVENT Query Mutation Subscription rootResolver =- GQLRootResolver+ RootResolver { queryResolver = Query { queryField = pure ""