morpheus-graphql 0.14.1 → 0.15.0
raw patch · 63 files changed
+2487/−2057 lines, 63 filesdep ~morpheus-graphql-core
Dependency ranges changed: morpheus-graphql-core
Files
- README.md +11/−11
- changelog.md +123/−38
- morpheus-graphql.cabal +13/−11
- src/Data/Morpheus.hs +37/−4
- src/Data/Morpheus/Document.hs +17/−5
- src/Data/Morpheus/Kind.hs +27/−19
- src/Data/Morpheus/Server.hs +22/−29
- src/Data/Morpheus/Server/Deriving/App.hs +49/−0
- src/Data/Morpheus/Server/Deriving/Channels.hs +46/−59
- src/Data/Morpheus/Server/Deriving/Decode.hs +58/−35
- src/Data/Morpheus/Server/Deriving/Encode.hs +128/−188
- src/Data/Morpheus/Server/Deriving/Interpreter.hs +0/−74
- src/Data/Morpheus/Server/Deriving/Introspect.hs +0/−684
- src/Data/Morpheus/Server/Deriving/Resolve.hs +0/−82
- src/Data/Morpheus/Server/Deriving/Schema.hs +273/−0
- src/Data/Morpheus/Server/Deriving/Schema/Internal.hs +417/−0
- src/Data/Morpheus/Server/Deriving/Utils.hs +215/−23
- src/Data/Morpheus/Server/Internal/TH/Decode.hs +11/−2
- src/Data/Morpheus/Server/Internal/TH/Types.hs +16/−2
- src/Data/Morpheus/Server/Internal/TH/Utils.hs +10/−2
- src/Data/Morpheus/Server/Playground.hs +7/−1
- src/Data/Morpheus/Server/TH/Compile.hs +10/−7
- src/Data/Morpheus/Server/TH/Declare.hs +22/−50
- src/Data/Morpheus/Server/TH/Declare/Channels.hs +0/−79
- src/Data/Morpheus/Server/TH/Declare/Decode.hs +0/−60
- src/Data/Morpheus/Server/TH/Declare/Encode.hs +0/−107
- src/Data/Morpheus/Server/TH/Declare/GQLType.hs +180/−36
- src/Data/Morpheus/Server/TH/Declare/Introspect.hs +0/−171
- src/Data/Morpheus/Server/TH/Declare/Type.hs +49/−35
- src/Data/Morpheus/Server/TH/Transform.hs +23/−9
- src/Data/Morpheus/Server/Types/GQLType.hs +132/−96
- src/Data/Morpheus/Server/Types/SchemaT.hs +132/−0
- src/Data/Morpheus/Server/Types/Types.hs +15/−14
- src/Data/Morpheus/Types.hs +35/−13
- src/Data/Morpheus/Types/Internal/Subscription.hs +12/−6
- src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs +17/−2
- src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs +16/−5
- src/Data/Morpheus/Types/Internal/Subscription/Stream.hs +3/−3
- test/Feature/Holistic/API.hs +80/−26
- test/Feature/Holistic/arguments/nameConflict/response.json +9/−0
- test/Feature/Holistic/cases.json +13/−5
- test/Feature/Holistic/fragment/nameCollision/response.json +9/−0
- test/Feature/Holistic/namespace/enum-fail-on-fullname/query.gql +3/−0
- test/Feature/Holistic/namespace/enum-fail-on-fullname/response.json +13/−0
- test/Feature/Holistic/namespace/enum/query.gql +77/−0
- test/Feature/Holistic/namespace/enum/response.json +22/−0
- test/Feature/Holistic/reservedNames/response.json +2/−1
- test/Feature/Holistic/schema-ext.gql +9/−0
- test/Feature/Holistic/schema.gql +13/−7
- test/Feature/Holistic/selection/mergeConflict/union/response.json +9/−0
- test/Feature/Input/Enum/API.hs +1/−1
- test/Feature/Input/Object/API.hs +1/−1
- test/Feature/Input/Scalar/API.hs +1/−1
- test/Feature/InputType/variables/nameCollision/response.json +9/−0
- test/Feature/TypeInference/API.hs +1/−1
- test/Rendering/Schema.hs +2/−2
- test/Rendering/schema.gql +10/−1
- test/Subscription/API.hs +12/−8
- test/Subscription/Case/ApolloRequest.hs +18/−22
- test/Subscription/Case/Publishing.hs +2/−2
- test/Subscription/Test.hs +1/−1
- test/Subscription/Utils.hs +31/−12
- test/TestFeature.hs +13/−4
README.md view
@@ -1,9 +1,9 @@ # Morpheus GraphQL [](https://hackage.haskell.org/package/morpheus-graphql)  -Build GraphQL APIs with your favourite functional language!+Build GraphQL APIs with your favorite functional language! Morpheus GraphQL (Server & Client) helps you to build GraphQL APIs in Haskell with native Haskell types.-Morpheus will convert your Haskell types to a GraphQL schema and all your resolvers are just native Haskell functions. Mopheus GraphQL can also convert your GraphQL Schema or Query to Haskell types and validate them in compile time.+Morpheus will convert your Haskell types to a GraphQL schema and all your resolvers are just native Haskell functions. Morpheus GraphQL can also convert your GraphQL Schema or Query to Haskell types and validate them in compile time. Morpheus is still in an early stage of development, so any feedback is more than welcome, and we appreciate any contribution! Just open an issue here on GitHub, or join [our Slack channel](https://morpheus-graphql-slack-invite.herokuapp.com/) to get in touch.@@ -104,12 +104,12 @@ `descriptions` and `deprecations` will be displayed in introspection. -`importGQLDocumentWithNamespace` will generate Types with namespaced fields. If you don't need napespacing use `importGQLDocument`+`importGQLDocumentWithNamespace` will generate Types with namespaced fields. If you don't need namespace use `importGQLDocument` ### with Native Haskell Types To define a GraphQL API with Morpheus we start by defining the API Schema as a native Haskell data type,-which derives the `Generic` typeclass. Lazily resolvable fields on this `Query` type are defined via `a -> ResolverQ () IO b`, representing resolving a set of arguments `a` to a concrete value `b`.+which derives the `Generic` typeClass. Lazily resolvable fields on this `Query` type are defined via `a -> ResolverQ () IO b`, representing resolving a set of arguments `a` to a concrete value `b`. ```haskell data Query m = Query@@ -232,13 +232,13 @@ ```haskell data Character- = CharacterDeity Deity -- Only <tyconName><conName> should generate direct link+ = CharacterDeity Deity -- Only <tyConName><conName> should generate direct link -- RECORDS | Creature { creatureName :: Text, creatureAge :: Int } --- Types | SomeDeity Deity | CharacterInt Int- | SomeMutli Int Text+ | SomeMulti Int Text --- ENUMS | Zeus | Cronus@@ -257,7 +257,7 @@ | Creature | SomeDeity # wrapped union: because "Character" <> "Deity" /= SomeDeity | CharacterInt- | SomeMutli+ | SomeMulti | CharacterEnumObject # no-argument constructors all wrapped into an enum type Creature { creatureName: String!@@ -272,7 +272,7 @@ _0: Int! } -type SomeMutli {+type SomeMulti { _0: Int! _1: String! }@@ -289,7 +289,7 @@ ``` By default, union members will be generated with wrapper objects.-There is one exception to this: if a constructor of a type is the type name concatinated with the name of the contained type, it will be referenced directly.+There is one exception to this: if a constructor of a type is the type name concatenated with the name of the contained type, it will be referenced directly. That is, given: ```haskell@@ -337,7 +337,7 @@ } ``` -- for all other unions will be generated new object type. for types without record syntax, fields will be automatally indexed.+- for all other unions will be generated new object type. for types without record syntax, fields will be automatically indexed. - all empty constructors in union will be summed in type `<tyConName>Enum` (e.g `CharacterEnum`), this enum will be wrapped in `CharacterEnumObject` and added to union members. @@ -487,7 +487,7 @@ -- immediate response on failures requireAuthorized pure $ \(Event _ content) -> do- -- exectues on every event+ -- executes on every event lift (getDBAddress content) ```
changelog.md view
@@ -1,5 +1,90 @@ # Changelog +## 0.15.0 - 12.09.2020++### new features++- custom operation root types: e.g++ ```hs+ RootResolver IO () MyQuery MyMutation Undefined+ ```++ creates app with:++ ```graphql+ schema {+ query: MyQuery+ mutation: MyMutation+ }+ ```++- type : `App event m` and `deriveApp`++ ```hs+ app :: App EVENT IO+ app = runApp (deriveApp root)++ api :: a -> IO b+ api = runApp (deriveApp root)+ ```++- `App` supports semigroup(`schema Stitching`): if whe have two graphql apps++ ```hs+ mergedApi :: a -> m b+ mergedApi = runApp (deriveApp root <> deriveApp root2)+ ```++- `GQLType` exposes `typeOptions` to modify labels: `typeOptions :: f a -> GQLTypeOptions`++ where++ ```haskell+ GQLTypeOptions {+ fieldLabelModifier :: String -> String,+ constructorTagModifier :: String -> String+ }+ ```++- you can use `GQLType.getDescriptions` to document field or enum Values++- with `importGQLDocumentWithNamespace` now you can use Enums with Colliding Values:++ ```graphql+ enum X {+ A+ }++ enum Y {+ A+ }+ ```++ they will be namespaced to. `XA` and `YA`++### Breaking Changes++- `importGQLDocumentWithNamespace` they will be namespaced enum Values+- Argument types must have `GQLType` instances+- in `Data.Morpheus.Server`:++ - removed `subscriptionApp`+ - changed `webSocketsApp` type to `App e m -> m (ServerApp, e -> m ())`+ - changed `httpPubApp` type to `[e -> m ()] -> App e m -> a -> m b`++- removed `Stream` from `Data.Morpheus.Types`++- removed class `Interpreter`, `interpreter` is now just regular function.++ ```hs+ interpreter = runApp . deriveApp+ ```++### Minor Changes++- internal refactoring+ ## 0.14.1 - 16.08.2020 ## 0.14.0 - 15.08.2020@@ -7,7 +92,7 @@ ### new features - query validation supports interfaces-- `debugInterpreter`: displays internal context on grahql errors+- `debugInterpreter`: displays internal context on graphql errors - compileTimeSchemaValidation : morpheus validates schema at runtime (after the schema derivation). to be ensure that only correct api is compiled.@@ -27,9 +112,9 @@ query { createDeity( name: """- powerqwe+ power qwe bla \n sd- blu \\ dete+ blu \\ date """ ) { name@@ -62,7 +147,7 @@ - `Context' renamed to`ResolverContext' - internal refactoring: changed AST-- root subscribtion fields must be wrapped with `SubscriptionField`. e.g:+- root subscription fields must be wrapped with `SubscriptionField`. e.g: ```haskell data Subscription (m :: * -> *) = Subscription@@ -75,13 +160,13 @@ - signature of `subscribe` is changed. now you can use it as followed: ```haskell-resolveNewAdress :: SubscriptionField (ResolverS EVENT IO Address)-resolveNewAdress = subscribe ADDRESS $ do+resolveNewAddress :: SubscriptionField (ResolverS EVENT IO Address)+resolveNewAddress = subscribe ADDRESS $ do -- executed only once -- immediate response on failures requireAuthorized pure $ \(Event _ content) -> do- -- exectues on every event+ -- executes on every event lift (getDBAddress content) ``` @@ -140,27 +225,27 @@ - `Semigroup` support for Resolver - `MonadFail` Support for Resolver-- flexible resolvers: `ResolverO`, `ResolverQ` , `RwsolverM`, `ResolverS`+- flexible resolvers: `ResolverO`, `ResolverQ` , `ResolverM`, `ResolverS` they can handle object and scalar types: ```hs -- if we have record and regular Int data Object m = Object { field :: m Int } --- we canwrite--- handes kind : (* -> *) -> *+-- we can write+-- handles kind : (* -> *) -> * resolveObject :: ResolverO o EVENT IO Object -- is alias to: Resolver o () IO (Object (Resolver o () IO)) -- or--- handes kind : *+-- handles kind : * resolveInt :: ResolverO o EVENT IO Int -- is alias to: Resolver o () IO Int ``` -the resolvers : `ResolverQ` , `RwsolverM`, `ResolverS` , are like+the resolvers : `ResolverQ` , `ResolverM`, `ResolverS` , are like `ResolverO` but with `QUERY` , `MUTATION` and `SUBSCRIPTION` as argument. -- flexible compsed Resolver Type alias: `ComposedResolver`. extends `ResolverO` with+- flexible composed Resolver Type alias: `ComposedResolver`. extends `ResolverO` with parameter `(f :: * -> *)`. so that you can compose Resolvers e.g: ```hs@@ -182,7 +267,7 @@ ### minor -- fixed subscription sessions, srarting new session does not affects old ones.+- fixed subscription sessions, starting new session does not affects old ones. - added tests for subscriptions ## 0.11.0 - 01.05.2020@@ -190,7 +275,7 @@ ### Breaking Changes - 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`+- for Variant selection inputUnion uses `inputname` instead of `__typename` - in `Data.Morpheus.Server` @@ -307,7 +392,7 @@ ### minor -- monadio instance for resolvers. thanks @dandoh+- monad instance for resolvers. thanks @dandoh - example using stm, authentication, monad transformers. thanks @dandoh - added dependency `mtl` @@ -325,7 +410,7 @@ - liftEither support in MutResolver (#351) - selection of `__typename` on object und union objects (#337)-- auto inferece of external types in gql document (#343)+- auto inference of external types in gql document (#343) th will generate field `m (Type m)` if type has an argument @@ -367,24 +452,24 @@ - support of resolver fields `m type` for the fields without arguments ```hs- data Diety m = Deity {+ data Deity m = Deity { name :: m Text } -- is equal to- data Diety m = Deity {+ data Deity m = Deity { name :: () -> m Text } ``` -- template haskell generates `m type` insead of `() -> m type` for fields without argument (#334)+- template haskell generates `m type` instead of `() -> m type` for fields without argument (#334) ```hs- data Diety m = Deity {+ data Deity m = Deity { name :: (Arrow () (m Text)), power :: (Arrow () (m (Maybe Text))) } -- changed to- data Diety m = Deity {+ data Deity m = Deity { name :: m Text, power :: m (Maybe Text) }@@ -397,7 +482,7 @@ - deprecated: `INPUT_OBJECT`, `OBJECT`, `UNION`, - use `INPUT` instead of `INPUT_OBJECT`- - use `deriving(GQLType)` insead of `OBJECT` or `UNION`+ - use `deriving(GQLType)` instead of `OBJECT` or `UNION` - only namespaced Unions generate regular graphql Union, other attempts will be wrapped inside an object with constructor name : @@ -443,13 +528,13 @@ } deriving (Generic, GQLType) data Character =- CharacterDeity Deity -- Only <tyconName><conName> should generate direct link+ CharacterDeity Deity -- Only <tyConName><conName> should generate direct link -- RECORDS | Creature { creatureName :: Text, creatureAge :: Int } --- Types | SomeDeity Deity | CharacterInt Int- | SomeMutli Int Text+ | SomeMulti Int Text --- ENUMS | Zeus | Cronus deriving (Generic, GQLType)@@ -476,7 +561,7 @@ | Creature | SomeDeity | CharacterInt- | SomeMutli+ | SomeMulti | CharacterEnumObject type Creature {@@ -492,7 +577,7 @@ _0: Int! } -type SomeMutli {+type SomeMulti { _0: Int! _1: String! }@@ -520,7 +605,7 @@ | ... ``` -- for union recrods (`Creature { creatureName :: Text, creatureAge :: Int }`) will be referenced in union type, plus type `Creature`will be added in schema.+- for union records (`Creature { creatureName :: Text, creatureAge :: Int }`) will be referenced in union type, plus type `Creature`will be added in schema. e.g @@ -539,7 +624,7 @@ - all empty constructors in union will be summed in type `<tyConName>Enum` (e.g `CharacterEnum`), this enum will be wrapped in `CharacterEnumObject` and this type will be added to union `Character`. as in example above - - there is only types left with form `TypeName Type1 2Type ..`(e.g `SomeDeity Deity` ,`CharacterInt Int`, `SomeMutli Int Text`),+ - there is only types left with form `TypeName Type1 2Type ..`(e.g `SomeDeity Deity` ,`CharacterInt Int`, `SomeMulti Int Text`), morpheus will generate objet type from it: @@ -557,7 +642,7 @@ ### Fixed -- on filed resolver was displayed. unexhausted case exception of graphql error+- on filed resolver was displayed. Unexhausted case exception of graphql error - support of signed numbers (e.g `-4`) - support of round floats (e.g `1.000`) - validation checks undefined fields on inputObject@@ -565,7 +650,7 @@ ## [0.7.1] - 26.11.2019 -- max bound icludes: support-megaparsec-8.0+- max bound includes: support-megaparsec-8.0 ## [0.7.0] - 24.11.2019 @@ -692,7 +777,7 @@ `ResolveM EVENT IO Address` is same as `MutRes EVENT IO (Address (MutRes EVENT IO))` - is helpfull wenn you want to resolve GraphQL object+ is helpful when you want to resolve GraphQL object ### Fixed @@ -733,7 +818,7 @@ ### Fixed - can be parsed `implements` with multiple interfaces separated by `&`-- can be parsed default value on `inputobject`+- can be parsed default value on `inputObject` - Parser supports anonymous Operation: `query` , `mutation` , `subscription` for example: @@ -874,10 +959,10 @@ client will Generate: - `UserPerson` from `{user`- - `UserFriendPerson`: from `{user{freind`+ - `UserFriendPerson`: from `{user{friend` - `UserParentPerson`: from `{user{parent`- - `UserBestFriendPerson`: from `{user{bestFrend`- - `UserBestFriendParentPerson`: from `{user{bestFrend{parent`+ - `UserBestFriendPerson`: from `{user{bestFriend`+ - `UserBestFriendParentPerson`: from `{user{bestFriend{parent` - GraphQL Client Defines enums and Input Types only once per query and they don't collide @@ -902,7 +987,7 @@ ### Fixed -- `String` defined in GQLDcoument will be converted to `Text` by template haskell+- `String` defined in GQLDocument will be converted to `Text` by template haskell - `importGQLDocument` and `gqlDocument` supports Mutation, Subscription and Resolvers with custom Monad @@ -1098,7 +1183,7 @@ - WebSocket subProtocol changed from `graphql-subscriptions` to `graphql-ws` -- type familiy `KIND` is moved into typeClasses `GQLType`, so you should replace+- type family `KIND` is moved into typeClasses `GQLType`, so you should replace ```haskell type instance KIND Deity = OBJECT
morpheus-graphql.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 6aa7dd94a910283c164fa2b2c2f7e12b94bd464fc93383d8c68a691f56c888b0+-- hash: 1faac42698aa34bcc1613a4c75a9b6f8780c2189802d941fcf2f61e85bc7b027 name: morpheus-graphql-version: 0.14.1+version: 0.15.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql@@ -62,6 +62,8 @@ test/Feature/Holistic/introspection/schemaTypes/__Schema/query.gql test/Feature/Holistic/introspection/schemaTypes/__Type/query.gql test/Feature/Holistic/introspection/schemaTypes/__TypeKind/query.gql+ test/Feature/Holistic/namespace/enum-fail-on-fullname/query.gql+ test/Feature/Holistic/namespace/enum/query.gql test/Feature/Holistic/parsing/AnonymousOperation/mutation/query.gql test/Feature/Holistic/parsing/AnonymousOperation/query/query.gql test/Feature/Holistic/parsing/AnonymousOperation/subscription/query.gql@@ -81,6 +83,7 @@ test/Feature/Holistic/parsing/numbers/query.gql test/Feature/Holistic/parsing/singleLineComments/query.gql test/Feature/Holistic/reservedNames/query.gql+ test/Feature/Holistic/schema-ext.gql test/Feature/Holistic/schema.gql test/Feature/Holistic/selection/__typename/query.gql test/Feature/Holistic/selection/AliasResolve/query.gql@@ -229,6 +232,8 @@ test/Feature/Holistic/introspection/schemaTypes/__Schema/response.json test/Feature/Holistic/introspection/schemaTypes/__Type/response.json test/Feature/Holistic/introspection/schemaTypes/__TypeKind/response.json+ test/Feature/Holistic/namespace/enum-fail-on-fullname/response.json+ test/Feature/Holistic/namespace/enum/response.json test/Feature/Holistic/parsing/AnonymousOperation/mutation/response.json test/Feature/Holistic/parsing/AnonymousOperation/query/response.json test/Feature/Holistic/parsing/AnonymousOperation/subscription/response.json@@ -394,12 +399,12 @@ Data.Morpheus.Document Data.Morpheus.Types.Internal.Subscription other-modules:+ Data.Morpheus.Server.Deriving.App Data.Morpheus.Server.Deriving.Channels Data.Morpheus.Server.Deriving.Decode Data.Morpheus.Server.Deriving.Encode- Data.Morpheus.Server.Deriving.Interpreter- Data.Morpheus.Server.Deriving.Introspect- Data.Morpheus.Server.Deriving.Resolve+ Data.Morpheus.Server.Deriving.Schema+ Data.Morpheus.Server.Deriving.Schema.Internal Data.Morpheus.Server.Deriving.Utils Data.Morpheus.Server.Internal.TH.Decode Data.Morpheus.Server.Internal.TH.Types@@ -407,14 +412,11 @@ Data.Morpheus.Server.Playground Data.Morpheus.Server.TH.Compile Data.Morpheus.Server.TH.Declare- Data.Morpheus.Server.TH.Declare.Channels- 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.SchemaT Data.Morpheus.Server.Types.Types Data.Morpheus.Types.Internal.Subscription.Apollo Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore@@ -429,7 +431,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.14.0 && <0.15.0+ , morpheus-graphql-core >=0.15.0 && <0.16.0 , mtl >=2.0 && <=3.0 , scientific >=0.3.6.2 && <0.4 , template-haskell >=2.0 && <=3.0@@ -478,7 +480,7 @@ , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <9.0.0 , morpheus-graphql- , morpheus-graphql-core >=0.14.0 && <0.15.0+ , morpheus-graphql-core >=0.15.0 && <0.16.0 , mtl >=2.0 && <=3.0 , scientific >=0.3.6.2 && <0.4 , tasty
src/Data/Morpheus.hs view
@@ -1,9 +1,42 @@--- | Build GraphQL APIs with your favourite functional language!+{-# LANGUAGE FlexibleContexts #-}++-- | Build GraphQL APIs with your favorite functional language! module Data.Morpheus- ( Interpreter (..),+ ( interpreter,+ debugInterpreter,+ App,+ deriveApp,+ runApp,+ withDebugger, ) where -import Data.Morpheus.Server.Deriving.Interpreter- ( Interpreter (..),+-- MORPHEUS+import Data.Morpheus.Core+ ( App,+ runApp,+ withDebugger, )+import Data.Morpheus.Server.Deriving.App+ ( RootResolverConstraint,+ deriveApp,+ )+import Data.Morpheus.Types+ ( RootResolver (..),+ )+import Data.Morpheus.Types.IO (MapAPI)++-- | main query processor and resolver+interpreter ::+ (MapAPI a b, RootResolverConstraint m e query mut sub) =>+ RootResolver m e query mut sub ->+ a ->+ m b+interpreter = runApp . deriveApp++debugInterpreter ::+ (MapAPI a b, RootResolverConstraint m e query mut sub) =>+ RootResolver m e query mut sub ->+ a ->+ m b+debugInterpreter = runApp . withDebugger . deriveApp
src/Data/Morpheus/Document.hs view
@@ -16,10 +16,13 @@ import Data.Morpheus.Core ( render, )-import Data.Morpheus.Server.Deriving.Resolve+import Data.Morpheus.Server.Deriving.App ( RootResolverConstraint, deriveSchema, )+import Data.Morpheus.Server.Internal.TH.Types+ ( ServerDecContext (..),+ ) import Data.Morpheus.Server.TH.Compile ( compileDocument, gqlDocument,@@ -34,12 +37,21 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Language.Haskell.TH -importGQLDocument :: String -> Q [Dec]-importGQLDocument src = runIO (readFile src) >>= compileDocument False+importGQLDocument :: FilePath -> Q [Dec]+importGQLDocument src =+ runIO (readFile src)+ >>= compileDocument+ ServerDecContext+ { namespace = False+ } -importGQLDocumentWithNamespace :: String -> Q [Dec]+importGQLDocumentWithNamespace :: FilePath -> Q [Dec] importGQLDocumentWithNamespace src =- runIO (readFile src) >>= compileDocument True+ runIO (readFile src)+ >>= compileDocument+ ServerDecContext+ { namespace = True+ } -- | Generates schema.gql file from 'RootResolver' toGraphQLDocument ::
src/Data/Morpheus/Kind.hs view
@@ -11,19 +11,14 @@ UNION, INPUT_OBJECT, GQL_KIND,- Context (..),- VContext (..),- ResContext (..), OUTPUT, INPUT, INTERFACE,+ ToValue (..),+ isObject, ) where -import Data.Morpheus.Types.Internal.AST- ( OperationType (..),- )- data GQL_KIND = SCALAR | ENUM@@ -32,20 +27,33 @@ | WRAPPER | INTERFACE -data ResContext (kind :: GQL_KIND) (operation :: OperationType) event (m :: * -> *) value = ResContext+class ToValue (a :: GQL_KIND) where+ toValue :: f a -> GQL_KIND ---type ObjectConstraint a =+instance ToValue 'SCALAR where+ toValue _ = SCALAR --- | context , like Proxy with multiple parameters--- * 'kind': object, scalar, enum ...--- * 'a': actual gql type-data Context (kind :: GQL_KIND) a- = Context+instance ToValue 'ENUM where+ toValue _ = ENUM -newtype VContext (kind :: GQL_KIND) a = VContext- { unVContext :: a- }+instance ToValue 'WRAPPER where+ toValue _ = WRAPPER +instance ToValue 'INPUT where+ toValue _ = INPUT++instance ToValue 'OUTPUT where+ toValue _ = OUTPUT++instance ToValue 'INTERFACE where+ toValue _ = INTERFACE++isObject :: GQL_KIND -> Bool+isObject INPUT = True+isObject OUTPUT = True+isObject INTERFACE = True+isObject _ = False+ -- | GraphQL Scalar: Int, Float, String, Boolean or any user defined custom Scalar type type SCALAR = 'SCALAR @@ -61,12 +69,12 @@ -- | GraphQL input Object and input union type INPUT = 'INPUT -{-# DEPRECATED INPUT_OBJECT "use more generalised kind: INPUT" #-}+{-# DEPRECATED INPUT_OBJECT "use more generalized kind: INPUT" #-} -- | GraphQL input Object type INPUT_OBJECT = 'INPUT -{-# DEPRECATED UNION "use: deriving(GQLType), INPORTANT: only types with <type constructor name><constructor name> will sustain their form, other union constructors will be wrapped inside an new object" #-}+{-# DEPRECATED UNION "use: deriving(GQLType), IMPORTANT: only types with <type constructor name><constructor name> will sustain their form, other union constructors will be wrapped inside an new object" #-} -- | GraphQL Union type UNION = 'OUTPUT
src/Data/Morpheus/Server.hs view
@@ -13,7 +13,6 @@ module Data.Morpheus.Server ( webSocketsApp, httpPubApp,- subscriptionApp, ServerConstraint, httpPlayground, compileTimeSchemaValidation,@@ -27,7 +26,13 @@ ) -- MORPHEUS -import Data.Morpheus.Server.Deriving.Introspect+import Data.Foldable (traverse_)+import Data.Function ((&))+import Data.Morpheus.Core+ ( App,+ runApp,+ )+import Data.Morpheus.Server.Deriving.Schema ( compileTimeSchemaValidation, ) import Data.Morpheus.Server.Playground@@ -38,17 +43,16 @@ ( Event, ) import Data.Morpheus.Types.Internal.Subscription- ( HTTP,- Input (..),+ ( Input (..), Scope (..), Store (..),- Stream, WS, acceptApolloRequest, connectionThread, initDefaultStore, publishEventWith, runStreamHTTP,+ streamApp, ) import Network.WebSockets ( Connection,@@ -84,33 +88,32 @@ ( MonadIO m, MapAPI a b ) =>- (Input HTTP -> Stream HTTP e m) ->- (e -> m ()) ->+ [e -> m ()] ->+ App e m -> a -> m b-httpPubApp api httpCallback =+httpPubApp [] app = runApp app+httpPubApp callbacks app = mapAPI $ runStreamHTTP ScopeHTTP {httpCallback}- . api+ . streamApp app . Request+ where+ httpCallback e = traverse_ (e &) callbacks -- | Wai WebSocket Server App for GraphQL subscriptions-subscriptionApp ::+webSocketsApp :: ( MonadUnliftIO m, Eq channel ) =>- ( Store (Event channel a) m ->- (Scope WS (Event channel a) m -> m ()) ->- m app- ) ->- (Input WS -> Stream WS (Event channel a) m) ->- m (app, Event channel a -> m ())-subscriptionApp appWrapper api =+ App (Event channel cont) m ->+ m (ServerApp, Event channel cont -> m ())+webSocketsApp app = do store <- initDefaultStore- app <- appWrapper store (connectionThread api)+ wsApp <- webSocketsWrapper store (connectionThread app) pure- ( app,+ ( wsApp, publishEventWith store ) @@ -128,13 +131,3 @@ pingThread conn $ runIO (handler (defaultWSScope store conn))---- | Wai WebSocket Server App for GraphQL subscriptions-webSocketsApp ::- ( MonadIO m,- MonadUnliftIO m,- Eq channel- ) =>- (Input WS -> Stream WS (Event channel a) m) ->- m (ServerApp, Event channel a -> m ())-webSocketsApp = subscriptionApp webSocketsWrapper
+ src/Data/Morpheus/Server/Deriving/App.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.App+ ( RootResolverConstraint,+ deriveSchema,+ deriveApp,+ )+where++-- MORPHEUS++import Control.Monad (Monad)+import Data.Functor.Identity (Identity (..))+import Data.Morpheus.Core+ ( App (..),+ mkApp,+ )+import Data.Morpheus.Server.Deriving.Encode+ ( EncodeConstraints,+ deriveModel,+ )+import Data.Morpheus.Server.Deriving.Schema+ ( SchemaConstraints,+ deriveSchema,+ )+import Data.Morpheus.Types+ ( RootResolver (..),+ )+import Data.Morpheus.Types.Internal.Resolving+ ( resultOr,+ )++type RootResolverConstraint m e query mutation subscription =+ ( EncodeConstraints e m query mutation subscription,+ SchemaConstraints e m query mutation subscription,+ Monad m+ )++deriveApp ::+ RootResolverConstraint m event query mut sub =>+ RootResolver m event query mut sub ->+ App event m+deriveApp root =+ resultOr+ FailApp+ (`mkApp` deriveModel root)+ (deriveSchema (Identity root))
src/Data/Morpheus/Server/Deriving/Channels.hs view
@@ -1,37 +1,43 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Deriving.Channels ( getChannels,- ChannelCon,- GetChannel (..),- ExploreChannels (..),+ ChannelsConstraint, ) where --- MORPHEUS+import Control.Applicative (pure)+import Control.Monad ((>>=))+import Data.Functor.Identity (Identity (..))+import Data.Maybe (Maybe (..)) import Data.Morpheus.Internal.Utils ( Failure (..), elems, ) import Data.Morpheus.Server.Deriving.Decode- ( DecodeType,+ ( DecodeConstraint, decodeArguments, )-import Data.Morpheus.Server.Types.GQLType (GQLType (..))+import Data.Morpheus.Server.Deriving.Utils+ ( ConsRep (..),+ DataType (..),+ FieldRep (..),+ TypeConstraint (..),+ TypeRep (..),+ toValue,+ )+import Data.Morpheus.Server.Types.GQLType (GQLType) import Data.Morpheus.Types.Internal.AST- ( FALSE,- FieldName (..),+ ( FieldName (..), InternalError, SUBSCRIPTION, Selection (..),@@ -44,30 +50,23 @@ ResolverState, SubscriptionField (..), )-import Data.Proxy (Proxy (..))-import Data.Semigroup ((<>))-import Data.Text- ( pack,- ) import GHC.Generics--data CustomProxy (c :: Bool) e = CustomProxy+import Prelude+ ( (.),+ const,+ lookup,+ map,+ ) -type ChannelCon e m a =- ExploreChannels- (CUSTOM (a (Resolver SUBSCRIPTION e m)))- (a (Resolver SUBSCRIPTION e m))- e+type ChannelsConstraint e m (subs :: (* -> *) -> *) =+ ExploreConstraint e (subs (Resolver SUBSCRIPTION e m)) getChannels ::- forall e m subs.- ChannelCon e m subs =>+ ChannelsConstraint e m subs => subs (Resolver SUBSCRIPTION e m) -> Selection VALID -> ResolverState (Channel e)-getChannels value sel =- selectBy sel $- exploreChannels (CustomProxy :: CustomProxy (CUSTOM (subs (Resolver SUBSCRIPTION e m))) e) value+getChannels value sel = selectBy sel (exploreChannels value) selectBy :: Failure InternalError m =>@@ -92,43 +91,31 @@ getChannel SubscriptionField {channel} = const (pure channel) instance- (Generic arg, DecodeType arg) =>+ DecodeConstraint arg => GetChannel e (arg -> SubscriptionField (Resolver SUBSCRIPTION e m a)) where getChannel f sel@Selection {selectionArguments} = decodeArguments selectionArguments >>= (`getChannel` sel) . f -------------------------------------------------------class ExploreChannels (custom :: Bool) a e where- exploreChannels :: CustomProxy custom e -> a -> [(FieldName, Selection VALID -> ResolverState (Channel e))] -instance- ( TypeRep e (Rep (subs (Resolver SUBSCRIPTION e m))),- Generic (subs (Resolver SUBSCRIPTION e m))- ) =>- ExploreChannels FALSE (subs (Resolver SUBSCRIPTION e m)) e- where- exploreChannels _ = typeRep (Proxy @e) . from---------------------------------------------------------class TypeRep e f where- typeRep :: Proxy e -> f a -> [(FieldName, Selection VALID -> ResolverState (Channel e))]--instance TypeRep e f => TypeRep e (M1 D d f) where- typeRep c (M1 src) = typeRep c src--instance FieldRep e f => TypeRep e (M1 C c f) where- typeRep c (M1 src) = fieldRep c src----- FIELDS-class FieldRep e f where- fieldRep :: Proxy e -> f a -> [(FieldName, Selection VALID -> ResolverState (Channel e))]+type ChannelRes e = Selection VALID -> ResolverState (Channel e) -instance (FieldRep e f, FieldRep e g) => FieldRep e (f :*: g) where- fieldRep e (a :*: b) = fieldRep e a <> fieldRep e b+type ExploreConstraint e a =+ ( GQLType a,+ Generic a,+ TypeRep (GetChannel e) (Selection VALID -> ResolverState (Channel e)) (Rep a)+ ) -instance (Selector s, GetChannel e a) => FieldRep e (M1 S s (K1 s2 a)) where- fieldRep _ m@(M1 (K1 src)) = [(FieldName $ pack (selName m), getChannel src)]+exploreChannels :: forall e a. ExploreConstraint e a => a -> [(FieldName, ChannelRes e)]+exploreChannels =+ convertNode+ . toValue+ ( TypeConstraint (getChannel . runIdentity) ::+ TypeConstraint (GetChannel e) (Selection VALID -> ResolverState (Channel e)) Identity+ ) -instance FieldRep e U1 where- fieldRep _ _ = []+convertNode :: DataType (ChannelRes e) -> [(FieldName, ChannelRes e)]+convertNode DataType {tyCons = ConsRep {consFields}} = map toChannels consFields+ where+ toChannels FieldRep {fieldSelector, fieldValue} = (fieldSelector, fieldValue)
src/Data/Morpheus/Server/Deriving/Decode.hs view
@@ -12,15 +12,20 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Deriving.Decode ( decodeArguments, Decode (..),- DecodeType (..),+ DecodeConstraint, ) where --- MORPHEUS+import Control.Applicative ((<*>), pure)+import Control.Monad ((>>=))+import Data.Functor ((<$>), Functor (..))+import Data.List (elem)+import Data.Maybe (Maybe (..)) import Data.Morpheus.Internal.Utils ( elems, )@@ -44,7 +49,15 @@ withMaybe, withScalar, )-import Data.Morpheus.Server.Types.GQLType (GQLType (KIND, __typeName))+import Data.Morpheus.Server.Types.GQLType+ ( GQLType+ ( KIND,+ __type,+ typeOptions+ ),+ GQLTypeOptions (..),+ TypeData (..),+ ) import Data.Morpheus.Types.GQLScalar ( GQLScalar (..), )@@ -67,9 +80,22 @@ import Data.Proxy (Proxy (..)) import Data.Semigroup (Semigroup (..)) import GHC.Generics+import Prelude+ ( ($),+ (.),+ Eq (..),+ Ord,+ otherwise,+ ) +type DecodeConstraint a =+ ( Generic a,+ GQLType a,+ DecodeRep (Rep a)+ )+ -- GENERIC-decodeArguments :: DecodeType a => Arguments VALID -> ResolverState a+decodeArguments :: DecodeConstraint a => Arguments VALID -> ResolverState a decodeArguments = decodeType . Object . fmap toEntry where toEntry Argument {..} = ObjectEntry argumentName argumentValue@@ -93,27 +119,24 @@ -- SCALAR instance (GQLScalar a, GQLType a) => DecodeKind SCALAR a where- decodeKind _ = withScalar (__typeName (Proxy @a)) parseValue+ decodeKind _ = withScalar (gqlTypeName $ __type (Proxy @a)) parseValue -- ENUM-instance DecodeType a => DecodeKind ENUM a where+instance DecodeConstraint a => DecodeKind ENUM a where decodeKind _ = decodeType -- TODO: remove-instance DecodeType a => DecodeKind OUTPUT a where+instance DecodeConstraint a => DecodeKind OUTPUT a where decodeKind _ = decodeType -- INPUT_OBJECT and INPUT_UNION-instance DecodeType a => DecodeKind INPUT a where+instance DecodeConstraint a => DecodeKind INPUT a where decodeKind _ = decodeType -class DecodeType a where- decodeType :: ValidValue -> ResolverState a--instance {-# OVERLAPPABLE #-} (Generic a, DecodeRep (Rep a)) => DecodeType a where- decodeType = fmap to . decodeRep . (,Cont D_CONS "")+decodeType :: forall a. DecodeConstraint a => ValidValue -> ResolverState a+decodeType = fmap to . decodeRep . (typeOptions (Proxy @a),,Cont D_CONS "") --- data Inpuz =+-- data Input = -- InputHuman Human -- direct link: { __typename: Human, Human: {field: ""} } -- | InputRecord { name :: Text, age :: Int } -- { __typename: InputRecord, InputRecord: {field: ""} } -- | IndexedType Int Text -- { __typename: InputRecord, _0:2 , _1:"" }@@ -158,15 +181,15 @@ -- GENERICS -- class DecodeRep f where- tags :: Proxy f -> TypeName -> Info- decodeRep :: (ValidValue, Cont) -> ResolverState (f a)+ tags :: Proxy f -> (GQLTypeOptions, TypeName) -> Info+ decodeRep :: (GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a) instance (Datatype d, DecodeRep f) => DecodeRep (M1 D d f) where tags _ = tags (Proxy @f)- decodeRep (x, y) =+ decodeRep (ns, x, y) = M1 <$> decodeRep- (x, y {typeName = datatypeNameProxy (Proxy @d)})+ (ns, x, y {typeName = datatypeNameProxy (Proxy @d)}) getEnumTag :: ValidObject -> ResolverState TypeName getEnumTag x = case elems x of@@ -177,59 +200,59 @@ tags _ = tags (Proxy @a) <> tags (Proxy @b) decodeRep = __decode where- __decode (Object obj, cont) = withInputUnion handleUnion obj+ __decode (opt, Object obj, cont) = withInputUnion handleUnion obj where handleUnion name unions object | name == typeName cont <> "EnumObject" =- getEnumTag object >>= __decode . (,ctx) . Enum+ getEnumTag object >>= __decode . (opt,,ctx) . Enum | [name] == l1 =- L1 <$> decodeRep (Object object, ctx)+ L1 <$> decodeRep (opt, Object object, ctx) | [name] == r1 =- R1 <$> decodeRep (Object object, ctx)+ R1 <$> decodeRep (opt, Object object, ctx) | otherwise =- decideUnion (l1, decodeRep) (r1, decodeRep) name (Object unions, ctx)+ decideUnion (l1, decodeRep) (r1, decodeRep) name (opt, Object unions, ctx) l1 = tagName l1t r1 = tagName r1t- l1t = tags (Proxy @a) (typeName cont)- r1t = tags (Proxy @b) (typeName cont)+ l1t = tags (Proxy @a) (opt, typeName cont)+ r1t = tags (Proxy @b) (opt, typeName cont) ctx = cont {contKind = kind (l1t <> r1t)}- __decode (Enum name, cxt) =+ __decode (opt, Enum name, cxt) = decideUnion- (tagName $ tags (Proxy @a) (typeName cxt), decodeRep)- (tagName $ tags (Proxy @b) (typeName cxt), decodeRep)+ (tagName $ tags (Proxy @a) (opt, typeName cxt), decodeRep)+ (tagName $ tags (Proxy @b) (opt, typeName cxt), decodeRep) name- (Enum name, cxt)+ (opt, Enum name, cxt) __decode _ = failure ("lists and scalars are not allowed in Union" :: InternalError) instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where decodeRep = fmap M1 . decodeFields- tags _ baseName = getTag (refType (Proxy @a))+ tags _ (opt, baseName) = getTag (refType (Proxy @a)) where getTag (Just memberRef) | isUnionRef memberRef = Info {kind = D_UNION, tagName = [memberRef]} | otherwise = Info {kind = D_CONS, tagName = [consName]} getTag Nothing = Info {kind = D_CONS, tagName = [consName]} --------- consName = conNameProxy (Proxy @c)+ consName = conNameProxy opt (Proxy @c) ---------- isUnionRef x = baseName <> x == consName class DecodeFields f where refType :: Proxy f -> Maybe TypeName- decodeFields :: (ValidValue, Cont) -> ResolverState (f a)+ decodeFields :: (GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a) instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where refType _ = Nothing decodeFields gql = (:*:) <$> decodeFields gql <*> decodeFields gql instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where- refType _ = Just $ __typeName (Proxy @a)- decodeFields (value, Cont {contKind})+ refType _ = Just $ gqlTypeName $ __type (Proxy @a)+ decodeFields (opt, value, Cont {contKind}) | contKind == D_UNION = M1 . K1 <$> decode value | otherwise = __decode value where __decode = fmap (M1 . K1) . decodeRec- fieldName = selNameProxy (Proxy @s)+ fieldName = selNameProxy opt (Proxy @s) decodeRec = withInputObject (decodeFieldWith decode fieldName) instance DecodeFields U1 where
src/Data/Morpheus/Server/Deriving/Encode.hs view
@@ -6,44 +6,54 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Deriving.Encode- ( EncodeCon,- Encode (..),- ExploreResolvers (..),- deriveModel,+ ( deriveModel,+ EncodeConstraints, ) where +-- MORPHEUS++import Control.Applicative (Applicative (..))+import Control.Monad (Monad ((>>=)))+import Data.Functor (fmap)+import Data.Functor.Identity (Identity (..)) import Data.Map (Map) import qualified Data.Map as M ( toList, )--- MORPHEUS-+import Data.Maybe+ ( Maybe (..),+ maybe,+ ) import Data.Morpheus.Kind ( ENUM, GQL_KIND, INTERFACE, OUTPUT,- ResContext (..), SCALAR,- VContext (..), )-import Data.Morpheus.Server.Deriving.Channels (ChannelCon, getChannels)+import Data.Morpheus.Server.Deriving.Channels+ ( ChannelsConstraint,+ getChannels,+ ) import Data.Morpheus.Server.Deriving.Decode- ( DecodeType,+ ( DecodeConstraint, decodeArguments, ) import Data.Morpheus.Server.Deriving.Utils- ( conNameProxy,- datatypeNameProxy,- isRecordProxy,+ ( ConsRep (..),+ DataType (..),+ FieldRep (..),+ TypeConstraint (..),+ TypeRep (..),+ isUnionRef,+ toValue, ) import Data.Morpheus.Server.Types.GQLType (GQLType (..)) import Data.Morpheus.Server.Types.Types@@ -56,19 +66,16 @@ ) import Data.Morpheus.Types.GQLScalar (GQLScalar (..)) import Data.Morpheus.Types.Internal.AST- ( FieldName,- FieldName (..),- InternalError,+ ( InternalError, MUTATION,- OperationType (..),+ OperationType, QUERY, SUBSCRIPTION,- TypeName,+ TypeRef (..), ) import Data.Morpheus.Types.Internal.Resolving ( FieldResModel, LiftOperation,- ObjectResModel (..), ResModel (..), Resolver, ResolverState,@@ -77,56 +84,67 @@ failure, getArguments, liftResolverState,+ mkObject, ) import Data.Proxy (Proxy (..))-import Data.Semigroup ((<>)) import Data.Set (Set) import qualified Data.Set as S ( toList, )-import Data.Text (pack)+import Data.Traversable (traverse) import GHC.Generics+ ( Generic (..),+ )+import Prelude+ ( ($),+ (.),+ otherwise,+ ) -class Encode resolver o e (m :: * -> *) where+newtype ContextValue (kind :: GQL_KIND) a = ContextValue+ { unContextValue :: a+ }++class Encode o e (m :: * -> *) resolver where encode :: resolver -> Resolver o e m (ResModel o e m) -instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m, LiftOperation o) => Encode a o e m where- encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a)+instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m, LiftOperation o) => Encode o e m a where+ encode resolver = encodeKind (ContextValue resolver :: ContextValue (KIND a) a) -- MAYBE-instance (Monad m, LiftOperation o, Encode a o e m) => Encode (Maybe a) o e m where+instance (Monad m, LiftOperation o, Encode o e m a) => Encode o e m (Maybe a) where encode = maybe (pure ResNull) encode -- LIST []-instance (Monad m, Encode a o e m, LiftOperation o) => Encode [a] o e m where+instance (Monad m, Encode o e m a, LiftOperation o) => Encode o e m [a] where encode = fmap ResList . traverse encode -- Tuple (a,b)-instance Encode (Pair k v) o e m => Encode (k, v) o e m where+instance Encode o e m (Pair k v) => Encode o e m (k, v) where encode (key, value) = encode (Pair key value) -- Set-instance Encode [a] o e m => Encode (Set a) o e m where+instance Encode o e m [a] => Encode o e m (Set a) where encode = encode . S.toList -- Map-instance (Eq k, Monad m, LiftOperation o, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v) o e m where+instance (Monad m, LiftOperation o, Encode o e m (MapKind k v (Resolver o e m))) => Encode o e m (Map k v) where encode value = encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver o e m)) -- SUBSCRIPTION-instance (Monad m, LiftOperation o, Encode a o e m) => Encode (SubscriptionField a) o e m where+instance (Monad m, LiftOperation o, Encode o e m a) => Encode o e m (SubscriptionField a) where encode (SubscriptionField _ res) = encode res -- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY instance- ( DecodeType a,+ ( DecodeConstraint a, Generic a, Monad m, LiftOperation o,- Encode b o e m+ Encode o e m b ) =>- Encode (a -> b) o e m+ Encode o e m (a -> b) where encode f = getArguments@@ -134,114 +152,106 @@ >>= encode . f -- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance- ( Monad m,- Encode b o e m,- LiftOperation o- ) =>- Encode (Resolver o e m b) o e m- where+instance (Monad m, Encode o e m b, LiftOperation o) => Encode o e m (Resolver o e m b) where encode x = x >>= encode -- ENCODE GQL KIND class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where- encodeKind :: LiftOperation o => VContext kind a -> Resolver o e m (ResModel o e m)+ encodeKind :: LiftOperation o => ContextValue kind a -> Resolver o e m (ResModel o e m) -- SCALAR instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where- encodeKind = pure . ResScalar . serialize . unVContext+ encodeKind = pure . ResScalar . serialize . unContextValue -- ENUM-instance (Generic a, ExploreResolvers (CUSTOM a) a o e m, Monad m) => EncodeKind ENUM a o e m where- encodeKind (VContext value) = liftResolverState $ exploreResolvers (Proxy @(CUSTOM a)) value+instance EncodeConstraint o e m a => EncodeKind ENUM a o e m where+ encodeKind = pure . exploreResolvers . unContextValue -instance (Monad m, Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where- encodeKind (VContext value) = liftResolverState $ exploreResolvers (Proxy @(CUSTOM a)) value+instance EncodeConstraint o e m a => EncodeKind OUTPUT a o e m where+ encodeKind = pure . exploreResolvers . unContextValue -instance (Monad m, Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind INTERFACE a o e m where- encodeKind (VContext value) = liftResolverState $ exploreResolvers (Proxy @(CUSTOM a)) value+instance EncodeConstraint o e m a => EncodeKind INTERFACE a o e m where+ encodeKind = pure . exploreResolvers . unContextValue convertNode :: (Monad m, LiftOperation o) =>- ResNode o e m ->+ DataType (Resolver o e m (ResModel o e m)) -> ResModel o e m-convertNode ResNode {resDatatypeName, resKind = REP_OBJECT, resFields} =- ResObject (ObjectResModel resDatatypeName $ map toFieldRes resFields)-convertNode ResNode {resDatatypeName, resKind = REP_UNION, resFields, resTypeName, isResRecord} =- encodeUnion resFields- where- -- ENUM- encodeUnion [] = ResEnum resDatatypeName resTypeName- -- Type References --------------------------------------------------------------- encodeUnion [FieldNode {fieldTypeName, fieldResolver, isFieldObject}]- | isFieldObject && resTypeName == resDatatypeName <> fieldTypeName =- ResUnion fieldTypeName fieldResolver- -- Inline Union Types ----------------------------------------------------------------------------- encodeUnion fields =- ResUnion- resTypeName- $ pure- $ ResObject- $ ObjectResModel- resTypeName- (map toFieldRes resolvers)- where- resolvers- | isResRecord = fields- | otherwise = setFieldNames fields+convertNode+ DataType+ { tyName,+ tyIsUnion,+ tyCons = cons@ConsRep {consFields, consName}+ }+ | tyIsUnion = encodeUnion consFields+ | otherwise = mkObject tyName (fmap toFieldRes consFields)+ where+ -- ENUM+ encodeUnion [] = ResEnum tyName consName+ -- Type References --------------------------------------------------------------+ encodeUnion [FieldRep {fieldTypeRef = TypeRef {typeConName}, fieldValue}]+ | isUnionRef tyName cons = ResUnion typeConName fieldValue+ -- Inline Union Types ----------------------------------------------------------------------------+ encodeUnion fields =+ ResUnion+ consName+ $ pure+ $ mkObject+ consName+ (fmap toFieldRes fields) -- Types & Constrains --------------------------------------------------------type GQL_RES a = (Generic a, GQLType a)--type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m)----- GENERICS -------------------------------------------------class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where- exploreResolvers :: Proxy custom -> a -> ResolverState (ResModel o e m)--instance (Generic a, Monad m, LiftOperation o, TypeRep (Rep a) o e m) => ExploreResolvers 'False a o e m where- exploreResolvers _ value =- pure- $ convertNode- $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value)+exploreResolvers ::+ forall o e m a.+ ( EncodeConstraint o e m a,+ LiftOperation o+ ) =>+ a ->+ ResModel o e m+exploreResolvers =+ convertNode+ . toValue+ ( TypeConstraint (encode . runIdentity) ::+ TypeConstraint (Encode o e m) (Resolver o e m (ResModel o e m)) Identity+ ) ----- HELPERS ---------------------------- objectResolvers ::- forall a o e m.- ( ExploreResolvers (CUSTOM a) a o e m,- Monad m,+ ( EncodeConstraint o e m a, LiftOperation o ) => a -> ResolverState (ResModel o e m)-objectResolvers value =- exploreResolvers (Proxy @(CUSTOM a)) value- >>= constraintOnject+objectResolvers value = constraintObject (exploreResolvers value) where- constraintOnject obj@ResObject {} =+ constraintObject obj@ResObject {} = pure obj- constraintOnject _ =+ constraintObject _ = failure ("resolver must be an object" :: InternalError) -type Con o e m a =- ExploreResolvers- ( CUSTOM- (a (Resolver o e m))- )- (a (Resolver o e m))- o- e- m+type EncodeObjectConstraint (o :: OperationType) e (m :: * -> *) a =+ EncodeConstraint o e m (a (Resolver o e m)) +type EncodeConstraint (o :: OperationType) e (m :: * -> *) a =+ ( Monad m,+ GQLType a,+ Generic a,+ TypeRep (Encode o e m) (Resolver o e m (ResModel o e m)) (Rep a)+ )++type EncodeConstraints e m query mut sub =+ ( ChannelsConstraint e m sub,+ EncodeObjectConstraint QUERY e m query,+ EncodeObjectConstraint MUTATION e m mut,+ EncodeObjectConstraint SUBSCRIPTION e m sub+ )++toFieldRes :: FieldRep (Resolver o e m (ResModel o e m)) -> FieldResModel o e m+toFieldRes FieldRep {fieldSelector, fieldValue} = (fieldSelector, fieldValue)+ deriveModel :: forall e m query mut sub.- ( Con QUERY e m query,- Con MUTATION e m mut,- Con SUBSCRIPTION e m sub,- ChannelCon e m sub,- Applicative m,- Monad m- ) =>+ (Monad m, EncodeConstraints e m query mut sub) => RootResolver m e query mut sub -> RootResModel e m deriveModel@@ -254,79 +264,9 @@ { query = objectResolvers queryResolver, mutation = objectResolvers mutationResolver, subscription = objectResolvers subscriptionResolver,- channelMap = Just (getChannels subscriptionResolver)- }--toFieldRes :: FieldNode o e m -> FieldResModel o e m-toFieldRes FieldNode {fieldSelName, fieldResolver} =- (fieldSelName, fieldResolver)---- NEW AUTOMATIC DERIVATION SYSTEM-data REP_KIND = REP_UNION | REP_OBJECT--data ResNode o e m = ResNode- { resDatatypeName :: TypeName,- resTypeName :: TypeName,- resKind :: REP_KIND,- resFields :: [FieldNode o e m],- isResRecord :: Bool- }--data FieldNode o e m = FieldNode- { fieldTypeName :: TypeName,- fieldSelName :: FieldName,- fieldResolver :: Resolver o e m (ResModel o e m),- isFieldObject :: Bool- }---- setFieldNames :: Power Int Text -> Power { _1 :: Int, _2 :: Text }-setFieldNames :: [FieldNode o e m] -> [FieldNode o e m]-setFieldNames = zipWith setFieldName ([0 ..] :: [Int])- where- setFieldName i field = field {fieldSelName = FieldName $ "_" <> pack (show i)}--class TypeRep f o e (m :: * -> *) where- typeResolvers :: ResContext OUTPUT o e m value -> f a -> ResNode o e m--instance (Datatype d, TypeRep f o e m) => TypeRep (M1 D d f) o e m where- typeResolvers context (M1 src) =- (typeResolvers context src)- { resDatatypeName = datatypeNameProxy (Proxy @d)- }----- UNION OR OBJECT-instance (TypeRep a o e m, TypeRep b o e m) => TypeRep (a :+: b) o e m where- typeResolvers context (L1 x) =- (typeResolvers context x) {resKind = REP_UNION}- typeResolvers context (R1 x) =- (typeResolvers context x) {resKind = REP_UNION}--instance (FieldRep f o e m, Constructor c) => TypeRep (M1 C c f) o e m where- typeResolvers context (M1 src) =- ResNode- { resDatatypeName = "",- resTypeName = conNameProxy (Proxy @c),- resKind = REP_OBJECT,- resFields = fieldRep context src,- isResRecord = isRecordProxy (Proxy @c)+ channelMap }----- FIELDS-class FieldRep f o e (m :: * -> *) where- fieldRep :: ResContext OUTPUT o e m value -> f a -> [FieldNode o e m]--instance (FieldRep f o e m, FieldRep g o e m) => FieldRep (f :*: g) o e m where- fieldRep context (a :*: b) = fieldRep context a <> fieldRep context b--instance (Selector s, GQLType a, Encode a o e m) => FieldRep (M1 S s (K1 s2 a)) o e m where- fieldRep _ m@(M1 (K1 src)) =- [ FieldNode- { fieldSelName = FieldName $ pack (selName m),- fieldTypeName = __typeName (Proxy @a),- fieldResolver = encode src,- isFieldObject = isObjectKind (Proxy @a)- }- ]--instance FieldRep U1 o e m where- fieldRep _ _ = []+ where+ channelMap+ | isEmptyType (Proxy :: Proxy (sub (Resolver SUBSCRIPTION e m))) = Nothing+ | otherwise = Just (getChannels subscriptionResolver)
− src/Data/Morpheus/Server/Deriving/Interpreter.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}--module Data.Morpheus.Server.Deriving.Interpreter- ( Interpreter (..),- )-where---- MORPHEUS-import Data.Morpheus.Core (debugConfig, defaultConfig)-import Data.Morpheus.Server.Deriving.Resolve- ( RootResolverConstraint,- coreResolver,- statelessResolver,- )-import Data.Morpheus.Types- ( Event,- RootResolver (..),- )-import Data.Morpheus.Types.IO- ( GQLRequest,- GQLResponse,- MapAPI (..),- )-import Data.Morpheus.Types.Internal.Subscription- ( Input,- Stream,- toOutStream,- )---- | main query processor and resolver--- possible versions of interpreter------ 1. with effect and state: where 'GQLState' is State Monad of subscriptions------ @--- k :: GQLState -> a -> IO a--- @------ 2. without effect and state: stateless query processor without any effect,--- if you don't need any subscription use this one , is simple and fast------ @--- k :: a -> IO a--- -- or--- k :: GQLRequest -> IO GQLResponse--- @-class Interpreter e m a b where- interpreter ::- Monad m =>- (RootResolverConstraint m e query mut sub) =>- RootResolver m e query mut sub ->- a ->- b- debugInterpreter ::- Monad m =>- (RootResolverConstraint m e query mut sub) =>- RootResolver m e query mut sub ->- a ->- b--instance Interpreter e m GQLRequest (m GQLResponse) where- interpreter root = statelessResolver root defaultConfig- debugInterpreter root = statelessResolver root debugConfig--instance Interpreter (Event ch cont) m (Input api) (Stream api (Event ch cont) m) where- interpreter root = toOutStream (coreResolver root defaultConfig)- debugInterpreter root = toOutStream (coreResolver root debugConfig)--instance (MapAPI a a) => Interpreter e m a (m a) where- interpreter root = mapAPI (interpreter root)- debugInterpreter root = mapAPI (debugInterpreter root)
− src/Data/Morpheus/Server/Deriving/Introspect.hs
@@ -1,684 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Data.Morpheus.Server.Deriving.Introspect- ( Introspect (..),- DeriveTypeContent (..),- introspectOUT,- IntroCon,- deriveCustomInputObjectType,- ProxyRep (..),- TypeUpdater,- deriveSchema,- compileTimeSchemaValidation,- )-where---- MORPHEUS--import Control.Monad ((>=>))-import Data.List (partition)-import Data.Map (Map)-import Data.Morpheus.Core (defaultConfig, validateSchema)-import Data.Morpheus.Error (globalErrorMessage)-import Data.Morpheus.Internal.Utils- ( Failure (..),- concatUpdates,- empty,- failUpdates,- resolveUpdates,- singleton,- )-import Data.Morpheus.Kind- ( Context (..),- ENUM,- GQL_KIND,- INPUT,- INTERFACE,- OUTPUT,- SCALAR,- )-import Data.Morpheus.Server.Deriving.Utils- ( EnumRep (..),- conNameProxy,- isRecordProxy,- selNameProxy,- )-import Data.Morpheus.Server.Types.GQLType- ( GQLType (..),- GQLType (CUSTOM),- TypeUpdater,- )-import Data.Morpheus.Server.Types.Types- ( MapKind,- Pair,- )-import Data.Morpheus.Types.GQLScalar (GQLScalar (..))-import Data.Morpheus.Types.Internal.AST- ( ArgumentsDefinition (..),- CONST,- DataFingerprint (..),- DataUnion,- ELEM,- FALSE,- FieldContent (..),- FieldDefinition (..),- FieldName,- FieldName (..),- FieldsDefinition,- GQLErrors,- IN,- LEAF,- MUTATION,- Message,- OBJECT,- OUT,- QUERY,- SUBSCRIPTION,- Schema (..),- TRUE,- TypeCategory,- TypeContent (..),- TypeDefinition (..),- TypeName (..),- TypeRef (..),- UnionMember (..),- VALID,- fieldsToArguments,- initTypeLib,- insertType,- mkEnumContent,- mkInputValue,- mkType,- mkTypeRef,- mkUnionMember,- msg,- toListField,- toNullable,- unsafeFromFields,- updateSchema,- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless,- Resolver,- Result (..),- SubscriptionField (..),- )-import Data.Proxy (Proxy (..))-import Data.Semigroup ((<>))-import Data.Set (Set)-import Data.Text- ( pack,- )-import GHC.Generics-import Language.Haskell.TH (Exp, Q)--type IntroCon a = (GQLType a, DeriveTypeContent OUT (CUSTOM a) a)--type IntrospectConstraint m event query mutation subscription =- ( IntroCon (query (Resolver QUERY event m)),- IntroCon (mutation (Resolver MUTATION event m)),- IntroCon (subscription (Resolver SUBSCRIPTION event m))- )--data ProxyRep (cat :: TypeCategory) a- = ProxyRep---- | normaly morpheus server validates schema at runtime (after the schema derivation).--- this method allows you to validate it at compile time.-compileTimeSchemaValidation ::- (IntrospectConstraint m event qu mu su) =>- proxy (root m event qu mu su) ->- Q Exp-compileTimeSchemaValidation =- fromSchema- . (deriveSchema >=> validateSchema True defaultConfig)--fromSchema :: Eventless (Schema VALID) -> Q Exp-fromSchema Success {} = [|()|]-fromSchema Failure {errors} = fail (show errors)--deriveSchema ::- forall- rootResolver- proxy- m- event- query- mutation- subscription- f.- ( IntrospectConstraint m event query mutation subscription,- Applicative f,- Failure GQLErrors f- ) =>- proxy (rootResolver m event query mutation subscription) ->- f (Schema CONST)-deriveSchema _ = case querySchema >>= mutationSchema >>= subscriptionSchema of- Success {result} -> pure result- Failure {errors} -> failure errors- where- querySchema =- resolveUpdates (initTypeLib (operatorType fields "Query")) types- where- (fields, types) =- introspectObjectFields- (Proxy @(CUSTOM (query (Resolver QUERY event m))))- ("type for query", Proxy @(query (Resolver QUERY event m)))- ------------------------------- mutationSchema lib =- resolveUpdates- (lib {mutation = maybeOperator fields "Mutation"})- types- where- (fields, types) =- introspectObjectFields- (Proxy @(CUSTOM (mutation (Resolver MUTATION event m))))- ( "type for mutation",- Proxy @(mutation (Resolver MUTATION event m))- )- ------------------------------- subscriptionSchema lib =- resolveUpdates- (lib {subscription = maybeOperator fields "Subscription"})- types- where- (fields, types) =- introspectObjectFields- (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION event m))))- ( "type for subscription",- Proxy @(subscription (Resolver SUBSCRIPTION event m))- )- maybeOperator :: FieldsDefinition OUT CONST -> TypeName -> Maybe (TypeDefinition OBJECT CONST)- maybeOperator fields- | null fields = const Nothing- | otherwise = Just . operatorType fields- -------------------------------------------------- operatorType :: FieldsDefinition OUT CONST -> TypeName -> TypeDefinition OBJECT CONST- operatorType fields typeName = mkType typeName (DataObject [] fields)--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 (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 cat a -> FieldName -> FieldDefinition cat CONST- ------------------------------------------------ default field ::- GQLType a =>- proxy cat a ->- FieldName ->- FieldDefinition cat CONST- field _ = buildField (Proxy @a) Nothing---- Maybe-instance Introspect cat a => Introspect cat (Maybe a) where- isObject _ = False- field _ = toNullable . field (ProxyRep :: ProxyRep cat a)- introspect _ = introspect (ProxyRep :: ProxyRep cat a)---- List-instance Introspect cat a => Introspect cat [a] where- isObject _ = False- field _ = toListField . field (ProxyRep :: ProxyRep cat a)- introspect _ = introspect (ProxyRep :: ProxyRep cat a)---- Tuple-instance Introspect cat (Pair k v) => Introspect cat (k, v) where- isObject _ = True- field _ = field (ProxyRep :: ProxyRep cat (Pair k v))- introspect _ = introspect (ProxyRep :: ProxyRep cat (Pair k v))---- Set-instance Introspect cat [a] => Introspect cat (Set a) where- isObject _ = False- field _ = field (ProxyRep :: ProxyRep cat [a])- introspect _ = introspect (ProxyRep :: ProxyRep cat [a])---- Map-instance Introspect cat (MapKind k v Maybe) => Introspect cat (Map k v) where- isObject _ = True- 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 IN 'False a, Introspect OUT b) => Introspect OUT (a -> m b) where- isObject _ = False- field _ name = fieldObj {fieldContent = Just (FieldArgs fieldArgs)}- where- fieldObj = field (ProxyRep :: ProxyRep OUT b) name- fieldArgs :: ArgumentsDefinition CONST- fieldArgs =- fieldsToArguments- $ fst- $ introspectInputObjectFields- (Proxy :: Proxy 'False)- (__typeName (Proxy @b), Proxy @a)- introspect _ = concatUpdates (introspect (ProxyRep :: ProxyRep OUT b) : inputs)- where- name = "Arguments for " <> __typeName (Proxy @b)- inputs :: [TypeUpdater]- inputs =- snd $ introspectInputObjectFields (Proxy :: Proxy 'False) (name, Proxy @a)--instance (Introspect OUT a) => Introspect OUT (SubscriptionField a) where- isObject _ = isObject (ProxyRep :: ProxyRep OUT a)- field _ = field (ProxyRep :: ProxyRep OUT a)- introspect _ = introspect (ProxyRep :: ProxyRep OUT a)---- GQL Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance (GQLType b, Introspect cat b) => Introspect cat (Resolver fo e m b) where- isObject _ = False- 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- introspectKind :: Context kind a -> TypeUpdater -- Generates internal GraphQL Schema---- SCALAR-instance (GQLType a, GQLScalar a) => IntrospectKind SCALAR a where- introspectKind _ = updateLib scalarType [] (Proxy @a)- where- scalarType :: Proxy a -> TypeDefinition LEAF CONST- scalarType = buildType $ DataScalar $ scalarValidator (Proxy @a)---- ENUM-instance (GQL_TYPE a, EnumRep (Rep a)) => IntrospectKind ENUM a where- introspectKind _ = updateLib enumType [] (Proxy @a)- where- enumType :: Proxy a -> TypeDefinition LEAF CONST- enumType = buildType $ mkEnumContent $ enumTags (Proxy @(Rep a))--instance (GQL_TYPE a, DeriveTypeContent IN (CUSTOM a) a) => IntrospectKind INPUT a where- introspectKind _ = derivingData (Proxy @a) InputType--instance (GQL_TYPE a, DeriveTypeContent OUT (CUSTOM a) a) => IntrospectKind OUTPUT a where- introspectKind _ = derivingData (Proxy @a) OutputType--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, Proxy @a)- baseName = __typeName (Proxy @a)--derivingData ::- forall a cat.- (GQLType a, DeriveTypeContent cat (CUSTOM a) a) =>- Proxy a ->- TypeScope cat ->- TypeUpdater-derivingData _ scope = updateLib (buildType datatypeContent) updates (Proxy @a)- where- (datatypeContent, updates) =- deriveTypeContent- (Proxy @(CUSTOM a))- (Proxy @a, unzip $ implements (Proxy @a), scope, baseName, baseFingerprint)- baseName = __typeName (Proxy @a)- baseFingerprint = __typeFingerprint (Proxy @a)--type GQL_TYPE a = (Generic a, GQLType a)--deriveCustomInputObjectType ::- DeriveTypeContent IN TRUE a =>- (TypeName, proxy a) ->- TypeUpdater-deriveCustomInputObjectType (name, proxy) =- concatUpdates (snd $ introspectInputObjectFields (Proxy :: Proxy TRUE) (name, proxy))--introspectInputObjectFields ::- DeriveTypeContent IN custom a =>- proxy1 (custom :: Bool) ->- (TypeName, proxy2 a) ->- (FieldsDefinition IN CONST, [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 OUT custom a =>- proxy1 (custom :: Bool) ->- (TypeName, proxy2 a) ->- (FieldsDefinition OUT CONST, [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 = failUpdates . globalErrorMessage . ("invalid schema: " <>)---- Object Fields-class DeriveTypeContent cat (custom :: Bool) a where- deriveTypeContent ::- proxy1 custom ->- (proxy2 a, ([TypeName], [TypeUpdater]), TypeScope cat, TypeName, DataFingerprint) ->- (TypeContent TRUE cat CONST, [TypeUpdater])--instance (TypeRep cat (Rep a), Generic a) => DeriveTypeContent cat FALSE a where- deriveTypeContent _ (_, interfaces, scope, baseName, baseFingerprint) =- builder $ typeRep (ProxyRep :: ProxyRep cat (Rep a))- where- 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 ->- Maybe (FieldContent TRUE cat CONST) ->- FieldName ->- FieldDefinition cat CONST-buildField proxy fieldContent fieldName =- FieldDefinition- { fieldType = mkTypeRef (__typeName proxy),- fieldDescription = Nothing,- fieldDirectives = empty,- fieldContent = fieldContent,- ..- }--buildType :: GQLType a => TypeContent TRUE cat CONST -> Proxy a -> TypeDefinition cat CONST-buildType typeContent proxy =- TypeDefinition- { typeName = __typeName proxy,- typeFingerprint = __typeFingerprint proxy,- typeDescription = description proxy,- typeDirectives = [],- typeContent- }--updateLib ::- GQLType a =>- (Proxy a -> TypeDefinition cat CONST) ->- [TypeUpdater] ->- Proxy a ->- TypeUpdater-updateLib f stack proxy = updateSchema (__typeName proxy) (__typeFingerprint proxy) stack f proxy--updateLibOUT ::- GQLType a =>- (Proxy a -> TypeDefinition OUT CONST) ->- [TypeUpdater] ->- Proxy a ->- TypeUpdater-updateLibOUT f stack proxy = updateSchema (__typeName proxy) (__typeFingerprint proxy) stack f proxy---- NEW AUTOMATIC DERIVATION SYSTEM--data ConsRep cat = ConsRep- { consName :: TypeName,- consIsRecord :: Bool,- consFields :: [FieldRep cat]- }--data FieldRep cat = FieldRep- { fieldTypeName :: TypeName,- fieldData :: FieldDefinition cat CONST,- fieldTypeUpdater :: TypeUpdater,- fieldIsObject :: Bool- }--data ResRep cat = ResRep- { enumCons :: [TypeName],- unionRef :: [TypeName],- unionRecordRep :: [ConsRep cat]- }--isEmpty :: ConsRep cat -> Bool-isEmpty ConsRep {consFields = []} = True-isEmpty _ = False--isUnionRef :: TypeName -> ConsRep cat -> Bool-isUnionRef baseName ConsRep {consName, consFields = [FieldRep {fieldIsObject = True, fieldTypeName}]} =- consName == baseName <> fieldTypeName-isUnionRef _ _ = False--setFieldNames :: ConsRep cat -> ConsRep cat-setFieldNames cons@ConsRep {consFields} =- cons- { consFields = zipWith setFieldName ([0 ..] :: [Int]) consFields- }- where- setFieldName i fieldR@FieldRep {fieldData = fieldD} = fieldR {fieldData = fieldD {fieldName}}- where- fieldName = FieldName ("_" <> pack (show i))--analyseRep :: TypeName -> [ConsRep cat] -> ResRep cat-analyseRep baseName cons =- ResRep- { enumCons = map consName enumRep,- unionRef = map fieldTypeName $ concatMap consFields unionRefRep,- unionRecordRep = unionRecordRep <> map setFieldNames anyonimousUnionRep- }- where- (enumRep, left1) = partition isEmpty cons- (unionRefRep, left2) = partition (isUnionRef baseName) left1- (unionRecordRep, anyonimousUnionRep) = partition consIsRecord left2--buildInputUnion ::- (TypeName, DataFingerprint) -> [ConsRep IN] -> (TypeContent TRUE IN CONST, [TypeUpdater])-buildInputUnion (baseName, baseFingerprint) cons =- datatype- (analyseRep baseName cons)- where- datatype :: ResRep IN -> (TypeContent TRUE IN CONST, [TypeUpdater])- datatype ResRep {unionRef = [], unionRecordRep = [], enumCons} = (mkEnumContent enumCons, types)- datatype ResRep {unionRef, unionRecordRep, enumCons} =- (DataInputUnion typeMembers, types <> unionTypes)- where- typeMembers :: [UnionMember IN CONST]- typeMembers = map mkUnionMember (unionRef <> unionMembers) <> map (`UnionMember` False) enumCons- (unionMembers, unionTypes) =- buildUnions wrapInputObject baseFingerprint unionRecordRep- types = map fieldTypeUpdater $ concatMap consFields cons- wrapInputObject :: (FieldsDefinition IN CONST -> TypeContent TRUE IN CONST)- wrapInputObject = DataInputObject--buildUnionType ::- (ELEM LEAF cat ~ TRUE) =>- (TypeName, DataFingerprint) ->- (DataUnion CONST -> TypeContent TRUE cat CONST) ->- (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->- [ConsRep cat] ->- (TypeContent TRUE cat CONST, [TypeUpdater])-buildUnionType (baseName, baseFingerprint) wrapUnion wrapObject cons =- datatype- (analyseRep baseName cons)- where- --datatype :: ResRep -> (TypeContent TRUE cat, [TypeUpdater])- datatype ResRep {unionRef = [], unionRecordRep = [], enumCons} = (mkEnumContent enumCons, types)- datatype ResRep {unionRef, unionRecordRep, enumCons} =- (wrapUnion (map mkUnionMember typeMembers), types <> enumTypes <> unionTypes)- where- typeMembers = unionRef <> enumMembers <> unionMembers- (enumMembers, enumTypes) =- buildUnionEnum wrapObject baseName baseFingerprint enumCons- (unionMembers, unionTypes) =- buildUnions wrapObject baseFingerprint unionRecordRep- types = map fieldTypeUpdater $ concatMap consFields cons--buildObject :: ([TypeName], [TypeUpdater]) -> TypeScope cat -> [FieldRep cat] -> (TypeContent TRUE cat CONST, [TypeUpdater])-buildObject (interfaces, interfaceTypes) scope consFields =- ( wrapWith scope fields,- types <> interfaceTypes- )- where- (fields, types) = buildDataObject consFields- --- wrap with- wrapWith :: TypeScope cat -> FieldsDefinition cat CONST -> TypeContent TRUE cat CONST- wrapWith InputType = DataInputObject- wrapWith OutputType = DataObject interfaces--buildDataObject :: [FieldRep cat] -> (FieldsDefinition cat CONST, [TypeUpdater])-buildDataObject consFields = (fields, types)- where- fields = unsafeFromFields $ map fieldData consFields- types = map fieldTypeUpdater consFields--buildUnions ::- (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->- DataFingerprint ->- [ConsRep cat] ->- ([TypeName], [TypeUpdater])-buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons)- where- buildURecType = insertType . buildUnionRecord wrapObject baseFingerprint- members = map consName cons--buildUnionRecord ::- (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) -> DataFingerprint -> ConsRep cat -> TypeDefinition cat CONST-buildUnionRecord wrapObject typeFingerprint ConsRep {consName, consFields} =- TypeDefinition- { typeName = consName,- typeFingerprint,- typeDescription = Nothing,- typeDirectives = empty,- typeContent =- wrapObject- $ unsafeFromFields- $ map fieldData consFields- }--buildUnionEnum ::- (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->- TypeName ->- DataFingerprint ->- [TypeName] ->- ([TypeName], [TypeUpdater])-buildUnionEnum wrapObject baseName baseFingerprint enums = (members, updates)- where- members- | null enums = []- | otherwise = [enumTypeWrapperName]- enumTypeName = baseName <> "Enum"- enumTypeWrapperName = enumTypeName <> "Object"- -------------------------- updates :: [TypeUpdater]- updates- | null enums =- []- | otherwise =- [ buildEnumObject- wrapObject- enumTypeWrapperName- baseFingerprint- enumTypeName,- buildEnum enumTypeName baseFingerprint enums- ]--buildEnum :: TypeName -> DataFingerprint -> [TypeName] -> TypeUpdater-buildEnum typeName typeFingerprint tags =- insertType- ( TypeDefinition- { typeDescription = Nothing,- typeDirectives = empty,- typeContent = mkEnumContent tags,- ..- } ::- TypeDefinition LEAF CONST- )--buildEnumObject ::- (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->- TypeName ->- DataFingerprint ->- TypeName ->- TypeUpdater-buildEnumObject wrapObject typeName typeFingerprint enumTypeName =- insertType- TypeDefinition- { typeName,- typeFingerprint,- typeDescription = Nothing,- typeDirectives = empty,- typeContent =- wrapObject- $ singleton- $ mkInputValue "enum" [] enumTypeName- }--data TypeScope (cat :: TypeCategory) where- InputType :: TypeScope IN- OutputType :: TypeScope OUT--deriving instance Show (TypeScope cat)--deriving instance Eq (TypeScope cat)--deriving instance Ord (TypeScope cat)---- GENERIC UNION-class TypeRep (cat :: TypeCategory) f where- typeRep :: ProxyRep cat f -> [ConsRep cat]--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 cat a, TypeRep cat b) => TypeRep cat (a :+: b) where- typeRep _ = typeRep (ProxyRep :: ProxyRep cat a) <> typeRep (ProxyRep :: ProxyRep cat b)--instance (ConRep cat f, Constructor c) => TypeRep cat (M1 C c f) where- typeRep _ =- [ ConsRep- { consName = conNameProxy (Proxy @c),- consFields = conRep (ProxyRep :: ProxyRep cat f),- consIsRecord = isRecordProxy (Proxy @c)- }- ]--class ConRep cat f where- conRep :: ProxyRep cat f -> [FieldRep cat]---- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION'-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 cat a) => ConRep cat (M1 S s (Rec0 a)) where- conRep _ =- [ FieldRep- { fieldTypeName = typeConName $ fieldType fieldData,- fieldData = fieldData,- fieldTypeUpdater = introspect (ProxyRep :: ProxyRep cat a),- fieldIsObject = isObject (ProxyRep :: ProxyRep cat a)- }- ]- where- name = selNameProxy (Proxy @s)- fieldData = field (ProxyRep :: ProxyRep cat a) name--instance ConRep cat U1 where- conRep _ = []
− src/Data/Morpheus/Server/Deriving/Resolve.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Morpheus.Server.Deriving.Resolve- ( statelessResolver,- RootResolverConstraint,- coreResolver,- deriveSchema,- )-where--import Data.Functor.Identity (Identity (..))--- MORPHEUS--import Data.Morpheus.Core- ( Config,- runApi,- )-import Data.Morpheus.Server.Deriving.Channels (ChannelCon)-import Data.Morpheus.Server.Deriving.Encode- ( EncodeCon,- deriveModel,- )-import Data.Morpheus.Server.Deriving.Introspect- ( IntroCon,- deriveSchema,- )-import Data.Morpheus.Types- ( RootResolver (..),- )-import Data.Morpheus.Types.IO- ( GQLRequest (..),- GQLResponse (..),- renderResponse,- )-import Data.Morpheus.Types.Internal.AST- ( MUTATION,- QUERY,- SUBSCRIPTION,- VALID,- Value,- )-import Data.Morpheus.Types.Internal.Resolving- ( Resolver,- ResponseStream,- ResultT (..),- )--type OperationConstraint operation event m a =- ( EncodeCon operation event m (a (Resolver operation event m)),- IntroCon (a (Resolver operation event m))- )--type RootResolverConstraint m event query mutation subscription =- ( Monad m,- OperationConstraint QUERY event m query,- OperationConstraint MUTATION event m mutation,- OperationConstraint SUBSCRIPTION event m subscription,- ChannelCon event m subscription- )--statelessResolver ::- RootResolverConstraint m event query mut sub =>- RootResolver m event query mut sub ->- Config ->- GQLRequest ->- m GQLResponse-statelessResolver root config req =- renderResponse <$> runResultT (coreResolver root config req)--coreResolver ::- RootResolverConstraint m event query mut sub =>- RootResolver m event query mut sub ->- Config ->- GQLRequest ->- ResponseStream event m (Value VALID)-coreResolver root config request = do- schema <- deriveSchema (Identity root)- runApi schema (deriveModel root) config request
+ src/Data/Morpheus/Server/Deriving/Schema.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Schema+ ( compileTimeSchemaValidation,+ DeriveType,+ deriveImplementsInterface,+ deriveSchema,+ SchemaConstraints,+ SchemaT,+ )+where++-- MORPHEUS++import Control.Applicative (Applicative (..))+import Control.Monad ((>=>), (>>=))+import Data.Functor (($>), (<$>), Functor (..))+import Data.Map (Map)+import Data.Maybe (Maybe (..))+import Data.Morpheus.Core (defaultConfig, validateSchema)+import Data.Morpheus.Internal.Utils+ ( Failure (..),+ )+import Data.Morpheus.Kind+ ( ENUM,+ GQL_KIND,+ INPUT,+ INTERFACE,+ OUTPUT,+ SCALAR,+ )+import Data.Morpheus.Server.Deriving.Schema.Internal+ ( KindedProxy (..),+ KindedType (..),+ TyContentM,+ UpdateDef (..),+ asObjectType,+ builder,+ fromSchema,+ inputType,+ outputType,+ setProxyType,+ unpackMs,+ updateByContent,+ withObject,+ )+import Data.Morpheus.Server.Deriving.Utils+ ( TypeConstraint (..),+ TypeRep (..),+ genericTo,+ )+import Data.Morpheus.Server.Types.GQLType+ ( GQLType (..),+ TypeData (..),+ )+import Data.Morpheus.Server.Types.SchemaT+ ( SchemaT,+ closeWith,+ setMutation,+ setSubscription,+ )+import Data.Morpheus.Server.Types.Types+ ( MapKind,+ Pair,+ )+import Data.Morpheus.Types.GQLScalar (GQLScalar (..))+import Data.Morpheus.Types.Internal.AST+ ( ArgumentsDefinition,+ CONST,+ CONST,+ FieldContent (..),+ FieldsDefinition,+ GQLErrors,+ IN,+ LEAF,+ MUTATION,+ OBJECT,+ OUT,+ QUERY,+ SUBSCRIPTION,+ Schema (..),+ TRUE,+ TypeCategory,+ TypeContent (..),+ TypeDefinition (..),+ TypeName,+ fieldsToArguments,+ initTypeLib,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Resolver,+ SubscriptionField (..),+ resultOr,+ )+import Data.Proxy (Proxy (..))+import Data.Set (Set)+import GHC.Generics (Generic, Rep)+import Language.Haskell.TH (Exp, Q)+import Prelude+ ( ($),+ (.),+ Bool (..),+ )++type SchemaConstraints event (m :: * -> *) query mutation subscription =+ ( DeriveTypeConstraint OUT (query (Resolver QUERY event m)),+ DeriveTypeConstraint OUT (mutation (Resolver MUTATION event m)),+ DeriveTypeConstraint OUT (subscription (Resolver SUBSCRIPTION event m))+ )++-- | normal morpheus server validates schema at runtime (after the schema derivation).+-- this method allows you to validate it at compile time.+compileTimeSchemaValidation ::+ (SchemaConstraints event m qu mu su) =>+ proxy (root m event qu mu su) ->+ Q Exp+compileTimeSchemaValidation =+ fromSchema+ . (deriveSchema >=> validateSchema True defaultConfig)++deriveSchema ::+ forall+ root+ proxy+ m+ e+ query+ mut+ subs+ f.+ ( SchemaConstraints e m query mut subs,+ Failure GQLErrors f+ ) =>+ proxy (root m e query mut subs) ->+ f (Schema CONST)+deriveSchema _ = resultOr failure pure schema+ where+ schema = closeWith (initTypeLib <$> queryDef <* mutationDef <* subscriptionDef)+ queryDef = deriveObjectType (Proxy @(query (Resolver QUERY e m)))+ mutationDef = deriveObjectType (Proxy @(mut (Resolver MUTATION e m))) >>= setMutation+ subscriptionDef = deriveObjectType (Proxy @(subs (Resolver SUBSCRIPTION e m))) >>= setSubscription++instance {-# OVERLAPPABLE #-} (GQLType a, DeriveKindedType (KIND a) a) => DeriveType cat a where+ deriveType _ = deriveKindedType (KindedProxy :: KindedProxy (KIND a) a)++-- | Generates internal GraphQL Schema for query validation and introspection rendering+class DeriveType (kind :: TypeCategory) (a :: *) where+ deriveType :: f kind a -> SchemaT ()++ deriveContent :: f kind a -> SchemaT (Maybe (FieldContent TRUE kind CONST))+ deriveContent _ = pure Nothing++deriveTypeWith :: DeriveType cat a => f a -> kinded cat b -> SchemaT ()+deriveTypeWith x = deriveType . setProxyType x++-- Maybe+instance DeriveType cat a => DeriveType cat (Maybe a) where+ deriveType = deriveTypeWith (Proxy @a)++-- List+instance DeriveType cat a => DeriveType cat [a] where+ deriveType = deriveTypeWith (Proxy @a)++-- Tuple+instance DeriveType cat (Pair k v) => DeriveType cat (k, v) where+ deriveType = deriveTypeWith (Proxy @(Pair k v))++-- Set+instance DeriveType cat [a] => DeriveType cat (Set a) where+ deriveType = deriveTypeWith (Proxy @[a])++-- Map+instance DeriveType cat (MapKind k v Maybe) => DeriveType cat (Map k v) where+ deriveType = deriveTypeWith (Proxy @(MapKind k v Maybe))++-- Resolver : a -> Resolver b+instance+ ( GQLType b,+ DeriveType OUT b,+ DeriveTypeConstraint IN a+ ) =>+ DeriveType OUT (a -> m b)+ where+ deriveContent _ = Just . FieldArgs <$> deriveArgumentDefinition (Proxy @a)+ deriveType _ = deriveType (outputType $ Proxy @b)++instance (DeriveType OUT a) => DeriveType OUT (SubscriptionField a) where+ deriveType _ = deriveType (KindedProxy :: KindedProxy OUT a)++-- GQL Resolver b, MUTATION, SUBSCRIPTION, QUERY+instance (DeriveType cat b) => DeriveType cat (Resolver fo e m b) where+ deriveType = deriveTypeWith (Proxy @b)++-- | DeriveType With specific Kind: 'kind': object, scalar, enum ...+class DeriveKindedType (kind :: GQL_KIND) a where+ deriveKindedType :: proxy kind a -> SchemaT ()++-- SCALAR+instance (GQLType a, GQLScalar a) => DeriveKindedType SCALAR a where+ deriveKindedType = updateByContent deriveScalarContent++-- ENUM+instance DeriveTypeConstraint IN a => DeriveKindedType ENUM a where+ deriveKindedType = deriveInputType++instance DeriveTypeConstraint IN a => DeriveKindedType INPUT a where+ deriveKindedType = deriveInputType++instance DeriveTypeConstraint OUT a => DeriveKindedType OUTPUT a where+ deriveKindedType = deriveOutputType++type DeriveTypeConstraint kind a =+ ( Generic a,+ GQLType a,+ TypeRep (DeriveType kind) (TyContentM kind) (Rep a),+ TypeRep (DeriveType kind) (SchemaT ()) (Rep a)+ )++instance DeriveTypeConstraint OUT a => DeriveKindedType INTERFACE a where+ deriveKindedType = updateByContent deriveInterfaceContent++deriveScalarContent :: (GQLScalar a) => f a -> SchemaT (TypeContent TRUE LEAF CONST)+deriveScalarContent = pure . DataScalar . scalarValidator++deriveInterfaceContent :: DeriveTypeConstraint OUT a => f a -> SchemaT (TypeContent TRUE OUT CONST)+deriveInterfaceContent = fmap DataInterface . deriveFields . outputType++deriveArgumentDefinition :: DeriveTypeConstraint IN a => f a -> SchemaT (ArgumentsDefinition CONST)+deriveArgumentDefinition = fmap fieldsToArguments . deriveFields . inputType++deriveFields :: DeriveTypeConstraint kind a => KindedType kind a -> SchemaT (FieldsDefinition kind CONST)+deriveFields kindedType = deriveTypeContent kindedType >>= withObject kindedType++deriveInputType :: DeriveTypeConstraint IN a => f a -> SchemaT ()+deriveInputType = updateByContent deriveTypeContent . inputType++deriveOutputType :: DeriveTypeConstraint OUT a => f a -> SchemaT ()+deriveOutputType = updateByContent deriveTypeContent . outputType++deriveObjectType :: DeriveTypeConstraint OUT a => f a -> SchemaT (TypeDefinition OBJECT CONST)+deriveObjectType = asObjectType (deriveFields . outputType)++deriveImplementsInterface :: (GQLType a, DeriveType OUT a) => f a -> SchemaT TypeName+deriveImplementsInterface x = deriveType (outputType x) $> gqlTypeName (__type x)++fieldContentConstraint :: f kind a -> TypeConstraint (DeriveType kind) (TyContentM kind) Proxy+fieldContentConstraint _ = TypeConstraint deriveFieldContent++deriveFieldContent :: forall f kind a. (DeriveType kind a) => f a -> TyContentM kind+deriveFieldContent _ = deriveType kinded *> deriveContent kinded+ where+ kinded :: KindedProxy kind a+ kinded = KindedProxy++deriveTypeContent ::+ DeriveTypeConstraint kind a =>+ KindedType kind a ->+ SchemaT (TypeContent TRUE kind CONST)+deriveTypeContent kinded =+ unpackMs (genericTo (fieldContentConstraint kinded) kinded)+ >>= fmap (updateDef kinded) . builder kinded
+ src/Data/Morpheus/Server/Deriving/Schema/Internal.hs view
@@ -0,0 +1,417 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Schema.Internal+ ( KindedProxy (..),+ KindedType (..),+ builder,+ inputType,+ outputType,+ setProxyType,+ unpackMs,+ UpdateDef (..),+ withObject,+ TyContentM,+ asObjectType,+ fromSchema,+ updateByContent,+ )+where++-- MORPHEUS++import Control.Applicative (Applicative (..))+import Control.Monad.Fail (fail)+import Data.Foldable (concatMap, traverse_)+import Data.Functor (($>), (<$>), Functor (..))+import Data.List (partition)+import qualified Data.Map as M+import Data.Maybe (Maybe (..), fromMaybe)+import Data.Morpheus.Error (globalErrorMessage)+import Data.Morpheus.Internal.Utils+ ( Failure (..),+ empty,+ singleton,+ )+import Data.Morpheus.Server.Deriving.Utils+ ( ConsRep (..),+ FieldRep (..),+ ResRep (..),+ fieldTypeName,+ isEmptyConstraint,+ isUnionRef,+ )+import Data.Morpheus.Server.Types.GQLType+ ( GQLType (..),+ TypeData (..),+ )+import Data.Morpheus.Server.Types.SchemaT+ ( SchemaT,+ insertType,+ updateSchema,+ )+import Data.Morpheus.Types.Internal.AST+ ( CONST,+ DataEnumValue (..),+ DataFingerprint (..),+ DataUnion,+ Description,+ Directives,+ ELEM,+ FieldContent (..),+ FieldDefinition (..),+ FieldName,+ FieldName (..),+ FieldsDefinition,+ IN,+ LEAF,+ OBJECT,+ OUT,+ Schema (..),+ TRUE,+ Token,+ TypeCategory,+ TypeContent (..),+ TypeDefinition (..),+ TypeName (..),+ UnionMember (..),+ VALID,+ mkEnumContent,+ mkField,+ mkInputValue,+ mkType,+ mkUnionMember,+ msg,+ unsafeFromFields,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Eventless,+ Result (..),+ )+import Data.Proxy (Proxy (..))+import Data.Semigroup ((<>))+import Data.Traversable (traverse)+import Language.Haskell.TH (Exp, Q)+import Prelude+ ( ($),+ (.),+ Bool (..),+ Show (..),+ map,+ null,+ otherwise,+ sequence,+ )++-- | context , like Proxy with multiple parameters+-- * 'kind': object, scalar, enum ...+-- * 'a': actual gql type+data KindedProxy k a+ = KindedProxy++data KindedType (cat :: TypeCategory) a where+ InputType :: KindedType IN a+ OutputType :: KindedType OUT a++-- converts:+-- f a -> KindedType IN a+-- or+-- f k a -> KindedType IN a+inputType :: f a -> KindedType IN a+inputType _ = InputType++outputType :: f a -> KindedType OUT a+outputType _ = OutputType++deriving instance Show (KindedType cat a)++setProxyType :: f b -> kinded k a -> KindedProxy k b+setProxyType _ _ = KindedProxy++fromSchema :: Eventless (Schema VALID) -> Q Exp+fromSchema Success {} = [|()|]+fromSchema Failure {errors} = fail (show errors)++withObject :: (GQLType a) => KindedType c a -> TypeContent TRUE any s -> SchemaT (FieldsDefinition c s)+withObject InputType DataInputObject {inputObjectFields} = pure inputObjectFields+withObject OutputType DataObject {objectFields} = pure objectFields+withObject x _ = failureOnlyObject x++asObjectType ::+ GQLType a =>+ (f2 a -> SchemaT (FieldsDefinition OUT CONST)) ->+ f2 a ->+ SchemaT (TypeDefinition OBJECT CONST)+asObjectType f proxy = (`mkObjectType` gqlTypeName (__type proxy)) <$> f proxy++mkObjectType :: FieldsDefinition OUT CONST -> TypeName -> TypeDefinition OBJECT CONST+mkObjectType fields typeName = mkType typeName (DataObject [] fields)++failureOnlyObject :: forall c a b. (GQLType a) => KindedType c a -> SchemaT b+failureOnlyObject _ =+ failure+ $ globalErrorMessage+ $ msg (gqlTypeName $ __type (Proxy @a)) <> " should have only one nonempty constructor"++type TyContentM kind = (SchemaT (Maybe (FieldContent TRUE kind CONST)))++type TyContent kind = Maybe (FieldContent TRUE kind CONST)++unpackM :: FieldRep (TyContentM k) -> SchemaT (FieldRep (TyContent k))+unpackM FieldRep {..} =+ FieldRep fieldSelector fieldTypeRef fieldIsObject+ <$> fieldValue++unpackCons :: ConsRep (TyContentM k) -> SchemaT (ConsRep (TyContent k))+unpackCons ConsRep {..} = ConsRep consName <$> traverse unpackM consFields++unpackMs :: [ConsRep (TyContentM k)] -> SchemaT [ConsRep (TyContent k)]+unpackMs = traverse unpackCons++builder ::+ forall kind (a :: *).+ GQLType a =>+ KindedType kind a ->+ [ConsRep (TyContent kind)] ->+ SchemaT (TypeContent TRUE kind CONST)+builder scope [ConsRep {consFields}] = buildObj <$> sequence (implements (Proxy @a))+ where+ buildObj interfaces = wrapFields interfaces scope (mkFieldsDefinition consFields)+builder scope cons = genericUnion scope cons+ where+ proxy = Proxy @a+ typeData = __type proxy+ genericUnion InputType = buildInputUnion typeData+ genericUnion OutputType = buildUnionType typeData DataUnion (DataObject [])++class UpdateDef value where+ updateDef :: GQLType a => f a -> value -> value++instance UpdateDef (TypeContent TRUE c CONST) where+ updateDef proxy DataObject {objectFields = fields, ..} =+ DataObject {objectFields = fmap (updateDef proxy) fields, ..}+ updateDef proxy DataInputObject {inputObjectFields = fields} =+ DataInputObject {inputObjectFields = fmap (updateDef proxy) fields, ..}+ updateDef proxy DataInterface {interfaceFields = fields} =+ DataInterface {interfaceFields = fmap (updateDef proxy) fields, ..}+ updateDef proxy (DataEnum enums) = DataEnum $ fmap (updateDef proxy) enums+ updateDef _ x = x++instance GetFieldContent cat => UpdateDef (FieldDefinition cat CONST) where+ updateDef proxy FieldDefinition {fieldName, fieldType, fieldContent} =+ FieldDefinition+ { fieldName,+ fieldDescription = lookupDescription (readName fieldName) proxy,+ fieldDirectives = lookupDirectives (readName fieldName) proxy,+ fieldContent = getFieldContent fieldName fieldContent proxy,+ ..+ }++instance UpdateDef (DataEnumValue CONST) where+ updateDef proxy DataEnumValue {enumName} =+ DataEnumValue+ { enumName,+ enumDescription = lookupDescription (readTypeName enumName) proxy,+ enumDirectives = lookupDirectives (readTypeName enumName) proxy+ }++lookupDescription :: GQLType a => Token -> f a -> Maybe Description+lookupDescription name = (name `M.lookup`) . getDescriptions++lookupDirectives :: GQLType a => Token -> f a -> Directives CONST+lookupDirectives name = fromMaybe [] . (name `M.lookup`) . getDirectives++class GetFieldContent c where+ getFieldContent :: GQLType a => FieldName -> Maybe (FieldContent TRUE c CONST) -> f a -> Maybe (FieldContent TRUE c CONST)++instance GetFieldContent IN where+ getFieldContent name val proxy =+ case name `M.lookup` getFieldContents proxy of+ Just (Just x, _) -> Just (DefaultInputValue x)+ _ -> val++instance GetFieldContent OUT where+ getFieldContent name args proxy =+ case name `M.lookup` getFieldContents proxy of+ Just (_, Just x) -> Just (FieldArgs x)+ _ -> args++updateByContent ::+ GQLType a =>+ (f kind a -> SchemaT (TypeContent TRUE cat CONST)) ->+ f kind a ->+ SchemaT ()+updateByContent f proxy =+ updateSchema+ (gqlTypeName $ __type proxy)+ (gqlFingerprint $ __type proxy)+ deriveD+ proxy+ where+ deriveD _ = buildType proxy <$> f proxy++analyseRep :: TypeName -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> ResRep (Maybe (FieldContent TRUE kind CONST))+analyseRep baseName cons =+ ResRep+ { enumCons = fmap consName enumRep,+ unionRef = fieldTypeName <$> concatMap consFields unionRefRep,+ unionRecordRep+ }+ where+ (enumRep, left1) = partition isEmptyConstraint cons+ (unionRefRep, unionRecordRep) = partition (isUnionRef baseName) left1++buildInputUnion ::+ TypeData ->+ [ConsRep (Maybe (FieldContent TRUE IN CONST))] ->+ SchemaT (TypeContent TRUE IN CONST)+buildInputUnion TypeData {gqlTypeName, gqlFingerprint} =+ mkInputUnionType gqlFingerprint . analyseRep gqlTypeName++buildUnionType ::+ (ELEM LEAF kind ~ TRUE) =>+ TypeData ->+ (DataUnion CONST -> TypeContent TRUE kind CONST) ->+ (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->+ [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->+ SchemaT (TypeContent TRUE kind CONST)+buildUnionType typeData wrapUnion wrapObject =+ mkUnionType typeData wrapUnion wrapObject . analyseRep (gqlTypeName typeData)++mkInputUnionType :: DataFingerprint -> ResRep (Maybe (FieldContent TRUE IN CONST)) -> SchemaT (TypeContent TRUE IN CONST)+mkInputUnionType _ ResRep {unionRef = [], unionRecordRep = [], enumCons} = pure $ mkEnumContent enumCons+mkInputUnionType baseFingerprint ResRep {unionRef, unionRecordRep, enumCons} = DataInputUnion <$> typeMembers+ where+ typeMembers :: SchemaT [UnionMember IN CONST]+ typeMembers = withMembers <$> buildUnions wrapInputObject baseFingerprint unionRecordRep+ where+ withMembers unionMembers = fmap mkUnionMember (unionRef <> unionMembers) <> fmap (`UnionMember` False) enumCons+ wrapInputObject :: (FieldsDefinition IN CONST -> TypeContent TRUE IN CONST)+ wrapInputObject = DataInputObject++mkUnionType ::+ (ELEM LEAF kind ~ TRUE) =>+ TypeData ->+ (DataUnion CONST -> TypeContent TRUE kind CONST) ->+ (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->+ ResRep (Maybe (FieldContent TRUE kind CONST)) ->+ SchemaT (TypeContent TRUE kind CONST)+mkUnionType _ _ _ ResRep {unionRef = [], unionRecordRep = [], enumCons} = pure $ mkEnumContent enumCons+mkUnionType typeData@TypeData {gqlFingerprint} wrapUnion wrapObject ResRep {unionRef, unionRecordRep, enumCons} = wrapUnion . map mkUnionMember <$> typeMembers+ where+ typeMembers = do+ enums <- buildUnionEnum wrapObject typeData enumCons+ unions <- buildUnions wrapObject gqlFingerprint unionRecordRep+ pure (unionRef <> enums <> unions)++wrapFields :: [TypeName] -> KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST+wrapFields _ InputType = DataInputObject+wrapFields interfaces OutputType = DataObject interfaces++mkFieldsDefinition :: [FieldRep (Maybe (FieldContent TRUE kind CONST))] -> FieldsDefinition kind CONST+mkFieldsDefinition = unsafeFromFields . fmap fieldByRep++fieldByRep :: FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST+fieldByRep FieldRep {fieldSelector, fieldTypeRef, fieldValue} =+ mkField fieldValue fieldSelector fieldTypeRef++buildUnions ::+ (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->+ DataFingerprint ->+ [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->+ SchemaT [TypeName]+buildUnions wrapObject baseFingerprint cons =+ traverse_ buildURecType cons $> fmap consName cons+ where+ buildURecType = insertType . buildUnionRecord wrapObject baseFingerprint++buildUnionEnum ::+ (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->+ TypeData ->+ [TypeName] ->+ SchemaT [TypeName]+buildUnionEnum wrapObject TypeData {gqlTypeName, gqlFingerprint} enums = updates $> members+ where+ members+ | null enums = []+ | otherwise = [enumTypeWrapperName]+ enumTypeName = gqlTypeName <> "Enum"+ enumTypeWrapperName = enumTypeName <> "Object"+ -------------------------+ updates :: SchemaT ()+ updates+ | null enums = pure ()+ | otherwise =+ buildEnumObject wrapObject enumTypeWrapperName gqlFingerprint enumTypeName+ *> buildEnum enumTypeName gqlFingerprint enums++buildType :: GQLType a => f a -> TypeContent TRUE cat CONST -> TypeDefinition cat CONST+buildType proxy typeContent =+ TypeDefinition+ { typeName = gqlTypeName typeData,+ typeFingerprint = gqlFingerprint typeData,+ typeDescription = description proxy,+ typeDirectives = [],+ typeContent+ }+ where+ typeData = __type proxy++buildUnionRecord ::+ (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->+ DataFingerprint ->+ ConsRep (Maybe (FieldContent TRUE kind CONST)) ->+ TypeDefinition kind CONST+buildUnionRecord wrapObject typeFingerprint ConsRep {consName, consFields} =+ mkSubType consName typeFingerprint (wrapObject $ mkFieldsDefinition consFields)++buildEnum :: TypeName -> DataFingerprint -> [TypeName] -> SchemaT ()+buildEnum typeName typeFingerprint tags =+ insertType+ ( mkSubType typeName typeFingerprint (mkEnumContent tags) ::+ TypeDefinition LEAF CONST+ )++buildEnumObject ::+ (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->+ TypeName ->+ DataFingerprint ->+ TypeName ->+ SchemaT ()+buildEnumObject wrapObject typeName typeFingerprint enumTypeName =+ insertType $+ mkSubType+ typeName+ typeFingerprint+ ( wrapObject+ $ singleton+ $ mkInputValue "enum" [] enumTypeName+ )++mkSubType :: TypeName -> DataFingerprint -> TypeContent TRUE k CONST -> TypeDefinition k CONST+mkSubType typeName typeFingerprint typeContent =+ TypeDefinition+ { typeName,+ typeFingerprint,+ typeDescription = Nothing,+ typeDirectives = empty,+ typeContent+ }
src/Data/Morpheus/Server/Deriving/Utils.hs view
@@ -1,52 +1,244 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Deriving.Utils- ( EnumRep (..),- datatypeNameProxy,+ ( datatypeNameProxy, conNameProxy,- selNameProxy, isRecordProxy,+ selNameProxy,+ ResRep (..),+ TypeRep (..),+ ConsRep (..),+ TypeConstraint (..),+ FieldRep (..),+ isEmptyConstraint,+ genericTo,+ DataType (..),+ deriveFieldRep,+ ConRep (..),+ toValue,+ isUnionRef,+ fieldTypeName, ) where +import Data.Functor (Functor (..))+import Data.Functor.Identity (Identity (..))+import Data.Morpheus.Server.Types.GQLType+ ( GQLType (..),+ GQLTypeOptions (..),+ TypeData (..),+ ) import Data.Morpheus.Types.Internal.AST- ( FieldName,- FieldName (..),+ ( FieldName (..), TypeName (..),+ TypeRef (..), convertToJSONName, ) import Data.Proxy (Proxy (..))+import Data.Semigroup (Semigroup (..)) import Data.Text ( pack, )+import GHC.Exts (Constraint) import GHC.Generics---- MORPHEUS-class EnumRep (f :: * -> *) where- enumTags :: Proxy f -> [TypeName]--instance EnumRep f => EnumRep (M1 D c f) where- enumTags _ = enumTags (Proxy @f)--instance (Constructor c) => EnumRep (M1 C c U1) where- enumTags _ = [conNameProxy (Proxy @c)]--instance (EnumRep a, EnumRep b) => EnumRep (a :+: b) where- enumTags _ = enumTags (Proxy @a) ++ enumTags (Proxy @b)+ ( (:*:) (..),+ (:+:) (..),+ C,+ Constructor,+ D,+ Datatype,+ Generic (..),+ K1 (..),+ M1 (..),+ Meta,+ Rec0,+ S,+ Selector,+ U1 (..),+ conIsRecord,+ conName,+ datatypeName,+ selName,+ )+import Prelude+ ( ($),+ (.),+ Bool (..),+ Eq (..),+ Int,+ Maybe (..),+ otherwise,+ show,+ undefined,+ zipWith,+ ) datatypeNameProxy :: forall f (d :: Meta). Datatype d => f d -> TypeName datatypeNameProxy _ = TypeName $ pack $ datatypeName (undefined :: (M1 D d f a)) -conNameProxy :: forall f (c :: Meta). Constructor c => f c -> TypeName-conNameProxy _ = TypeName $ pack $ conName (undefined :: M1 C c U1 a)+conNameProxy :: forall f (c :: Meta). Constructor c => GQLTypeOptions -> f c -> TypeName+conNameProxy GQLTypeOptions {constructorTagModifier} _ =+ TypeName $ pack $ constructorTagModifier $ conName (undefined :: M1 C c U1 a) -selNameProxy :: forall f (s :: Meta). Selector s => f s -> FieldName-selNameProxy _ = convertToJSONName $ FieldName $ pack $ selName (undefined :: M1 S s f a)+selNameProxy :: forall f (s :: Meta). Selector s => GQLTypeOptions -> f s -> FieldName+selNameProxy GQLTypeOptions {fieldLabelModifier} _ =+ convertToJSONName $ FieldName $ pack $ fieldLabelModifier $ selName (undefined :: M1 S s f a) isRecordProxy :: forall f (c :: Meta). Constructor c => f c -> Bool isRecordProxy _ = conIsRecord (undefined :: (M1 C c f a))++newtype TypeConstraint (c :: * -> Constraint) (v :: *) (f :: * -> *) = TypeConstraint+ { typeConstraint :: forall a. c a => f a -> v+ }++genericTo ::+ forall f constraint value (a :: *).+ (GQLType a, TypeRep constraint value (Rep a)) =>+ TypeConstraint constraint value Proxy ->+ f a ->+ [ConsRep value]+genericTo f proxy = typeRep (typeOptions proxy, f) (Proxy @(Rep a))++toValue ::+ forall constraint value (a :: *).+ (GQLType a, Generic a, TypeRep constraint value (Rep a)) =>+ TypeConstraint constraint value Identity ->+ a ->+ DataType value+toValue f = toTypeRep (typeOptions (Proxy @a), f) . from++-- GENERIC UNION+class TypeRep (c :: * -> Constraint) (v :: *) f where+ typeRep :: (GQLTypeOptions, TypeConstraint c v Proxy) -> proxy f -> [ConsRep v]+ toTypeRep :: (GQLTypeOptions, TypeConstraint c v Identity) -> f a -> DataType v++instance (Datatype d, TypeRep c v f) => TypeRep c v (M1 D d f) where+ typeRep fun _ = typeRep fun (Proxy @f)+ toTypeRep fun (M1 src) = (toTypeRep fun src) {tyName = datatypeNameProxy (Proxy @d)}++-- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'+instance (TypeRep c v a, TypeRep c v b) => TypeRep c v (a :+: b) where+ typeRep fun _ = typeRep fun (Proxy @a) <> typeRep fun (Proxy @b)+ toTypeRep f (L1 x) = (toTypeRep f x) {tyIsUnion = True}+ toTypeRep f (R1 x) = (toTypeRep f x) {tyIsUnion = True}++instance (ConRep con v f, Constructor c) => TypeRep con v (M1 C c f) where+ typeRep f@(opt, _) _ = [deriveConsRep opt (Proxy @c) (conRep f (Proxy @f))]+ toTypeRep f@(opt, _) (M1 src) =+ DataType+ { tyName = "",+ tyIsUnion = False,+ tyCons = deriveConsRep opt (Proxy @c) (toFieldRep f src)+ }++deriveConsRep ::+ Constructor (c :: Meta) =>+ GQLTypeOptions ->+ f c ->+ [FieldRep v] ->+ ConsRep v+deriveConsRep opt proxy fields =+ ConsRep+ { consName = conNameProxy opt proxy,+ consFields+ }+ where+ consFields+ | isRecordProxy proxy = fields+ | otherwise = enumerate fields++class ConRep (c :: * -> Constraint) (v :: *) f where+ conRep :: (GQLTypeOptions, TypeConstraint c v Proxy) -> proxy f -> [FieldRep v]+ toFieldRep :: (GQLTypeOptions, TypeConstraint c v Identity) -> f a -> [FieldRep v]++-- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION'+instance (ConRep c v a, ConRep c v b) => ConRep c v (a :*: b) where+ conRep fun _ = conRep fun (Proxy @a) <> conRep fun (Proxy @b)+ toFieldRep fun (a :*: b) = toFieldRep fun a <> toFieldRep fun b++instance (Selector s, GQLType a, c a) => ConRep c v (M1 S s (Rec0 a)) where+ conRep (opt, TypeConstraint f) _ = [deriveFieldRep opt (Proxy @s) (Proxy @a) (f $ Proxy @a)]+ toFieldRep (opt, TypeConstraint f) (M1 (K1 src)) = [deriveFieldRep opt (Proxy @s) (Proxy @a) (f (Identity src))]++deriveFieldRep ::+ forall f (s :: Meta) g a v.+ (Selector s, GQLType a) =>+ GQLTypeOptions ->+ f s ->+ g a ->+ v ->+ FieldRep v+deriveFieldRep opt pSel proxy v =+ FieldRep+ { fieldSelector = selNameProxy opt pSel,+ fieldTypeRef =+ TypeRef+ { typeConName = gqlTypeName,+ typeWrappers = gqlWrappers,+ typeArgs = Nothing+ },+ fieldIsObject = isObjectKind proxy,+ fieldValue = v+ }+ where+ TypeData {gqlTypeName, gqlWrappers} = __type proxy++instance ConRep c v U1 where+ conRep _ _ = []+ toFieldRep _ _ = []++data DataType (v :: *) = DataType+ { tyName :: TypeName,+ tyIsUnion :: Bool,+ tyCons :: ConsRep v+ }++data ConsRep (v :: *) = ConsRep+ { consName :: TypeName,+ consFields :: [FieldRep v]+ }++data FieldRep (a :: *) = FieldRep+ { fieldSelector :: FieldName,+ fieldTypeRef :: TypeRef,+ fieldIsObject :: Bool,+ fieldValue :: a+ }+ deriving (Functor)++data ResRep (a :: *) = ResRep+ { enumCons :: [TypeName],+ unionRef :: [TypeName],+ unionRecordRep :: [ConsRep a]+ }++isEmptyConstraint :: ConsRep a -> Bool+isEmptyConstraint ConsRep {consFields = []} = True+isEmptyConstraint _ = False++-- setFieldNames :: Power Int Text -> Power { _1 :: Int, _2 :: Text }+enumerate :: [FieldRep a] -> [FieldRep a]+enumerate = zipWith setFieldName ([0 ..] :: [Int])+ where+ setFieldName i field = field {fieldSelector = FieldName $ "_" <> pack (show i)}++fieldTypeName :: FieldRep k -> TypeName+fieldTypeName = typeConName . fieldTypeRef++isUnionRef :: TypeName -> ConsRep k -> Bool+isUnionRef baseName ConsRep {consName, consFields = [fieldRep@FieldRep {fieldIsObject = True}]} =+ consName == baseName <> fieldTypeName fieldRep+isUnionRef _ _ = False
src/Data/Morpheus/Server/Internal/TH/Decode.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Internal.TH.Decode ( withInputObject,@@ -15,6 +16,12 @@ where -- MORPHEUS++import Control.Applicative (Applicative (..))+import Control.Monad (Monad ((>>=)))+import Data.Either (Either (..))+import Data.Functor ((<$>))+import Data.Maybe (Maybe (..)) import Data.Morpheus.Internal.Utils ( empty, selectBy,@@ -43,6 +50,8 @@ ( Failure (..), ) import Data.Semigroup ((<>))+import Data.Traversable (traverse)+import Prelude ((.)) withInputObject :: Failure InternalError m =>@@ -80,9 +89,9 @@ unions >>= providesValueFor . entryValue where- providesValueFor (Enum key) = selectOr notfound onFound (toFieldName key) unions+ providesValueFor (Enum key) = selectOr notFound onFound (toFieldName key) unions where- notfound = withInputObject (decoder key unions) (Object empty)+ notFound = withInputObject (decoder key unions) (Object empty) onFound = withInputObject (decoder key unions) . entryValue providesValueFor _ = failure ("__typename must be Enum" :: InternalError)
src/Data/Morpheus/Server/Internal/TH/Types.hs view
@@ -1,25 +1,39 @@+{-# LANGUAGE NoImplicitPrelude #-}+ module Data.Morpheus.Server.Internal.TH.Types ( ServerTypeDefinition (..),+ ServerDec,+ ServerDecContext (..), ) where +import Control.Monad.Reader (Reader) import Data.Morpheus.Types.Internal.AST ( ANY, ConsD (..),- FieldName, IN, TypeDefinition, TypeKind, TypeName, )+import Prelude+ ( Bool,+ Maybe,+ Show,+ ) --- Core data ServerTypeDefinition cat s = ServerTypeDefinition { tName :: TypeName,- tNamespace :: [FieldName], typeArgD :: [ServerTypeDefinition IN s], tCons :: [ConsD cat s], tKind :: TypeKind, typeOriginal :: Maybe (TypeDefinition ANY s) } deriving (Show)++type ServerDec = Reader ServerDecContext++newtype ServerDecContext = ServerDecContext+ { namespace :: Bool+ }
src/Data/Morpheus/Server/Internal/TH/Utils.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Internal.TH.Utils ( kindName,@@ -40,9 +41,16 @@ Type (..), cxt, )+import Prelude+ ( ($),+ (.),+ String,+ map,+ pure,+ ) o' :: Type-o' = VarT $ toName ("oparation" :: TypeName)+o' = VarT $ toName ("operation" :: TypeName) e' :: Type e' = VarT $ toName ("encodeEvent" :: TypeName)@@ -56,7 +64,7 @@ constraintTypeable :: Type -> Type constraintTypeable name = apply ''Typeable [name] -mkTypeableConstraints :: [TypeName] -> CxtQ+mkTypeableConstraints :: [String] -> CxtQ mkTypeableConstraints args = cxt $ map (pure . constraintTypeable) (vars args) kindName :: TypeKind -> Name
src/Data/Morpheus/Server/Playground.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Playground ( httpPlayground,@@ -10,7 +11,12 @@ where import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Functor (fmap) import Data.Semigroup ((<>))+import Prelude+ ( (.),+ mconcat,+ ) link :: ByteString -> ByteString -> ByteString link rel href = "<link rel=\"" <> rel <> "\" href=\"" <> href <> "\" />"@@ -23,7 +29,7 @@ t :: ByteString -> [(ByteString, ByteString)] -> [ByteString] -> ByteString t tagName attr children =- "<" <> tagName <> " " <> mconcat (map renderAttr attr) <> " >" <> mconcat children <> "</" <> tagName <> ">"+ "<" <> tagName <> " " <> mconcat (fmap renderAttr attr) <> " >" <> mconcat children <> "</" <> tagName <> ">" where renderAttr (name, value) = name <> "=\"" <> value <> "\" "
src/Data/Morpheus/Server/TH/Compile.hs view
@@ -17,6 +17,9 @@ ( gqlWarnings, renderGQLErrors, )+import Data.Morpheus.Server.Internal.TH.Types+ ( ServerDecContext (..),+ ) import Data.Morpheus.Server.TH.Declare ( declare, )@@ -29,8 +32,8 @@ import qualified Data.Text as T ( pack, )-import Language.Haskell.TH-import Language.Haskell.TH.Quote+import Language.Haskell.TH (Dec, Q)+import Language.Haskell.TH.Quote (QuasiQuoter (..)) gqlDocumentNamespace :: QuasiQuoter gqlDocumentNamespace =@@ -38,7 +41,7 @@ { quoteExp = notHandled "Expressions", quotePat = notHandled "Patterns", quoteType = notHandled "Types",- quoteDec = compileDocument True+ quoteDec = compileDocument ServerDecContext {namespace = True} } where notHandled things =@@ -50,15 +53,15 @@ { quoteExp = notHandled "Expressions", quotePat = notHandled "Patterns", quoteType = notHandled "Types",- quoteDec = compileDocument False+ quoteDec = compileDocument ServerDecContext {namespace = False} } where notHandled things = error $ things ++ " are not supported by the GraphQL QuasiQuoter" -compileDocument :: Bool -> String -> Q [Dec]-compileDocument namespace documentTXT =+compileDocument :: ServerDecContext -> String -> Q [Dec]+compileDocument ctx documentTXT = case parseTypeDefinitions (T.pack documentTXT) of Failure errors -> fail (renderGQLErrors errors) Success {result = schema, warnings} ->- gqlWarnings warnings >> toTHDefinitions namespace schema >>= declare namespace+ gqlWarnings warnings >> toTHDefinitions (namespace ctx) schema >>= declare ctx
src/Data/Morpheus/Server/TH/Declare.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.TH.Declare ( declare,@@ -9,77 +10,48 @@ where -- MORPHEUS-+import Control.Applicative (pure)+import Control.Monad.Reader (runReader)+import Data.Foldable (concat)+import Data.Functor (fmap) import Data.Morpheus.Server.Internal.TH.Types- ( ServerTypeDefinition (..),- )-import Data.Morpheus.Server.TH.Declare.Channels- ( deriveChannels,- )-import Data.Morpheus.Server.TH.Declare.Decode- ( deriveDecode,- )-import Data.Morpheus.Server.TH.Declare.Encode- ( deriveEncode,+ ( ServerDecContext (..),+ ServerTypeDefinition (..), ) 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 Data.Traversable (traverse) import Language.Haskell.TH+import Prelude+ ( ($),+ (.),+ ) class Declare a where- type DeclareCtx a :: *- declare :: DeclareCtx a -> a -> Q [Dec]+ declare :: ServerDecContext -> a -> Q [Dec] instance Declare a => Declare [a] where- type DeclareCtx [a] = DeclareCtx a declare namespace = fmap concat . traverse (declare namespace) instance Declare (TypeDec s) where- type DeclareCtx (TypeDec s) = Bool declare namespace (InputType typeD) = declare namespace typeD declare namespace (OutputType typeD) = declare namespace typeD instance Declare (ServerTypeDefinition cat s) where- type DeclareCtx (ServerTypeDefinition cat s) = Bool- declare namespace typeD@ServerTypeDefinition {tKind, typeArgD, typeOriginal} =+ declare ctx typeD@ServerTypeDefinition {typeArgD} = 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, deriveChannels typeD]- | otherwise =- []+ typeDef <- declareServerType ctx typeD+ argTypes <- traverse (declareServerType ctx) typeArgD+ pure $ typeDef <> concat argTypes -declareArgTypes :: Bool -> [ServerTypeDefinition IN s] -> 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+declareServerType :: ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]+declareServerType ctx argType = do+ typeClasses <- deriveGQLType ctx argType+ let defs = runReader (declareType argType) ctx+ pure (defs <> typeClasses)
− src/Data/Morpheus/Server/TH/Declare/Channels.hs
@@ -1,79 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Server.TH.Declare.Channels- ( deriveChannels,- )-where--import Data.Morpheus.Internal.TH- ( _',- apply,- destructRecord,- funDSimple,- m',- mkFieldsE,- )-import Data.Morpheus.Server.Deriving.Channels- ( ExploreChannels (..),- GetChannel (..),- )-import Data.Morpheus.Server.Internal.TH.Types- ( ServerTypeDefinition (..),- )-import Data.Morpheus.Server.Internal.TH.Utils- ( e',- )-import Data.Morpheus.Types.Internal.AST- ( ConsD (..),- FieldDefinition (..),- FieldName,- SUBSCRIPTION,- Selection,- TRUE,- TypeName (..),- VALID,- isSubscription,- )-import Data.Morpheus.Types.Internal.Resolving- ( Channel,- Resolver,- ResolverState,- )-import Data.Semigroup ((<>))-import Language.Haskell.TH--mkEntry ::- GetChannel e a =>- FieldName ->- a ->- ( FieldName,- Selection VALID -> ResolverState (Channel e)- )-mkEntry name field = (name, getChannel field)---- | defines :: "MyType" ==> MyType (Resolver SUBSCRIPTION e m)-mkType :: TypeName -> Type-mkType tName = apply tName [apply ''Resolver [ConT ''SUBSCRIPTION, e', m']]---- | defines: ExploreChannels ('TRUE) (<Type> (Resolver SUBSCRIPTION e m)) e-mkTypeClass :: TypeName -> Type-mkTypeClass tName = apply ''ExploreChannels [ConT ''TRUE, mkType tName, e']--exploreChannelsD :: TypeName -> [FieldDefinition cat s] -> DecQ-exploreChannelsD tName fields = funDSimple 'exploreChannels args body- where- args = [_', destructRecord tName fields]- body = pure (mkFieldsE 'mkEntry fields)--deriveChannels :: ServerTypeDefinition cat s -> Q [Dec]-deriveChannels ServerTypeDefinition {tName, tCons = [ConsD {cFields}], tKind}- | isSubscription tKind =- pure <$> instanceD context typeDef funDefs- where- context = cxt []- typeDef = pure (mkTypeClass tName)- funDefs = [exploreChannelsD tName cFields]-deriveChannels _ = pure []
− src/Data/Morpheus/Server/TH/Declare/Decode.hs
@@ -1,60 +0,0 @@-{-# 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- ( applyCons,- decodeObjectE,- funDSimple,- v',- )-import Data.Morpheus.Server.Deriving.Decode- ( Decode (..),- DecodeType (..),- )-import Data.Morpheus.Server.Internal.TH.Decode- ( decodeFieldWith,- withInputObject,- )-import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))-import Data.Morpheus.Types.Internal.AST- ( ConsD (..),- FieldName,- TypeName,- ValidValue,- )-import Data.Morpheus.Types.Internal.Resolving- ( ResolverState,- )-import Language.Haskell.TH--decodeFieldValue :: Decode a => ValidValue -> FieldName -> ResolverState a-decodeFieldValue value selectorName = withInputObject (decodeFieldWith decode selectorName) value--mkTypeClass :: TypeName -> Q Type-mkTypeClass tName = applyCons ''DecodeType [tName]--decodeValueD :: ConsD cat s -> DecQ-decodeValueD ConsD {cName, cFields} = funDSimple 'decodeType [v'] body- where- body = decodeObjectE (const 'decodeFieldValue) cName cFields--deriveDecode :: ServerTypeDefinition cat s -> Q [Dec]-deriveDecode- ServerTypeDefinition- { tName,- tCons = [cons]- } =- pure <$> instanceD (cxt []) (mkTypeClass tName) [decodeValueD cons]-deriveDecode _ = pure []
− src/Data/Morpheus/Server/TH/Declare/Encode.hs
@@ -1,107 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Server.TH.Declare.Encode- ( deriveEncode,- )-where------- MORPHEUS--import Data.Morpheus.Internal.TH- ( _',- apply,- destructRecord,- e',- funDSimple,- m',- mkFieldsE,- o',- )-import Data.Morpheus.Server.Deriving.Encode- ( Encode (..),- ExploreResolvers (..),- )-import Data.Morpheus.Server.Internal.TH.Types- ( ServerTypeDefinition (..),- )-import Data.Morpheus.Server.Internal.TH.Utils- ( constraintTypeable,- typeNameStringE,- withPure,- )-import Data.Morpheus.Types.Internal.AST- ( ConsD (..),- FieldDefinition (..),- TRUE,- TypeName (..),- )-import Data.Morpheus.Types.Internal.Resolving- ( LiftOperation,- ResModel,- Resolver,- mkObject,- )-import Data.Semigroup ((<>))-import Language.Haskell.TH--vars :: [Type]-vars = [o', e', m']--mkType :: TypeName -> Type-mkType tName = mainType- where- mainTypeArg = [apply ''Resolver vars]- mainType = apply tName mainTypeArg--genHeadType :: TypeName -> [Type]-genHeadType tName = mkType tName : vars---- defines Constraint: (Monad m, ...)-mkConstrains :: TypeName -> [Type]-mkConstrains tName =- [ apply ''Monad [m'],- apply ''Encode (genHeadType tName),- apply ''LiftOperation [o']- ]- <> map constraintTypeable [o', e', m']--mkObjectE :: TypeName -> Exp -> Exp-mkObjectE name = AppE (AppE (VarE 'mkObject) (typeNameStringE name))--mkEntry ::- Encode resolver o e m =>- a ->- resolver ->- (a, Resolver o e m (ResModel o e m))-mkEntry name field = (name, encode field)--decodeObjectE :: TypeName -> [FieldDefinition cat s] -> Exp-decodeObjectE tName cFields =- withPure $- mkObjectE- tName- (mkFieldsE 'mkEntry cFields)---- | defines: ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value)-instanceType :: TypeName -> Type-instanceType tName = apply ''ExploreResolvers (ConT ''TRUE : genHeadType tName)---- | defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...]-exploreResolversD :: TypeName -> [FieldDefinition cat s] -> DecQ-exploreResolversD tName fields = funDSimple 'exploreResolvers args body- where- args = [_', destructRecord tName fields]- body = pure (decodeObjectE tName fields)--deriveEncode :: ServerTypeDefinition cat s -> Q [Dec]-deriveEncode ServerTypeDefinition {tName, tCons = [ConsD {cFields}]} =- pure <$> instanceD context typeDef funDefs- where- context = cxt (map pure $ mkConstrains tName)- typeDef = pure (instanceType tName)- funDefs = [exploreResolversD tName cFields]-deriveEncode _ = pure []
src/Data/Morpheus/Server/TH/Declare/GQLType.hs view
@@ -1,9 +1,14 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.TH.Declare.GQLType ( deriveGQLType,@@ -12,6 +17,11 @@ -- -- MORPHEUS+import Control.Applicative (Applicative (..))+import Control.Monad (Monad ((>>=)))+import Data.Functor ((<$>), fmap)+import Data.Map (Map, empty, fromList)+import Data.Maybe (Maybe (..), maybe) import Data.Morpheus.Internal.TH ( apply, applyVars,@@ -20,27 +30,57 @@ tyConArgs, typeInstanceDec, )-import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))+import Data.Morpheus.Internal.Utils+ ( elems,+ stripConstructorNamespace,+ stripFieldNamespace,+ )+import Data.Morpheus.Server.Internal.TH.Types+ ( ServerDecContext (..),+ ServerTypeDefinition (..),+ ) import Data.Morpheus.Server.Internal.TH.Utils ( kindName, mkTypeableConstraints, ) import Data.Morpheus.Server.Types.GQLType ( GQLType (..),+ GQLTypeOptions (..),+ defaultTypeOptions, ) import Data.Morpheus.Types (Resolver, interface) import Data.Morpheus.Types.Internal.AST ( ANY,+ ArgumentsDefinition,+ DataEnumValue (..),+ Description,+ Directives,+ FieldContent (..),+ FieldDefinition (..),+ FieldName (..),+ FieldsDefinition,+ IN,+ OUT, QUERY, TRUE,+ Token, TypeContent (..), TypeDefinition (..),- TypeName,- isObject,+ TypeKind (..),+ TypeName (..),+ Value, ) import Data.Proxy (Proxy (..))-import Data.Semigroup ((<>)) import Language.Haskell.TH+import Prelude+ ( ($),+ (&&),+ (.),+ Eq (..),+ concatMap,+ null,+ otherwise,+ ) interfaceF :: Name -> ExpQ interfaceF name = [|interface (Proxy :: (Proxy ($(conT name) (Resolver QUERY () Maybe))))|]@@ -48,39 +88,143 @@ introspectInterface :: TypeName -> ExpQ introspectInterface = interfaceF . toName -deriveGQLType :: ServerTypeDefinition cat s -> Q [Dec]-deriveGQLType ServerTypeDefinition {tName, tKind, typeOriginal} =- pure <$> instanceD constrains iHead (functions <> typeFamilies)- where- functions =- funDProxy- [ ('__typeName, [|tName|]),- ('description, [|tDescription|]),- ('implements, implementsFunc)- ]- where- tDescription = typeOriginal >>= typeDescription- implementsFunc = listE $ map introspectInterface (interfacesFrom typeOriginal)- --------------------------------- typeArgs = tyConArgs tKind- --------------------------------- iHead = apply ''GQLType [applyVars tName typeArgs]- headSig = applyVars tName typeArgs- ---------------------------------------------------- constrains = mkTypeableConstraints typeArgs- -------------------------------------------------- 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)+deriveGQLType :: ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]+deriveGQLType+ ServerDecContext {namespace}+ ServerTypeDefinition {tName, tKind, typeOriginal} =+ pure <$> instanceD constrains iHead (typeFamilies : functions)+ where+ functions =+ funDProxy+ [ ('description, [|tDescription|]),+ ('implements, implementsFunc),+ ('typeOptions, typeOptionsFunc),+ ('getDescriptions, fieldDescriptionsFunc),+ ('getDirectives, fieldDirectivesFunc),+ ('getFieldContents, getFieldContentsFunc)+ ]+ where+ tDescription = typeOriginal >>= typeDescription+ implementsFunc = listE $ fmap introspectInterface (interfacesFrom typeOriginal)+ typeOptionsFunc+ | namespace && tKind == KindEnum = [|GQLTypeOptions id (stripConstructorNamespace tName)|]+ | namespace = [|GQLTypeOptions (stripFieldNamespace tName) id|]+ | otherwise = [|defaultTypeOptions|]+ fieldDescriptionsFunc = [|value|]+ where+ value = getDesc typeOriginal+ fieldDirectivesFunc = [|value|]+ where+ value = getDirs typeOriginal+ getFieldContentsFunc = [|value|]+ where+ value =+ fmapFieldValues+ (fmap getDefaultValue . fieldContent)+ (fmap getDefaultValue . fieldContent)+ typeOriginal+ --------------------------------+ typeArgs = tyConArgs tKind+ --------------------------------+ iHead = apply ''GQLType [applyVars tName typeArgs]+ headSig = applyVars tName typeArgs+ ---------------------------------------------------+ constrains = mkTypeableConstraints typeArgs+ -------------------------------------------------+ typeFamilies = deriveInstance ''KIND (kindName tKind)+ where+ deriveInstance :: Name -> Name -> Q Dec+ deriveInstance insName tyName = do+ typeN <- headSig+ pure $ typeInstanceDec insName typeN (ConT tyName) interfacesFrom :: Maybe (TypeDefinition ANY s) -> [TypeName] interfacesFrom (Just TypeDefinition {typeContent = DataObject {objectImplements}}) = objectImplements interfacesFrom _ = []++fmapFieldValues :: (FieldDefinition IN s -> Maybe a) -> (FieldDefinition OUT s -> Maybe a) -> Maybe (TypeDefinition c s) -> Map FieldName a+fmapFieldValues f g = maybe empty (collectFieldValues f g)++getDesc :: Maybe (TypeDefinition c s) -> Map Token Description+getDesc = fromList . get++getDirs :: Maybe (TypeDefinition c s) -> Map Token (Directives s)+getDirs = fromList . get++class Meta a v where+ get :: a -> [(Token, v)]++instance (Meta a v) => Meta (Maybe a) v where+ get (Just x) = get x+ get _ = []++instance+ ( Meta (FieldsDefinition IN s) v,+ Meta (FieldsDefinition OUT s) v,+ Meta (DataEnumValue s) v+ ) =>+ Meta (TypeDefinition c s) v+ where+ get TypeDefinition {typeContent} = get typeContent++instance+ ( Meta (FieldsDefinition IN s) v,+ Meta (FieldsDefinition OUT s) v,+ Meta (DataEnumValue s) v+ ) =>+ Meta (TypeContent a c s) v+ where+ get DataObject {objectFields} = get objectFields+ get DataInputObject {inputObjectFields} = get inputObjectFields+ get DataInterface {interfaceFields} = get interfaceFields+ get DataEnum {enumMembers} = concatMap get enumMembers+ get _ = []++instance Meta (DataEnumValue s) Description where+ get DataEnumValue {enumName, enumDescription = Just x} = [(readTypeName enumName, x)]+ get _ = []++instance Meta (DataEnumValue s) (Directives s) where+ get DataEnumValue {enumName, enumDirectives}+ | null enumDirectives = []+ | otherwise = [(readTypeName enumName, enumDirectives)]++instance+ Meta (FieldDefinition c s) v =>+ Meta (FieldsDefinition c s) v+ where+ get = concatMap get . elems++instance Meta (FieldDefinition c s) Description where+ get FieldDefinition {fieldName, fieldDescription = Just x} = [(readName fieldName, x)]+ get _ = []++instance Meta (FieldDefinition c s) (Directives s) where+ get FieldDefinition {fieldName, fieldDirectives}+ | null fieldDirectives = []+ | otherwise = [(readName fieldName, fieldDirectives)]++collectFieldValues ::+ (FieldDefinition IN s -> Maybe a) ->+ (FieldDefinition OUT s -> Maybe a) ->+ TypeDefinition c s ->+ Map FieldName a+collectFieldValues _ g TypeDefinition {typeContent = DataObject {objectFields}} = getFieldValues g objectFields+collectFieldValues f _ TypeDefinition {typeContent = DataInputObject {inputObjectFields}} = getFieldValues f inputObjectFields+collectFieldValues _ g TypeDefinition {typeContent = DataInterface {interfaceFields}} = getFieldValues g interfaceFields+collectFieldValues _ _ _ = empty++getFieldValues :: (FieldDefinition c s -> Maybe a) -> FieldsDefinition c s -> Map FieldName a+getFieldValues f = fromList . notNulls . fmap (getFieldValue f) . elems++notNulls :: [(k, Maybe a)] -> [(k, a)]+notNulls [] = []+notNulls ((_, Nothing) : xs) = notNulls xs+notNulls ((name, Just x) : xs) = (name, x) : notNulls xs++getFieldValue :: (FieldDefinition c s -> Maybe a) -> FieldDefinition c s -> (FieldName, Maybe a)+getFieldValue f field = (fieldName field, f field)++getDefaultValue :: FieldContent TRUE c s -> (Maybe (Value s), Maybe (ArgumentsDefinition s))+getDefaultValue DefaultInputValue {defaultInputValue} = (Just defaultInputValue, Nothing)+getDefaultValue (FieldArgs args) = (Nothing, Just args)
− src/Data/Morpheus/Server/TH/Declare/Introspect.hs
@@ -1,171 +0,0 @@-{-# 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- ( _',- _2',- apply,- applyVars,- cat',- funDSimple,- toCon,- toVarT,- tyConArgs,- )-import Data.Morpheus.Internal.Utils- ( concatUpdates,- )-import Data.Morpheus.Server.Deriving.Introspect- ( DeriveTypeContent (..),- Introspect (..),- ProxyRep (..),- deriveCustomInputObjectType,- )-import Data.Morpheus.Server.Internal.TH.Types- ( ServerTypeDefinition (..),- )-import Data.Morpheus.Server.Internal.TH.Utils- ( mkTypeableConstraints,- )-import Data.Morpheus.Server.Types.GQLType- ( GQLType (__typeName, implements),- TypeUpdater,- )-import Data.Morpheus.Types.Internal.AST- ( ArgumentsDefinition (..),- CONST,- ConsD (..),- FieldContent (..),- FieldDefinition (..),- IN,- LEAF,- OUT,- TRUE,- TypeContent (..),- TypeDefinition (..),- TypeKind (..),- TypeName,- TypeRef (..),- insertType,- unsafeFromFields,- )-import Data.Proxy (Proxy (..))-import Language.Haskell.TH--instanceIntrospect :: Maybe (TypeDefinition cat s) -> Q [Dec]-instanceIntrospect (Just typeDef@TypeDefinition {typeName, typeContent = DataEnum {}}) =- pure <$> instanceD (cxt []) iHead [defineIntrospect]- where- iHead = pure (apply ''Introspect [cat', toCon typeName])- defineIntrospect = funDSimple 'introspect [_'] [|insertType (typeDef :: TypeDefinition LEAF CONST)|]-instanceIntrospect _ = pure []---- [(FieldDefinition, TypeUpdater)]-deriveObjectRep :: ServerTypeDefinition cat s -> Q [Dec]-deriveObjectRep- ServerTypeDefinition- { tName,- tCons = [ConsD {cFields}],- tKind- } =- pure <$> instanceD constrains iHead methods- where- mainTypeName = applyVars tName typeArgs- typeArgs = tyConArgs tKind- constrains = mkTypeableConstraints typeArgs- ------------------------------------------------ iHead = apply ''DeriveTypeContent [instCat, conT ''TRUE, mainTypeName]- instCat- | tKind == KindInputObject =- conT ''IN- | otherwise = conT ''OUT- methods = [funDSimple 'deriveTypeContent [_', _2'] 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 s] ->- [TypeUpdater] ->- ( TypeContent TRUE IN s,- [TypeUpdater]- )-deriveInputObject fields typeUpdates =- (DataInputObject (unsafeFromFields fields), typeUpdates)--deriveOutputObject ::- (GQLType a) =>- Proxy a ->- [FieldDefinition OUT s] ->- [TypeUpdater] ->- ( TypeContent TRUE OUT s,- [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 = concatUpdates . map snd . implements--buildTypes :: TypeQ -> [FieldDefinition cat s] -> ExpQ-buildTypes cat = listE . concatMap (introspectField cat)--introspectField :: TypeQ -> FieldDefinition cat s -> [ExpQ]-introspectField cat FieldDefinition {fieldType, fieldContent} =- [|introspect $(proxyRepT cat fieldType)|] : inputTypes fieldContent- where- inputTypes :: Maybe (FieldContent TRUE cat s) -> [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 (toCon typeConName) (toVarT m)- genSig _ = toCon typeConName--proxyT :: TypeRef -> Q Exp-proxyT TypeRef {typeConName, typeArgs} = [|(Proxy :: Proxy $(genSig typeArgs))|]- where- genSig (Just m) = appT (toCon typeConName) (toVarT m)- genSig _ = toCon typeConName--buildFields :: [FieldDefinition cat s] -> 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
@@ -8,6 +8,7 @@ ) where +import Control.Monad.Reader (asks) import Data.Morpheus.Internal.TH ( declareTypeRef, m',@@ -16,16 +17,20 @@ toName, tyConArgs, )-import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))+import Data.Morpheus.Server.Internal.TH.Types+ ( ServerDec,+ ServerDecContext (..),+ ServerTypeDefinition (..),+ ) import Data.Morpheus.Types.Internal.AST ( ArgumentsDefinition (..), ConsD (..), FieldContent (..), FieldDefinition (..),- FieldName,+ FieldName (..), TRUE, TypeKind (..),- TypeName,+ TypeName (..), isOutput, isOutputObject, isSubscription,@@ -36,22 +41,26 @@ import GHC.Generics (Generic) import Language.Haskell.TH -declareType :: Bool -> ServerTypeDefinition cat s -> [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 . toName)- cons = declareCons namespace tKind (tNamespace, tName) tCons+declareType :: ServerTypeDefinition cat s -> ServerDec [Dec]+declareType ServerTypeDefinition {tKind = KindScalar} = pure []+declareType+ ServerTypeDefinition+ { tName,+ tCons,+ tKind+ } =+ do+ cons <- declareCons tKind tName tCons+ let vars = map (PlainTV . toName) (tyConArgs tKind)+ pure+ [ DataD+ []+ (toName tName)+ vars+ Nothing+ cons+ (derive tKind)+ ] derive :: TypeKind -> [DerivClause] derive tKind = [deriveClasses (''Generic : derivingList)]@@ -63,33 +72,38 @@ deriveClasses :: [Name] -> DerivClause deriveClasses classNames = DerivClause Nothing (map ConT classNames) -mkNamespace :: [FieldName] -> TypeName -> Name-mkNamespace tNamespace = toName . nameSpaceType tNamespace- declareCons ::- Bool -> TypeKind ->- ([FieldName], TypeName) ->+ TypeName -> [ConsD cat s] ->- [Con]-declareCons namespace tKind (tNamespace, tName) = map consR+ ServerDec [Con]+declareCons tKind tName = traverse consR where consR ConsD {cName, cFields} = RecC- (mkNamespace tNamespace cName)- (map (declareField namespace tKind tName) cFields)+ <$> consName tKind tName cName+ <*> traverse (declareField tKind tName) cFields +consName :: TypeKind -> TypeName -> TypeName -> ServerDec Name+consName KindEnum (TypeName name) conName = do+ namespace' <- asks namespace+ if namespace'+ then pure $ toName $ nameSpaceType [FieldName name] conName+ else pure (toName conName)+consName _ _ conName = pure (toName conName)+ declareField ::- Bool -> TypeKind -> TypeName -> FieldDefinition cat s ->- (Name, Bang, Type)-declareField namespace tKind tName field@FieldDefinition {fieldName} =- ( fieldTypeName namespace tName fieldName,- Bang NoSourceUnpackedness NoSourceStrictness,- renderFieldType tKind field- )+ ServerDec (Name, Bang, Type)+declareField tKind tName field@FieldDefinition {fieldName} = do+ namespace' <- asks namespace+ pure+ ( fieldTypeName namespace' tName fieldName,+ Bang NoSourceUnpackedness NoSourceStrictness,+ renderFieldType tKind field+ ) renderFieldType :: TypeKind ->
src/Data/Morpheus/Server/TH/Transform.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.TH.Transform ( toTHDefinitions,@@ -12,6 +13,11 @@ where -- MORPHEUS++import Control.Applicative (pure)+import Control.Monad ((>>=))+import Control.Monad.Fail (fail)+import Data.Functor ((<$>), fmap) import Data.Morpheus.Internal.TH ( infoTyVars, toName,@@ -50,11 +56,22 @@ ) import Data.Semigroup ((<>)) import Language.Haskell.TH+import Prelude+ ( ($),+ Bool (..),+ Maybe (..),+ String,+ concat,+ not,+ null,+ otherwise,+ traverse,+ ) -m_ :: TypeName+m_ :: String m_ = "m" -getTypeArgs :: TypeName -> [TypeDefinition ANY s] -> Q (Maybe TypeName)+getTypeArgs :: TypeName -> [TypeDefinition ANY s] -> Q (Maybe String) getTypeArgs "__TypeKind" _ = pure Nothing getTypeArgs "Boolean" _ = pure Nothing getTypeArgs "String" _ = pure Nothing@@ -64,12 +81,12 @@ Just x -> pure (kindToTyArgs x) Nothing -> getTyArgs <$> reify (toName key) -getTyArgs :: Info -> Maybe TypeName+getTyArgs :: Info -> Maybe String getTyArgs x | null (infoTyVars x) = Nothing | otherwise = Just m_ -kindToTyArgs :: TypeContent TRUE ANY s -> Maybe TypeName+kindToTyArgs :: TypeContent TRUE ANY s -> Maybe String kindToTyArgs DataObject {} = Just m_ kindToTyArgs DataUnion {} = Just m_ kindToTyArgs DataInterface {} = Just m_@@ -102,7 +119,6 @@ InputType ServerTypeDefinition { tName = hsTypeName typeName,- tNamespace = [], tCons, typeArgD = empty, ..@@ -111,7 +127,6 @@ OutputType ServerTypeDefinition { tName = hsTypeName typeName,- tNamespace = [], tCons, .. }@@ -163,7 +178,7 @@ TypeContent TRUE ANY s -> Q (BuildPlan s) genTypeContent _ _ _ DataScalar {} = pure (ConsIN [])-genTypeContent _ _ _ (DataEnum tags) = pure $ ConsIN (map mkConsEnum tags)+genTypeContent _ _ _ (DataEnum tags) = pure $ ConsIN (fmap mkConsEnum tags) genTypeContent _ _ typeName (DataInputObject fields) = pure $ ConsIN (mkObjectCons typeName fields) genTypeContent _ _ _ DataInputUnion {} = fail "Input Unions not Supported"@@ -178,7 +193,7 @@ <$> traverse (mkObjectField schema toArgsTyName) objectFields pure $ ConsOUT typeArgD objCons genTypeContent _ _ typeName (DataUnion members) =- pure $ ConsOUT [] (map unionCon members)+ pure $ ConsOUT [] (fmap unionCon members) where unionCon UnionMember {memberName} = mkCons@@ -211,7 +226,6 @@ pure [ ServerTypeDefinition { tName,- tNamespace = empty, tCons = [mkCons tName (Fields arguments)], tKind = KindInputObject, typeArgD = [],
src/Data/Morpheus/Server/Types/GQLType.hs view
@@ -4,21 +4,24 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Types.GQLType ( GQLType (..),- TypeUpdater,+ GQLTypeOptions (..),+ defaultTypeOptions,+ TypeData (..), ) where -import Data.Map (Map) -- MORPHEUS--import Data.Morpheus.Internal.Utils (UpdateT)+import Data.Map (Map) import Data.Morpheus.Kind+import Data.Morpheus.Server.Types.SchemaT (SchemaT) import Data.Morpheus.Server.Types.Types ( MapKind, Pair,@@ -26,17 +29,21 @@ ) import Data.Morpheus.Types.ID (ID) import Data.Morpheus.Types.Internal.AST- ( CONST,+ ( ArgumentsDefinition,+ CONST, DataFingerprint (..),- FALSE,+ Description,+ Directives,+ FieldName, QUERY,- Schema, TypeName (..),+ TypeWrapper (..),+ Value, internalFingerprint,+ toNullable, ) import Data.Morpheus.Types.Internal.Resolving- ( Eventless,- Resolver,+ ( Resolver, SubscriptionField, ) import Data.Proxy (Proxy (..))@@ -56,9 +63,72 @@ typeRep, typeRepTyCon, )+import Prelude+ ( ($),+ (.),+ Bool (..),+ Eq (..),+ Float,+ Int,+ Maybe (..),+ String,+ concatMap,+ fmap,+ id,+ mempty,+ show,+ ) -type TypeUpdater = UpdateT Eventless (Schema CONST)+data TypeData = TypeData+ { gqlTypeName :: TypeName,+ gqlWrappers :: [TypeWrapper],+ gqlFingerprint :: DataFingerprint+ } +data GQLTypeOptions = GQLTypeOptions+ { fieldLabelModifier :: String -> String,+ constructorTagModifier :: String -> String+ }++defaultTypeOptions :: GQLTypeOptions+defaultTypeOptions =+ GQLTypeOptions+ { fieldLabelModifier = id,+ constructorTagModifier = id+ }++getTypename :: Typeable a => f a -> TypeName+getTypename = TypeName . intercalate "_" . getName+ where+ getName = fmap (fmap (pack . tyConName)) (fmap replacePairCon . ignoreResolver . splitTyConApp . typeRep)++getFingerprint :: Typeable a => f a -> DataFingerprint+getFingerprint = DataFingerprint "Typeable" . fmap show . conFingerprints+ where+ conFingerprints = fmap (fmap tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep)++deriveTypeData :: Typeable a => f a -> TypeData+deriveTypeData proxy =+ TypeData+ { gqlTypeName = getTypename proxy,+ gqlWrappers = [],+ gqlFingerprint = getFingerprint proxy+ }++mkTypeData :: TypeName -> TypeData+mkTypeData name =+ TypeData+ { gqlTypeName = name,+ gqlFingerprint = internalFingerprint name [],+ gqlWrappers = []+ }++list :: [TypeWrapper] -> [TypeWrapper]+list = (TypeList :)++wrapper :: ([TypeWrapper] -> [TypeWrapper]) -> TypeData -> TypeData+wrapper f TypeData {..} = TypeData {gqlWrappers = f gqlWrappers, ..}+ resolverCon :: TyCon resolverCon = typeRepTyCon $ typeRep $ Proxy @(Resolver QUERY () Maybe) @@ -90,137 +160,103 @@ -- instance GQLType ... where -- description = const "your description ..." -- @-class IsObject (a :: GQL_KIND) where- isObject :: Proxy a -> Bool--instance IsObject SCALAR where- isObject _ = False--instance IsObject ENUM where- isObject _ = False--instance IsObject WRAPPER where- isObject _ = False--instance IsObject INPUT where- isObject _ = True--instance IsObject OUTPUT where- isObject _ = True--instance IsObject INTERFACE where- isObject _ = True--class IsObject (KIND a) => GQLType a where+class ToValue (KIND a) => GQLType a where type KIND a :: GQL_KIND type KIND a = OUTPUT - type CUSTOM a :: Bool- type CUSTOM a = FALSE-- implements :: Proxy a -> [(TypeName, TypeUpdater)]+ implements :: f a -> [SchemaT TypeName] implements _ = [] - description :: Proxy a -> Maybe Text+ isObjectKind :: f a -> Bool+ isObjectKind _ = isObject $ toValue (Proxy @(KIND a))++ description :: f a -> Maybe Text description _ = Nothing - isObjectKind :: Proxy a -> Bool- isObjectKind _ = isObject (Proxy @(KIND a))+ getDescriptions :: f a -> Map Text Description+ getDescriptions _ = mempty - __typeName :: Proxy a -> TypeName- default __typeName ::- (Typeable a) =>- Proxy a ->- TypeName- __typeName _ = TypeName $ intercalate "_" (getName $ Proxy @a)- where- getName = fmap (map (pack . tyConName)) (map replacePairCon . ignoreResolver . splitTyConApp . typeRep)+ typeOptions :: f a -> GQLTypeOptions+ typeOptions _ = defaultTypeOptions - __typeFingerprint :: Proxy a -> DataFingerprint- default __typeFingerprint ::- (Typeable a) =>- Proxy a ->- DataFingerprint- __typeFingerprint _ = DataFingerprint "Typeable" $ map show $ conFingerprints (Proxy @a)- where- conFingerprints = fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep)+ getDirectives :: f a -> Map Text (Directives CONST)+ getDirectives _ = mempty -instance GQLType () where- type KIND () = WRAPPER- type CUSTOM () = 'False+ getFieldContents ::+ f a ->+ Map+ FieldName+ ( Maybe (Value CONST),+ Maybe (ArgumentsDefinition CONST)+ )+ getFieldContents _ = mempty -instance Typeable m => GQLType (Undefined m) where- type KIND (Undefined m) = WRAPPER- type CUSTOM (Undefined m) = 'False+ isEmptyType :: f a -> Bool+ isEmptyType _ = False + __type :: f a -> TypeData+ default __type :: Typeable a => f a -> TypeData+ __type _ = deriveTypeData (Proxy @a)+ instance GQLType Int where type KIND Int = SCALAR- __typeFingerprint _ = internalFingerprint "Int" []+ __type _ = mkTypeData "Int" instance GQLType Float where type KIND Float = SCALAR- __typeFingerprint _ = internalFingerprint "Float" []+ __type _ = mkTypeData "Float" instance GQLType Text where type KIND Text = SCALAR- __typeName _ = "String"- __typeFingerprint _ = internalFingerprint "String" []+ __type _ = mkTypeData "String" instance GQLType Bool where type KIND Bool = SCALAR- __typeName _ = "Boolean"- __typeFingerprint _ = internalFingerprint "Boolean" []+ __type _ = mkTypeData "Boolean" +instance GQLType ID where+ type KIND ID = SCALAR+ __type _ = mkTypeData "ID"++-- WRAPPERS+instance GQLType ()++instance Typeable m => GQLType (Undefined m) where+ type KIND (Undefined m) = WRAPPER+ isEmptyType _ = True+ instance GQLType a => GQLType (Maybe a) where type KIND (Maybe a) = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)+ __type _ = wrapper toNullable $ __type $ Proxy @a instance GQLType a => GQLType [a] where type KIND [a] = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)+ __type _ = wrapper list $ __type $ Proxy @a instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where type KIND (a, b) = WRAPPER- __typeName _ = __typeName $ Proxy @(Pair a b)+ __type _ = __type $ Proxy @(Pair a b) instance GQLType a => GQLType (Set a) where type KIND (Set a) = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)--instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where- type KIND (Pair a b) = OUTPUT--instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where- type KIND (MapKind a b m) = OUTPUT- __typeName _ = __typeName (Proxy @(Map a b))- __typeFingerprint _ = __typeFingerprint (Proxy @(Map a b))+ __type _ = __type $ Proxy @[a] instance (Typeable k, Typeable v) => GQLType (Map k v) where type KIND (Map k v) = WRAPPER -instance GQLType a => GQLType (Either s a) where- type KIND (Either s a) = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)- instance GQLType a => GQLType (Resolver o e m a) where type KIND (Resolver o e m a) = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)+ __type _ = __type $ Proxy @a instance GQLType a => GQLType (SubscriptionField a) where type KIND (SubscriptionField a) = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)+ __type _ = __type $ Proxy @a instance GQLType b => GQLType (a -> b) where type KIND (a -> b) = WRAPPER- __typeName _ = __typeName (Proxy @b)- __typeFingerprint _ = __typeFingerprint (Proxy @b)+ __type _ = __type $ Proxy @b -instance GQLType ID where- type KIND ID = SCALAR- __typeFingerprint _ = internalFingerprint "ID" []+instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b)++instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where+ __type _ = __type $ Proxy @(Map a b)
+ src/Data/Morpheus/Server/Types/SchemaT.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Types.SchemaT+ ( SchemaT,+ closeWith,+ updateSchema,+ insertType,+ setMutation,+ setSubscription,+ )+where++import Control.Applicative (Applicative (..))+import Control.Monad (Monad (..), foldM)+import Data.Function ((&))+import Data.Functor (Functor (..))+import Data.Morpheus.Error (nameCollisionError)+import Data.Morpheus.Internal.Utils+ ( Failure (..),+ )+import Data.Morpheus.Types.Internal.AST+ ( CONST,+ DataFingerprint,+ OBJECT,+ Schema (..),+ TypeContent (..),+ TypeDefinition (..),+ TypeName (..),+ isNotSystemTypeName,+ isTypeDefined,+ safeDefineType,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Eventless,+ )+import Data.Semigroup (Semigroup (..))+import Prelude+ ( ($),+ (.),+ Eq (..),+ Maybe (..),+ const,+ null,+ otherwise,+ uncurry,+ )++-- Helper Functions+newtype SchemaT a = SchemaT+ { runSchemaT ::+ Eventless+ ( a,+ [Schema CONST -> Eventless (Schema CONST)]+ )+ }+ deriving (Functor)++instance+ Failure err Eventless =>+ Failure err SchemaT+ where+ failure = SchemaT . failure++instance Applicative SchemaT where+ pure = SchemaT . pure . (,[])+ (SchemaT v1) <*> (SchemaT v2) =+ SchemaT $ do+ (f, u1) <- v1+ (a, u2) <- v2+ pure (f a, u1 <> u2)++instance Monad SchemaT where+ return = pure+ (SchemaT v1) >>= f =+ SchemaT $ do+ (x, up1) <- v1+ (y, up2) <- runSchemaT (f x)+ pure (y, up1 <> up2)++closeWith :: SchemaT (Schema CONST) -> Eventless (Schema CONST)+closeWith (SchemaT v) = v >>= uncurry execUpdates++init :: (Schema CONST -> Eventless (Schema CONST)) -> SchemaT ()+init f = SchemaT $ pure ((), [f])++setMutation :: TypeDefinition OBJECT CONST -> SchemaT ()+setMutation mut = init (\schema -> pure $ schema {mutation = optionalType mut})++setSubscription :: TypeDefinition OBJECT CONST -> SchemaT ()+setSubscription x = init (\schema -> pure $ schema {subscription = optionalType x})++optionalType :: TypeDefinition OBJECT CONST -> Maybe (TypeDefinition OBJECT CONST)+optionalType td@TypeDefinition {typeContent = DataObject {objectFields}}+ | null objectFields = Nothing+ | otherwise = Just td++execUpdates :: Monad m => a -> [a -> m a] -> m a+execUpdates = foldM (&)++insertType ::+ TypeDefinition cat CONST ->+ SchemaT ()+insertType dt@TypeDefinition {typeName, typeFingerprint} =+ updateSchema typeName typeFingerprint (const $ pure dt) ()++updateSchema ::+ TypeName ->+ DataFingerprint ->+ (a -> SchemaT (TypeDefinition cat CONST)) ->+ a ->+ SchemaT ()+updateSchema typeName typeFingerprint f x+ | isNotSystemTypeName typeName = SchemaT (pure ((), [upLib]))+ | otherwise = SchemaT (pure ((), []))+ where+ upLib :: Schema CONST -> Eventless (Schema CONST)+ upLib lib = case isTypeDefined typeName lib of+ Nothing -> do+ (tyDef, updater) <- runSchemaT (f x)+ execUpdates lib (safeDefineType tyDef : updater)+ Just fingerprint'+ | fingerprint' == typeFingerprint -> pure lib+ -- throw error if 2 different types has same name+ | otherwise -> failure [nameCollisionError typeName]
src/Data/Morpheus/Server/Types/Types.hs view
@@ -1,16 +1,26 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Types.Types ( Undefined (..), Pair (..), MapKind (..),- MapArgs (..), mapKindFromList, ) where -import GHC.Generics (Generic)+import Data.Functor (fmap)+import GHC.Generics+ ( Generic,+ )+import Prelude+ ( Applicative (..),+ Int,+ Show,+ length,+ uncurry,+ ) data Undefined (m :: * -> *) = Undefined deriving (Show, Generic) @@ -20,26 +30,17 @@ } deriving (Generic) -newtype MapArgs k = MapArgs- { oneOf :: Maybe [k]- }- deriving (Generic)- data MapKind k v m = MapKind { size :: Int,- pairs :: MapArgs k -> m [Pair k v]+ pairs :: m [Pair k v] } deriving (Generic) -mapKindFromList :: (Eq k, Applicative m) => [(k, v)] -> MapKind k v m+mapKindFromList :: (Applicative m) => [(k, v)] -> MapKind k v m mapKindFromList inputPairs = MapKind { size = length inputPairs, pairs = resolvePairs } where- filterBy MapArgs {oneOf = Just list} =- filter ((`elem` list) . fst) inputPairs- filterBy _ = inputPairs- resolvePairs = pure . (map toGQLTuple . filterBy)- toGQLTuple (x, y) = Pair x y+ resolvePairs = pure (fmap (uncurry Pair) inputPairs)
src/Data/Morpheus/Types.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | GQL Types module Data.Morpheus.Types@@ -33,7 +34,6 @@ unsafeInternalContext, ResolverContext (..), Input,- Stream, WS, HTTP, -- Resolvers@@ -54,19 +54,33 @@ IOSubRes, interface, SubscriptionField,+ App,+ RenderGQL (..),+ GQLTypeOptions (..), ) where +import Control.Applicative (pure)+import Control.Monad (Monad ((>>=)))+import Control.Monad.Fail (fail) import Control.Monad.Trans.Class (MonadTrans (..))-import Data.Either (either)--- MORPHEUS--import Data.Morpheus.Server.Deriving.Introspect- ( Introspect (..),- TypeUpdater,- introspectOUT,+import Data.Either+ ( Either (..),+ either, )-import Data.Morpheus.Server.Types.GQLType (GQLType (..))+import Data.Morpheus.Core+ ( App,+ RenderGQL (..),+ )+import Data.Morpheus.Server.Deriving.Schema+ ( DeriveType,+ SchemaT,+ deriveImplementsInterface,+ )+import Data.Morpheus.Server.Types.GQLType+ ( GQLType (..),+ GQLTypeOptions (..),+ ) import Data.Morpheus.Server.Types.Types (Undefined (..)) import Data.Morpheus.Types.GQLScalar ( GQLScalar@@ -105,10 +119,18 @@ import Data.Morpheus.Types.Internal.Subscription ( HTTP, Input,- Stream, WS, )-import Data.Proxy (Proxy (..))+import Data.Proxy+ ( Proxy (..),+ )+import Prelude+ ( ($),+ (.),+ IO,+ String,+ const,+ ) class FlexibleResolver (f :: * -> *) (a :: k) where type Flexible (m :: * -> *) a :: *@@ -206,5 +228,5 @@ subscriptionResolver :: sub (Resolver SUBSCRIPTION event m) } -interface :: (GQLType a, Introspect OUT a) => Proxy a -> (TypeName, TypeUpdater)-interface x = (__typeName x, introspectOUT x)+interface :: (GQLType a, DeriveType OUT a) => Proxy a -> SchemaT TypeName+interface = deriveImplementsInterface
src/Data/Morpheus/Types/Internal/Subscription.hs view
@@ -12,10 +12,8 @@ ( connect, disconnect, connectionThread,- toOutStream, runStreamWS, runStreamHTTP,- Stream, Scope (..), Input (..), WS,@@ -30,6 +28,7 @@ toList, connectionSessionIds, SessionID,+ streamApp, ) where @@ -47,6 +46,10 @@ ) -- MORPHEUS +import Data.Morpheus.Core+ ( App,+ runAppStream,+ ) import Data.Morpheus.Internal.Utils ( empty, )@@ -76,6 +79,9 @@ ) import Data.UUID.V4 (nextRandom) +streamApp :: Monad m => App e m -> Input api -> Stream api e m+streamApp app = toOutStream (runAppStream app)+ connect :: MonadIO m => m (Input WS) connect = Init <$> liftIO nextRandom @@ -120,7 +126,7 @@ connectionThread :: ( MonadUnliftIO m ) =>- (Input WS -> Stream WS e m) ->+ App e m -> Scope WS e m -> m () connectionThread api scope = do@@ -131,11 +137,11 @@ connectionLoop :: Monad m =>- (Input WS -> Stream WS e m) ->+ App e m -> Scope WS e m -> Input WS -> m ()-connectionLoop api scope input =+connectionLoop app scope input = forever $ runStreamWS scope- $ api input+ $ streamApp app input
src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Types.Internal.Subscription.Apollo ( ApolloAction (..),@@ -12,6 +13,7 @@ ) where +import Control.Applicative (Applicative (..)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Aeson ( (.:),@@ -29,8 +31,15 @@ ( ByteString, pack, )-import Data.Maybe (maybe)--- MORPHEUS+import Data.Either+ ( Either (..),+ either,+ )+import Data.Functor ((<$>))+import Data.Maybe+ ( Maybe (..),+ maybe,+ ) import Data.Morpheus.Types.IO ( GQLRequest (..), GQLResponse,@@ -53,6 +62,12 @@ acceptRequestWith, getRequestSubprotocols, pendingRequest,+ )+import Prelude+ ( ($),+ (.),+ Show,+ String, ) type ID = Text
src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore ( ID,@@ -21,6 +22,8 @@ ) where +import Control.Applicative (pure)+import Control.Monad (Monad ((>>=))) import Data.ByteString.Lazy.Char8 (ByteString) import Data.Foldable (traverse_) import Data.HashMap.Lazy (HashMap, keys)@@ -34,9 +37,7 @@ keys, toList, )-import Data.List (intersect)--- MORPHEUS-+import Data.List (filter, intersect) import Data.Morpheus.Internal.Utils ( Collection (..), KeyOf (..),@@ -52,6 +53,16 @@ import Data.Semigroup ((<>)) import Data.Text (Text) import Data.UUID (UUID)+import Prelude+ ( (.),+ Eq (..),+ Show (..),+ curry,+ not,+ null,+ otherwise,+ snd,+ ) type ID = UUID @@ -62,7 +73,7 @@ data ClientConnection e (m :: * -> *) = ClientConnection { connectionId :: ID, connectionCallback :: ByteString -> m (),- -- one connection can have multiple subsciprion session+ -- one connection can have multiple subscription session connectionSessions :: HashMap SessionID (SubEvent e m) } @@ -125,7 +136,7 @@ -- stores active client connections -- every registered client has ID--- when client connection is closed client(including all its subsciprions) can By removed By its ID+-- when client connection is closed client(including all its subscriptions) can By removed By its ID newtype ClientConnectionStore e (m :: * -> *) = ClientConnectionStore { unpackStore :: HashMap ID (ClientConnection e m) }
src/Data/Morpheus/Types/Internal/Subscription/Stream.hs view
@@ -176,13 +176,13 @@ ) -> Input api -> Stream api e m-toOutStream app (Init clienId) =+toOutStream app (Init clientId) = StreamWS handle where handle ws@ScopeWS {listener, callback} = do let runS (StreamWS x) = x ws- bla <- listener >>= runS . handleWSRequest app clienId- pure $ (Updates (insert clienId callback) :) <$> bla+ bla <- listener >>= runS . handleWSRequest app clientId+ pure $ (Updates (insert clientId callback) :) <$> bla toOutStream app (Request req) = StreamHTTP $ handleResponseHTTP (app req) handleResponseHTTP ::
test/Feature/Holistic/API.hs view
@@ -9,15 +9,19 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-} module Feature.Holistic.API ( api,- rootResolver, ) where -import Data.Morpheus (interpreter)-import Data.Morpheus.Document (importGQLDocument)+import Control.Monad.Fail (fail)+import Data.Morpheus (deriveApp, runApp)+import Data.Morpheus.Document+ ( importGQLDocument,+ importGQLDocumentWithNamespace,+ ) import Data.Morpheus.Kind (SCALAR) import Data.Morpheus.Types ( Event,@@ -28,11 +32,30 @@ ID (..), RootResolver (..), ScalarValue (..),+ Undefined (..), liftEither, subscribe, )+import Data.Semigroup ((<>)) import Data.Text (Text) import GHC.Generics (Generic)+import Prelude+ ( ($),+ (*),+ (+),+ (.),+ (<$>),+ Applicative (..),+ Either (..),+ Eq (..),+ IO,+ Int,+ Maybe (..),+ Show (..),+ String,+ const,+ id,+ ) data TestScalar = TestScalar@@ -53,50 +76,81 @@ type EVENT = Event Channel () -importGQLDocument "test/Feature/Holistic/schema.gql"+importGQLDocumentWithNamespace "test/Feature/Holistic/schema.gql" +importGQLDocument "test/Feature/Holistic/schema-ext.gql"+ alwaysFail :: IO (Either String a) alwaysFail = pure $ Left "fail with Either" -rootResolver :: RootResolver IO EVENT Query Mutation Subscription-rootResolver =+root :: RootResolver IO EVENT Query Mutation Subscription+root = RootResolver { queryResolver = Query- { user,- testUnion = Just . TestUnionUser <$> user,- fail1 = liftEither alwaysFail,- fail2 = fail "fail with MonadFail",- person = pure Person {name = pure (Just "test Person Name")},- type' = \TypeArgs {in' = TypeInput {data'}} -> pure data'+ { queryUser,+ queryTestUnion = Just . TestUnionUser <$> queryUser,+ queryPerson =+ pure+ Person+ { personName = pure (Just "test Person Name")+ },+ queryTestEnum =+ \QueryTestEnumArgs+ { queryTestEnumArgsEnum+ } ->+ pure+ [ queryTestEnumArgsEnum,+ CollidingEnumEnumA+ ] },- mutationResolver = Mutation {createUser = const user},+ mutationResolver =+ Mutation+ { mutationCreateUser = const queryUser+ }, subscriptionResolver = Subscription- { newUser = subscribe Channel (pure $ const user),- newAddress = subscribe Channel (pure resolveAddress)+ { subscriptionNewUser = subscribe Channel (pure $ const queryUser),+ subscriptionNewAddress = subscribe Channel (pure resolveAddress) } } where- user :: Applicative m => m (User m)- user =+ queryUser :: Applicative m => m (User m)+ queryUser = pure User- { name = pure "testName",- email = pure "",- address = resolveAddress,- office = resolveAddress,- friend = pure Nothing+ { userName = pure "testName",+ userEmail = pure "",+ userAddress = resolveAddress,+ userOffice = resolveAddress,+ userFriend = pure Nothing } ----------------------------------------------------- resolveAddress :: Applicative m => a -> m (Address m) resolveAddress _ = pure Address- { city = pure "",- houseNumber = pure 0,- street = const $ pure Nothing+ { addressCity = pure "",+ addressHouseNumber = pure 0,+ addressStreet = const $ pure Nothing } +rootExt :: RootResolver IO EVENT ExtQuery Undefined Undefined+rootExt =+ RootResolver+ { queryResolver =+ ExtQuery+ { fail1 = liftEither alwaysFail,+ fail2 = fail "fail with MonadFail",+ type' = \TypeArgs {in' = TypeInput {data'}} -> pure data'+ },+ mutationResolver = Undefined,+ subscriptionResolver = Undefined+ }+ api :: GQLRequest -> IO GQLResponse-api = interpreter rootResolver+api =+ runApp+ ( deriveApp root+ <> deriveApp rootExt+ )
test/Feature/Holistic/arguments/nameConflict/response.json view
@@ -5,6 +5,15 @@ "locations": [ { "line": 3,+ "column": 13+ }+ ]+ },+ {+ "message": "There can Be only One Argument Named \"comment\"",+ "locations": [+ {+ "line": 3, "column": 26 } ]
test/Feature/Holistic/cases.json view
@@ -5,7 +5,7 @@ }, { "path": "arguments/unknownArguments",- "description": "fail when: argument on field is not recognised by the schema"+ "description": "fail when: argument on field is not recognized by the schema" }, { "path": "arguments/nameConflict",@@ -73,11 +73,11 @@ }, { "path": "fragment/conditionTypeViolation",- "description": "fail when: condtion type is not an Object"+ "description": "fail when: condition type is not an Object" }, { "path": "fragment/unknownConditionType",- "description": "fail when: condtion type is not defined by schema"+ "description": "fail when: condition type is not defined by schema" }, { "path": "parsing/duplicatedFields",@@ -225,7 +225,7 @@ }, { "path": "parsing/numbers",- "description": "parse signed numbers and numbers with expotential"+ "description": "parse signed numbers and numbers with exponential" }, { "path": "introspection/description/object",@@ -289,7 +289,7 @@ }, { "path": "selection/directives/default/withVariable",- "description": "api allowes use of variable inside directives"+ "description": "api allows use of variable inside directives" }, { "path": "selection/directives/default/withMerge",@@ -326,5 +326,13 @@ { "path": "reservedNames", "description": "morpheus should handle reserved names"+ },+ {+ "path": "namespace/enum",+ "description": "check if deriving stripes enum namespaces"+ },+ {+ "path": "namespace/enum-fail-on-fullname",+ "description": "must accept only striped enums" } ]
test/Feature/Holistic/fragment/nameCollision/response.json view
@@ -4,6 +4,15 @@ "message": "There can be only one fragment named \"F\".", "locations": [ {+ "line": 8,+ "column": 10+ }+ ]+ },+ {+ "message": "There can be only one fragment named \"F\".",+ "locations": [+ { "line": 12, "column": 10 }
+ test/Feature/Holistic/namespace/enum-fail-on-fullname/query.gql view
@@ -0,0 +1,3 @@+query {+ testEnum(enum: CollidingEnumEnumB)+}
+ test/Feature/Holistic/namespace/enum-fail-on-fullname/response.json view
@@ -0,0 +1,13 @@+{+ "errors": [+ {+ "message": "Argument \"enum\" got invalid value. Expected type \"CollidingEnum!\" found CollidingEnumEnumB.",+ "locations": [+ {+ "line": 2,+ "column": 12+ }+ ]+ }+ ]+}
+ test/Feature/Holistic/namespace/enum/query.gql view
@@ -0,0 +1,77 @@+query {+ testEnum(enum: EnumB)+ __type(name: "CollidingEnum") {+ ...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/Holistic/namespace/enum/response.json view
@@ -0,0 +1,22 @@+{+ "data": {+ "testEnum": ["EnumB", "EnumA"],+ "__type": {+ "kind": "ENUM",+ "name": "CollidingEnum",+ "fields": null,+ "inputFields": null,+ "interfaces": null,+ "enumValues": [+ { "name": "EnumA", "isDeprecated": false, "deprecationReason": null },+ {+ "name": "EnumB",+ "isDeprecated": true,+ "deprecationReason": "test deprecation enumValue"+ },+ { "name": "EnumC", "isDeprecated": true, "deprecationReason": null }+ ],+ "possibleTypes": null+ }+ }+}
test/Feature/Holistic/reservedNames/response.json view
@@ -5,9 +5,10 @@ "fields": [ { "name": "user", "args": [] }, { "name": "testUnion", "args": [] },+ { "name": "person", "args": [] },+ { "name": "testEnum", "args": [{ "name": "enum" }] }, { "name": "fail1", "args": [] }, { "name": "fail2", "args": [] },- { "name": "person", "args": [] }, { "name": "type", "args": [{ "name": "in" }] } ] },
+ test/Feature/Holistic/schema-ext.gql view
@@ -0,0 +1,9 @@+type ExtQuery {+ fail1: String!+ fail2: Int!+ type(in: TypeInput!): String!+}++input TypeInput {+ data: String!+}
test/Feature/Holistic/schema.gql view
@@ -15,6 +15,18 @@ EnumC @deprecated } +enum CollidingEnum {+ """+ enumValue Description: EnumA+ """+ EnumA+ EnumB @deprecated(reason: "test deprecation enumValue")+ """+ enumValue Description: EnumC+ """+ EnumC @deprecated+}+ input NestedInputObject { fieldTestID: ID! }@@ -93,17 +105,11 @@ friend: User } -input TypeInput {- data: String!-}- type Query { user: User! testUnion: TestUnion- fail1: String!- fail2: Int! person: Person!- type(in: TypeInput!): String!+ testEnum(enum: CollidingEnum!): [CollidingEnum!]! } type Mutation {
test/Feature/Holistic/selection/mergeConflict/union/response.json view
@@ -7,6 +7,15 @@ { "line": 4, "column": 7 }, { "line": 14, "column": 7 } ]+ },+ {+ "message": "Fields \"testUnion\" conflict because subfields \"address\" conflict because \"houseNumber\" and \"city\" are different fields. Use different aliases on the fields to fetch both if this was intentional.",+ "locations": [+ { "line": 2, "column": 3 },+ { "line": 6, "column": 7 },+ { "line": 7, "column": 9 },+ { "line": 16, "column": 9 }+ ] } ] }
test/Feature/Input/Enum/API.hs view
@@ -38,7 +38,7 @@ newtype TestArgs a = TestArgs { level :: a }- deriving (Generic, Show)+ deriving (Generic, Show, GQLType) instance GQLType Level where type KIND Level = ENUM
test/Feature/Input/Object/API.hs view
@@ -37,7 +37,7 @@ newtype Arg a = Arg { value :: a }- deriving (Generic, Show)+ deriving (Generic, Show, GQLType) -- query testRes :: Show a => Applicative m => Arg a -> m Text
test/Feature/Input/Scalar/API.hs view
@@ -23,7 +23,7 @@ newtype Arg a = Arg { value :: a }- deriving (Generic, Show)+ deriving (Generic, Show, GQLType) -- query testRes :: Applicative m => Arg a -> m a
test/Feature/InputType/variables/nameCollision/response.json view
@@ -5,6 +5,15 @@ "locations": [ { "line": 1,+ "column": 29+ }+ ]+ },+ {+ "message": "There can Be only One Variable Named \"v1\"",+ "locations": [+ {+ "line": 1, "column": 43 } ]
test/Feature/TypeInference/API.hs view
@@ -74,7 +74,7 @@ newtype MonsterArgs = MonsterArgs { monster :: Monster }- deriving (Generic)+ deriving (Show, Generic, GQLType) data Query (m :: * -> *) = Query { deity :: Deity m,
test/Rendering/Schema.hs view
@@ -41,5 +41,5 @@ path :: String path = "test/Rendering/schema.gql" -proxy :: Proxy (RootResolver IO () Query Undefined Undefined)-proxy = Proxy @(RootResolver IO () Query Undefined Undefined)+proxy :: Proxy (RootResolver IO () MyQuery MyMutation Undefined)+proxy = Proxy @(RootResolver IO () MyQuery MyMutation Undefined)
test/Rendering/schema.gql view
@@ -23,7 +23,16 @@ scalar TestScalar -type Query {+type MyQuery { user: User! testUnion: TestUnion+}++type MyMutation {+ newUser: User!+}++schema {+ query: MyQuery+ mutation: MyMutation }
test/Subscription/API.hs view
@@ -10,15 +10,19 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Subscription.API (api, EVENT, Channel (..), Info (..)) where+module Subscription.API+ ( app,+ EVENT,+ Channel (..),+ Info (..),+ )+where -import Data.Morpheus (interpreter)+import Data.Morpheus (App, deriveApp) import Data.Morpheus.Document (importGQLDocument) import Data.Morpheus.Types ( Event (..),- Input, RootResolver (..),- Stream, subscribe, ) import Data.Text (Text)@@ -49,8 +53,8 @@ age = pure age } -rootResolver :: RootResolver (SubM EVENT) EVENT Query Mutation Subscription-rootResolver =+root :: RootResolver (SubM EVENT) EVENT Query Mutation Subscription+root = RootResolver { queryResolver = Query@@ -68,5 +72,5 @@ } } -api :: Input api -> Stream api EVENT (SubM EVENT)-api = interpreter rootResolver+app :: App EVENT (SubM EVENT)+app = deriveApp root
test/Subscription/Case/ApolloRequest.hs view
@@ -9,14 +9,11 @@ where import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Function ((&))+import Data.Morpheus (App) import Data.Morpheus.Types ( Event,- Input,- Stream, )-import Data.Morpheus.Types.Internal.Subscription- ( WS,- ) import Subscription.Utils ( SimulationState (..), SubM,@@ -36,9 +33,11 @@ testGroup, ) +type WSApp ch a = App (Event ch a) (SubM (Event ch a))+ testUnknownType :: (Eq ch) =>- (Input WS -> Stream WS (Event ch a) (SubM (Event ch a))) ->+ App (Event ch a) (SubM (Event ch a)) -> IO TestTree testUnknownType = testSimulation@@ -57,7 +56,7 @@ testConnectionInit :: (Eq ch) =>- (Input WS -> Stream WS (Event ch a) (SubM (Event ch a))) ->+ App (Event ch a) (SubM (Event ch a)) -> IO TestTree testConnectionInit = testSimulation test [apolloInit] where@@ -75,10 +74,7 @@ startSub :: ByteString -> ByteString startSub = apolloStart "subscription MySubscription { newDeity { name }}" -testSubscriptionStart ::- (Eq ch) =>- (Input WS -> Stream WS (Event ch a) (SubM (Event ch a))) ->- IO TestTree+testSubscriptionStart :: (Eq ch) => WSApp ch a -> IO TestTree testSubscriptionStart = testSimulation test@@ -100,10 +96,7 @@ store ] -testSubscriptionStop ::- (Eq ch) =>- (Input WS -> Stream WS (Event ch a) (SubM (Event ch a))) ->- IO TestTree+testSubscriptionStop :: (Eq ch) => WSApp ch a -> IO TestTree testSubscriptionStop = testSimulation test@@ -128,11 +121,14 @@ testApolloRequest :: (Eq ch) =>- (Input WS -> Stream WS (Event ch a) (SubM (Event ch a))) ->+ App (Event ch a) (SubM (Event ch a)) -> IO TestTree-testApolloRequest api = do- unknownType <- testUnknownType api- connection_init <- testConnectionInit api- start <- testSubscriptionStart api- stop <- testSubscriptionStop api- return $ testGroup "ApolloRequest" [unknownType, connection_init, start, stop]+testApolloRequest app =+ testGroup "ApolloRequest"+ <$> traverse+ (app &)+ [ testUnknownType,+ testConnectionInit,+ testSubscriptionStart,+ testSubscriptionStop+ ]
test/Subscription/Case/Publishing.hs view
@@ -23,7 +23,7 @@ ( Channel (..), EVENT, Info (..),- api,+ app, ) import Subscription.Utils ( SimulationState (..),@@ -53,7 +53,7 @@ input <- connect state <- simulate- api+ app input ( SimulationState [ apolloInit,
test/Subscription/Test.hs view
@@ -9,6 +9,6 @@ testSubsriptions :: IO TestTree testSubsriptions = do- subscription <- testApolloRequest TS.api+ subscription <- testApolloRequest TS.app publishing <- testPublishing return $ testGroup "Subscription" [subscription, publishing]
test/Subscription/Utils.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-} module Subscription.Utils ( SimulationState (..),@@ -22,6 +23,7 @@ ) where +import Control.Monad ((>>=)) import Control.Monad.State.Lazy ( StateT, runStateT,@@ -36,10 +38,11 @@ import Data.Maybe ( isJust, )+import Data.Morpheus+ ( App,+ ) import Data.Morpheus.Types ( Event,- Input,- Stream, ) import Data.Morpheus.Types.Internal.Subscription ( ClientConnectionStore,@@ -52,6 +55,7 @@ empty, publish, runStreamWS,+ streamApp, toList, ) import Data.Semigroup@@ -65,6 +69,21 @@ assertFailure, testCase, )+import Prelude+ ( ($),+ (.),+ (<$>),+ Eq (..),+ IO,+ Maybe (..),+ Show (..),+ length,+ lookup,+ null,+ otherwise,+ pure,+ snd,+ ) data SimulationState e = SimulationState { inputs :: [ByteString],@@ -87,17 +106,17 @@ readInput (SimulationState [] o s) = ("<Error>", SimulationState [] o s) wsApp ::- (Input WS -> Stream WS e (SubM e)) ->+ App e (SubM e) -> Input WS -> SubM e ()-wsApp api input =+wsApp app = runStreamWS ScopeWS { update = state . updateStore, listener = state readInput, callback = state . addOutput }- (api input)+ . streamApp app simulatePublish :: Eq ch =>@@ -107,7 +126,7 @@ simulatePublish event s = snd <$> runStateT (publish event (store s)) s simulate ::- (Input WS -> Stream WS e (SubM e)) ->+ App e (SubM e) -> Input WS -> SimulationState e -> IO (SimulationState e)@@ -117,7 +136,7 @@ testSimulation :: (Input WS -> SimulationState e -> TestTree) -> [ByteString] ->- (Input WS -> Stream WS e (SubM e)) ->+ App e (SubM e) -> IO TestTree testSimulation test simInputs api = do input <- connect@@ -126,7 +145,7 @@ expectedResponse :: [ByteString] -> [ByteString] -> IO () expectedResponse expected value- | expected == value = return ()+ | expected == value = pure () | otherwise = assertFailure $ "expected: \n " <> show expected <> " \n but got: \n " <> show value @@ -147,7 +166,7 @@ storeIsEmpty :: Store e -> TestTree storeIsEmpty cStore | null (toList cStore) =- testCase "connectionStore: is empty" $ return ()+ testCase "connectionStore: is empty" $ pure () | otherwise = testCase "connectionStore: is empty" $ assertFailure@@ -158,7 +177,7 @@ storedSingle :: Store e -> TestTree storedSingle cStore | length (toList cStore) == 1 =- testCase "stored single connection" $ return ()+ testCase "stored single connection" $ pure () | otherwise = testCase "stored single connection" $ assertFailure@@ -169,7 +188,7 @@ stored :: Input WS -> Store e -> TestTree stored (Init uuid) cStore | isJust (lookup uuid (toList cStore)) =- testCase "stored connection" $ return ()+ testCase "stored connection" $ pure () | otherwise = testCase "stored connection" $ assertFailure@@ -190,7 +209,7 @@ where checkSession (Just conn) | sort sids == sort (connectionSessionIds conn) =- testCase "stored subscriptions" $ return ()+ testCase "stored subscriptions" $ pure () | otherwise = testCase "stored subscriptions" $ assertFailure
test/TestFeature.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-} module TestFeature ( testFeature,@@ -22,6 +23,15 @@ Name, testWith, )+import Prelude+ ( ($),+ (<$>),+ Eq (..),+ IO,+ Maybe (..),+ otherwise,+ pure,+ ) packGQLRequest :: ByteString -> Maybe Value -> GQLRequest packGQLRequest queryBS variables =@@ -42,9 +52,8 @@ actualResponse <- encode <$> testApi (packGQLRequest testCaseQuery testCaseVariables) case decode actualResponse of Nothing -> assertFailure "Bad Response"- Just response -> return $ testCase (unpack path ++ " | " ++ description) $ customTest expectedResponse response+ Just response -> pure $ testCase (unpack path <> " | " <> description) $ customTest expectedResponse response where customTest expected value- | expected == value = return ()- | otherwise =- assertFailure $ LB.unpack $ "expected: \n " <> encode expected <> " \n but got: \n " <> actualResponse+ | expected == value = pure ()+ | otherwise = assertFailure $ LB.unpack $ "expected: \n " <> encode expected <> " \n but got: \n " <> actualResponse