morpheus-graphql 0.13.0 → 0.14.0

raw patch · 74 files changed

+1393/−886 lines, 74 filesdep ~morpheus-graphql-core

Dependency ranges changed: morpheus-graphql-core

Files

• README.md +37/−30
• changelog.md +117/−30
• morpheus-graphql.cabal +22/−8
• src/Data/Morpheus/Document.hs +5/−4
• src/Data/Morpheus/Kind.hs +0/−1
• src/Data/Morpheus/Server.hs +24/−21
• src/Data/Morpheus/Server/Deriving/Channels.hs +134/−0
• src/Data/Morpheus/Server/Deriving/Decode.hs +24/−28
• src/Data/Morpheus/Server/Deriving/Encode.hs +31/−26
• src/Data/Morpheus/Server/Deriving/Interpreter.hs +18/−11
• src/Data/Morpheus/Server/Deriving/Introspect.hs +182/−82
• src/Data/Morpheus/Server/Deriving/Resolve.hs +29/−115
• src/Data/Morpheus/Server/Deriving/Utils.hs +3/−4
• src/Data/Morpheus/Server/Internal/TH/Decode.hs +68/−56
• src/Data/Morpheus/Server/Internal/TH/Types.hs +4/−4
• src/Data/Morpheus/Server/Internal/TH/Utils.hs +71/−0
• src/Data/Morpheus/Server/Playground.hs +66/−0
• src/Data/Morpheus/Server/TH/Declare.hs +9/−6
• src/Data/Morpheus/Server/TH/Declare/Channels.hs +79/−0
• src/Data/Morpheus/Server/TH/Declare/Decode.hs +25/−16
• src/Data/Morpheus/Server/TH/Declare/Encode.hs +67/−91
• src/Data/Morpheus/Server/TH/Declare/GQLType.hs +17/−37
• src/Data/Morpheus/Server/TH/Declare/Introspect.hs +43/−43
• src/Data/Morpheus/Server/TH/Declare/Type.hs +43/−24
• src/Data/Morpheus/Server/TH/Transform.hs +26/−19
• src/Data/Morpheus/Server/Types/GQLType.hs +16/−9
• src/Data/Morpheus/Types.hs +11/−15
• src/Data/Morpheus/Types/Internal/Subscription.hs +5/−11
• src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs +8/−10
• src/Data/Morpheus/Types/Internal/Subscription/Stream.hs +6/−21
• test/Feature/Holistic/API.hs +2/−2
• test/Feature/Holistic/fragment/cannotBeSpreadOnType/query.gql +1/−1
• test/Feature/Holistic/fragment/cannotBeSpreadOnType/response.json +6/−7
• test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json +2/−7
• test/Feature/Holistic/parsing/complex/response.json +3/−23
• test/Feature/Holistic/parsing/directive/notOnArgument/response.json +1/−1
• test/Feature/Holistic/parsing/directive/notOnVariable/response.json +2/−7
• test/Feature/Holistic/parsing/invalidFields/response.json +1/−1
• test/Feature/Holistic/parsing/invalidNotNullOperator/response.json +2/−7
• test/Feature/Holistic/parsing/missingCloseBrace/response.json +1/−1
• test/Feature/Input/Enum/API.hs +0/−1
• test/Feature/Input/Object/API.hs +0/−1
• test/Feature/Input/Scalar/API.hs +9/−3
• test/Feature/Input/Scalar/cases.json +22/−2
• test/Feature/Input/Scalar/decodeFloat/query.gql +0/−7
• test/Feature/Input/Scalar/decodeFloat/response.json +0/−9
• test/Feature/Input/Scalar/decodeInt/query.gql +0/−7
• test/Feature/Input/Scalar/decodeInt/response.json +0/−9
• test/Feature/Input/Scalar/numbers/decodeFloat/query.gql +7/−0
• test/Feature/Input/Scalar/numbers/decodeFloat/response.json +9/−0
• test/Feature/Input/Scalar/numbers/decodeInt/query.gql +7/−0
• test/Feature/Input/Scalar/numbers/decodeInt/response.json +9/−0
• test/Feature/Input/Scalar/strings/block/query.gql +20/−0
• test/Feature/Input/Scalar/strings/block/response.json +6/−0
• test/Feature/Input/Scalar/strings/escaped/query.gql +3/−0
• test/Feature/Input/Scalar/strings/escaped/response.json +1/−0
• test/Feature/Input/Scalar/strings/regular/query.gql +3/−0
• test/Feature/Input/Scalar/strings/regular/response.json +5/−0
• test/Feature/Input/Scalar/strings/wrong-escaped/query.gql +3/−0
• test/Feature/Input/Scalar/strings/wrong-escaped/response.json +8/−0
• test/Feature/Input/Scalar/strings/wrong-newline/query.gql +7/−0
• test/Feature/Input/Scalar/strings/wrong-newline/response.json +8/−0
• test/Feature/InputType/API.hs +0/−1
• test/Feature/Schema/API.hs +0/−1
• test/Feature/TypeInference/API.hs +0/−1
• test/Feature/UnionType/API.hs +0/−1
• test/Feature/UnionType/cannotBeSpreadOnType/query.gql +1/−1
• test/Feature/WrappedTypeName/API.hs +8/−9
• test/Rendering/Schema.hs +7/−8
• test/Rendering/TestSchemaRendering.hs +8/−7
• test/Rendering/schema.gql +9/−7
• test/Subscription/API.hs +2/−2
• test/Subscription/Case/ApolloRequest.hs +13/−23
• test/Subscription/Utils.hs +7/−7

@@ -29,7 +29,7 @@ resolver: lts-15.13  extra-deps:-  - morpheus-graphql-0.13.0+  - morpheus-graphql-0.14.0 ```  As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update`@@ -60,41 +60,41 @@ _API.hs_  ```haskell-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns        #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}  module API (api) where -import qualified Data.ByteString.Lazy.Char8 as B--import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Document     (importGQLDocumentWithNamespace)-import           Data.Morpheus.Types        (RootResolver (..), ResolverQ, Undefined(..))-import           Data.Text                  (Text)+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Morpheus (interpreter)+import Data.Morpheus.Document (importGQLDocument)+import Data.Morpheus.Types (RootResolver (..), Undefined (..))+import Data.Text (Text) -importGQLDocumentWithNamespace "schema.gql"+importGQLDocument "schema.gql"  rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =   RootResolver-    {-      queryResolver = Query {queryDeity},+    { queryResolver = Query {deity},       mutationResolver = Undefined,       subscriptionResolver = Undefined     }   where-    queryDeity QueryDeityArgs {queryDeityArgsName} = pure Deity-      {-        deityName = pure "Morpheus"-      , deityPower = pure (Just "Shapeshifting")-      }+    deity DeityArgs {name} =+      pure+        Deity+          { name = pure name,+            power = pure (Just "Shapeshifting")+          }  api :: ByteString -> IO ByteString api = interpreter rootResolver@@ -460,6 +460,12 @@   { newDeity :: m  Deity   } deriving (Generic) +newtype Subscription (m :: * -> *) = Subscription+{ newDeity :: SubscriptionField (m Deity),+}+deriving (Generic)++ type APIEvent = Event Channel Content  rootResolver :: RootResolver IO APIEvent Query Mutation Subscription@@ -475,13 +481,14 @@       requireAuthorized       publish [Event { channels = [ChannelA], content = ContentA 1 }]       lift dbCreateDeity-  newDeity = subscribe [ChannelA] $ do-      requireAuthorized-      lift deityByEvent-   where-    deityByEvent (Event [ChannelA] (ContentA _value)) = fetchDeity  -- resolve New State-    deityByEvent (Event [ChannelA] (ContentB _value)) = fetchDeity   -- resolve New State-    deityByEvent _ = fetchDeity -- Resolve Old State+  newDeity :: SubscriptionField (ResolverS EVENT IO Deity)+  newDeity = subscribe ChannelA $ do+    -- executed only once+    -- immediate response on failures+    requireAuthorized+    pure $ \(Event _ content) -> do+        -- exectues on every event+        lift (getDBAddress content) ```  ### Interface

@@ -1,7 +1,94 @@ # Changelog -## 0.13.0 - Unreleased Changes+## 0.14.0 - 15.08.2020 +### new features++- query validation supports interfaces+- `debugInterpreter`: displays internal context on grahql errors+- compileTimeSchemaValidation :+  morpheus validates schema at runtime (after the schema derivation).+  to be ensure that only correct api is compiled.+  we can use template haskell method `compileTimeSchemaValidation`++```hs+import Morpheus.Graphql.Server(compileTimeSchemaValidation)++_validateSchema :: ()+_validateSchema = $(compileTimeSchemaValidation (Identity gqlRoot))+```++- directive Validation for Document (TypeSystem).+- supports of block string values. e.g:++  ```graphql+  query {+    createDeity(+      name: """+      powerqwe+      bla \n sd+      blu \\ dete+      """+    ) {+      name+    }+  }+  ```++- `Data.Morpheus.Document` exposes `RootResolverConstraint`+- `Data.Morpheus.Server` exposes `httpPlayground`+- `httpPubApp` supports `GQLRequest -> GQLResponse`+- `morpheus-graphql-core` support of `schema`. issue #412++  ```graphql+  schema {+    query: Query+  }+  ```++  note that this does not affect `morpheus-graphql-server` at all. since it has its own schema derivation. you still need to provide:++  ```haskell+  rootResolver :: RootResolver () IO Query Undefined Undefined+  rootResolver = RootResolver <resolvers ...>+  ```++- Subscription Resolver supports `Monad`.+- nested Subscription Resolvers.++### Breaking Changes++- `Context' renamed to`ResolverContext'+- internal refactoring: changed AST+- root subscribtion fields must be wrapped with `SubscriptionField`. e.g:++```haskell+data Subscription (m :: * -> *) = Subscription+{ newDeity :: SubscriptionField (m Deity),+  newHuman :: HumanArgs -> SubscriptionField (m Human)+}+deriving (Generic)+```++- signature of `subscribe` is changed. now you can use it as followed:++```haskell+resolveNewAdress :: SubscriptionField (ResolverS EVENT IO Address)+resolveNewAdress = subscribe ADDRESS $ do+    -- executed only once+    -- immediate response on failures+    requireAuthorized+    pure $ \(Event _ content) -> do+        -- exectues on every event+        lift (getDBAddress content)+```++- removed from `Data.Morpheus.Types`+  - `SubField`+  - `ComposedSubField`++## 0.13.0 - 22.06.2020+ ### breaking changes  - renamed `GQLRootResolver` -> `RootResolver`@@ -19,26 +106,26 @@  - `morpheus-graphql-core`: core components like: parser, validator, executor, utils. -  - Data.Morpheus.Core-  - Data.Morpheus.QuasiQuoter-  - Data.Morpheus.Error-  - Data.Morpheus.Internal.TH-  - Data.Morpheus.Internal.Utils-  - Data.Morpheus.Types.Internal.Resolving-  - Data.Morpheus.Types.Internal.Operation-  - Data.Morpheus.Types.Internal.AST-  - Data.Morpheus.Types.IO+- Data.Morpheus.Core+- Data.Morpheus.QuasiQuoter+- Data.Morpheus.Error+- Data.Morpheus.Internal.TH+- Data.Morpheus.Internal.Utils+- Data.Morpheus.Types.Internal.Resolving+- Data.Morpheus.Types.Internal.Operation+- Data.Morpheus.Types.Internal.AST+- Data.Morpheus.Types.IO  - `morpheus-graphql-client`: lightweight version of morpheus client without server implementation -  - Data.Morpheus.Client+- Data.Morpheus.Client  - `morpheus-graphql`: morpheus graphql server-  - Data.Morpheus-  - Data.Morpheus.Kind-  - Data.Morpheus.Types-  - Data.Morpheus.Server-  - Data.Morpheus.Document+- Data.Morpheus+- Data.Morpheus.Kind+- Data.Morpheus.Types+- Data.Morpheus.Server+- Data.Morpheus.Document  deprecated: @@ -54,22 +141,22 @@ - flexible resolvers: `ResolverO`, `ResolverQ` , `RwsolverM`, `ResolverS`   they can handle object and scalar types: -  ```hs-  -- if we have record and regular Int-  data Object m = Object { field :: m Int }+```hs+-- if we have record and regular Int+data Object m = Object { field :: m Int } -  -- we canwrite-  -- handes kind : (* -> *) -> *-  resolveObject :: ResolverO o EVENT IO Object-  -- is alias to: Resolver o () IO (Object (Resolver o () IO))-  -- or-  -- handes kind : *-  resolveInt :: ResolverO o EVENT IO Int-  -- is alias to: Resolver o () IO Int-  ```+-- we canwrite+-- handes kind : (* -> *) -> *+resolveObject :: ResolverO o EVENT IO Object+-- is alias to: Resolver o () IO (Object (Resolver o () IO))+-- or+-- handes kind : *+resolveInt :: ResolverO o EVENT IO Int+-- is alias to: Resolver o () IO Int+``` -  the resolvers : `ResolverQ` , `RwsolverM`, `ResolverS` , are like-  `ResolverO` but with `QUERY` , `MUTATION` and `SUBSCRIPTION` as argument.+the resolvers : `ResolverQ` , `RwsolverM`, `ResolverS` , are like+`ResolverO` but with `QUERY` , `MUTATION` and `SUBSCRIPTION` as argument.  - flexible compsed Resolver Type alias: `ComposedResolver`. extends `ResolverO` with   parameter `(f :: * -> *)`. so that you can compose Resolvers e.g:

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 55c61a113411654d318235d761f68f5115a1c3ffcd5f287c90ddfcc38b9fd393+-- hash: 8d1e49edfa571f6e0dff20aa867324523a25cd49b27fdf2a5beae8aeb9adf536  name:           morpheus-graphql-version:        0.13.0+version:        0.14.0 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -135,8 +135,13 @@     test/Feature/Input/Object/unexpectedValue/query.gql     test/Feature/Input/Object/unexpectedVariable/query.gql     test/Feature/Input/Object/unknownField/query.gql-    test/Feature/Input/Scalar/decodeFloat/query.gql-    test/Feature/Input/Scalar/decodeInt/query.gql+    test/Feature/Input/Scalar/numbers/decodeFloat/query.gql+    test/Feature/Input/Scalar/numbers/decodeInt/query.gql+    test/Feature/Input/Scalar/strings/block/query.gql+    test/Feature/Input/Scalar/strings/escaped/query.gql+    test/Feature/Input/Scalar/strings/regular/query.gql+    test/Feature/Input/Scalar/strings/wrong-escaped/query.gql+    test/Feature/Input/Scalar/strings/wrong-newline/query.gql     test/Feature/InputType/variables/incompatibleType/equalType/query.gql     test/Feature/InputType/variables/incompatibleType/stricterType/query.gql     test/Feature/InputType/variables/incompatibleType/weakerType1/query.gql@@ -304,8 +309,13 @@     test/Feature/Input/Object/unexpectedVariable/response.json     test/Feature/Input/Object/unknownField/response.json     test/Feature/Input/Scalar/cases.json-    test/Feature/Input/Scalar/decodeFloat/response.json-    test/Feature/Input/Scalar/decodeInt/response.json+    test/Feature/Input/Scalar/numbers/decodeFloat/response.json+    test/Feature/Input/Scalar/numbers/decodeInt/response.json+    test/Feature/Input/Scalar/strings/block/response.json+    test/Feature/Input/Scalar/strings/escaped/response.json+    test/Feature/Input/Scalar/strings/regular/response.json+    test/Feature/Input/Scalar/strings/wrong-escaped/response.json+    test/Feature/Input/Scalar/strings/wrong-newline/response.json     test/Feature/InputType/cases.json     test/Feature/InputType/variables/incompatibleType/equalType/response.json     test/Feature/InputType/variables/incompatibleType/equalType/variables.json@@ -384,6 +394,7 @@       Data.Morpheus.Document       Data.Morpheus.Types.Internal.Subscription   other-modules:+      Data.Morpheus.Server.Deriving.Channels       Data.Morpheus.Server.Deriving.Decode       Data.Morpheus.Server.Deriving.Encode       Data.Morpheus.Server.Deriving.Interpreter@@ -392,8 +403,11 @@       Data.Morpheus.Server.Deriving.Utils       Data.Morpheus.Server.Internal.TH.Decode       Data.Morpheus.Server.Internal.TH.Types+      Data.Morpheus.Server.Internal.TH.Utils+      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@@ -415,7 +429,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.13.0+    , morpheus-graphql-core >=0.14.0     , mtl >=2.0 && <=3.0     , scientific >=0.3.6.2 && <0.4     , template-haskell >=2.0 && <=3.0@@ -464,7 +478,7 @@     , containers >=0.4.2.1 && <0.7     , megaparsec >=7.0.0 && <9.0.0     , morpheus-graphql-    , morpheus-graphql-core >=0.13.0+    , morpheus-graphql-core >=0.14.0     , mtl >=2.0 && <=3.0     , scientific >=0.3.6.2 && <0.4     , tasty

@@ -5,6 +5,7 @@     gqlDocument,     importGQLDocument,     importGQLDocumentWithNamespace,+    RootResolverConstraint,   ) where @@ -16,8 +17,8 @@   ( render,   ) import Data.Morpheus.Server.Deriving.Resolve-  ( RootResCon,-    fullSchema,+  ( RootResolverConstraint,+    deriveSchema,   ) import Data.Morpheus.Server.TH.Compile   ( compileDocument,@@ -42,9 +43,9 @@  -- | Generates schema.gql file from 'RootResolver' toGraphQLDocument ::-  RootResCon m event query mut sub =>+  RootResolverConstraint m event query mut sub =>   proxy (RootResolver m event query mut sub) ->   ByteString toGraphQLDocument =   resultOr (pack . show) (encodeUtf8 . LT.fromStrict . render)-    . fullSchema+    . deriveSchema

@@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  -- | associating types to GraphQL Kinds module Data.Morpheus.Kind

@@ -15,6 +15,8 @@     httpPubApp,     subscriptionApp,     ServerConstraint,+    httpPlayground,+    compileTimeSchemaValidation,   ) where @@ -25,9 +27,15 @@   ) -- MORPHEUS +import Data.Morpheus.Server.Deriving.Introspect+  ( compileTimeSchemaValidation,+  )+import Data.Morpheus.Server.Playground+  ( httpPlayground,+  ) import Data.Morpheus.Types.IO (MapAPI (..)) import Data.Morpheus.Types.Internal.Resolving-  ( GQLChannel (..),+  ( Event,   ) import Data.Morpheus.Types.Internal.Subscription   ( HTTP,@@ -52,9 +60,7 @@  type ServerConstraint e m =   ( MonadIO m,-    MonadUnliftIO m,-    Eq (StreamChannel e),-    GQLChannel e+    MonadUnliftIO m   )  -- support old version of Websockets@@ -76,31 +82,29 @@  httpPubApp ::   ( MonadIO m,-    MapAPI a+    MapAPI a b   ) =>   (Input HTTP -> Stream HTTP e m) ->   (e -> m ()) ->   a ->-  m a+  m b httpPubApp api httpCallback =-  mapAPI-    ( runStreamHTTP ScopeHTTP {httpCallback}-        . api-        . Request-    )+  mapAPI $+    runStreamHTTP ScopeHTTP {httpCallback}+      . api+      . Request  -- | Wai WebSocket Server App for GraphQL subscriptions subscriptionApp ::   ( MonadUnliftIO m,-    (Eq (StreamChannel e)),-    (GQLChannel e)+    Eq channel   ) =>-  ( Store e m ->-    (Scope WS e m -> m ()) ->+  ( Store (Event channel a) m ->+    (Scope WS (Event channel a) m -> m ()) ->     m app   ) ->-  (Input WS -> Stream WS e m) ->-  m (app, e -> m ())+  (Input WS -> Stream WS (Event channel a) m) ->+  m (app, Event channel a -> m ()) subscriptionApp appWrapper api =   do     store <- initDefaultStore@@ -129,9 +133,8 @@ webSocketsApp ::   ( MonadIO m,     MonadUnliftIO m,-    (Eq (StreamChannel e)),-    (GQLChannel e)+    Eq channel   ) =>-  (Input WS -> Stream WS e m) ->-  m (ServerApp, e -> m ())+  (Input WS -> Stream WS (Event channel a) m) ->+  m (ServerApp, Event channel a -> m ()) webSocketsApp = subscriptionApp webSocketsWrapper

@@ -0,0 +1,134 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Morpheus.Server.Deriving.Channels+  ( getChannels,+    ChannelCon,+    GetChannel (..),+    ExploreChannels (..),+  )+where++-- MORPHEUS+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    elems,+  )+import Data.Morpheus.Server.Deriving.Decode+  ( DecodeType,+    decodeArguments,+  )+import Data.Morpheus.Server.Types.GQLType (GQLType (..))+import Data.Morpheus.Types.Internal.AST+  ( FALSE,+    FieldName (..),+    InternalError,+    SUBSCRIPTION,+    Selection (..),+    SelectionContent (..),+    VALID,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Channel,+    Resolver,+    ResolverState,+    SubscriptionField (..),+  )+import Data.Proxy (Proxy (..))+import Data.Semigroup ((<>))+import Data.Text+  ( pack,+  )+import GHC.Generics++data CustomProxy (c :: Bool) e = CustomProxy++type ChannelCon e m a =+  ExploreChannels+    (CUSTOM (a (Resolver SUBSCRIPTION e m)))+    (a (Resolver SUBSCRIPTION e m))+    e++getChannels ::+  forall e m subs.+  ChannelCon 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++selectBy ::+  Failure InternalError m =>+  Selection VALID ->+  [ ( FieldName,+      Selection VALID -> m (Channel e)+    )+  ] ->+  m (Channel e)+selectBy Selection {selectionContent = SelectionSet selSet} ch =+  case elems selSet of+    [sel@Selection {selectionName}] -> case lookup selectionName ch of+      Nothing -> failure ("invalid subscription: no channel is selected." :: InternalError)+      Just f -> f sel+    _ -> failure ("invalid subscription: there can be only one top level selection" :: InternalError)+selectBy _ _ = failure ("invalid subscription: expected selectionSet" :: InternalError)++class GetChannel e a | a -> e where+  getChannel :: a -> Selection VALID -> ResolverState (Channel e)++instance GetChannel e (SubscriptionField (Resolver SUBSCRIPTION e m a)) where+  getChannel SubscriptionField {channel} = const (pure channel)++instance+  (Generic arg, DecodeType 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))]++instance (FieldRep e f, FieldRep e g) => FieldRep e (f :*: g) where+  fieldRep e (a :*: b) = fieldRep e a <> fieldRep e b++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)]++instance FieldRep e U1 where+  fieldRep _ _ = []

@@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-}@@ -20,10 +21,6 @@ where  -- MORPHEUS-import Data.Morpheus.Error-  ( internalError,-    internalTypeMismatch,-  ) import Data.Morpheus.Internal.Utils   ( elems,   )@@ -41,19 +38,20 @@   ) import Data.Morpheus.Server.Internal.TH.Decode   ( decodeFieldWith,+    withInputObject,+    withInputUnion,     withList,     withMaybe,-    withObject,-    withUnion,+    withScalar,   ) import Data.Morpheus.Server.Types.GQLType (GQLType (KIND, __typeName)) import Data.Morpheus.Types.GQLScalar   ( GQLScalar (..),-    toScalar,   ) import Data.Morpheus.Types.Internal.AST   ( Argument (..),     Arguments,+    InternalError,     ObjectEntry (..),     TypeName (..),     VALID,@@ -63,22 +61,22 @@     msg,   ) import Data.Morpheus.Types.Internal.Resolving-  ( Eventless,-    Failure (..),+  ( Failure (..),+    ResolverState,   ) import Data.Proxy (Proxy (..)) import Data.Semigroup (Semigroup (..)) import GHC.Generics  -- GENERIC-decodeArguments :: DecodeType a => Arguments VALID -> Eventless a+decodeArguments :: DecodeType a => Arguments VALID -> ResolverState a decodeArguments = decodeType . Object . fmap toEntry   where-    toEntry (Argument name value _) = ObjectEntry name value+    toEntry Argument {..} = ObjectEntry argumentName argumentValue  -- | Decode GraphQL query arguments and input values class Decode a where-  decode :: ValidValue -> Eventless a+  decode :: ValidValue -> ResolverState a  instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where   decode = decodeKind (Proxy @(KIND a))@@ -91,13 +89,11 @@  -- | Decode GraphQL type with Specific Kind class DecodeKind (kind :: GQL_KIND) a where-  decodeKind :: Proxy kind -> ValidValue -> Eventless a+  decodeKind :: Proxy kind -> ValidValue -> ResolverState a  -- SCALAR-instance (GQLScalar a) => DecodeKind SCALAR a where-  decodeKind _ value = case toScalar value >>= parseValue of-    Right scalar -> return scalar-    Left errorMessage -> internalTypeMismatch (msg errorMessage) value+instance (GQLScalar a, GQLType a) => DecodeKind SCALAR a where+  decodeKind _ = withScalar (__typeName (Proxy @a)) parseValue  -- ENUM instance DecodeType a => DecodeKind ENUM a where@@ -112,7 +108,7 @@   decodeKind _ = decodeType  class DecodeType a where-  decodeType :: ValidValue -> Eventless a+  decodeType :: ValidValue -> ResolverState a  instance {-# OVERLAPPABLE #-} (Generic a, DecodeRep (Rep a)) => DecodeType a where   decodeType = fmap to . decodeRep . (,Cont D_CONS "")@@ -125,11 +121,11 @@ --     deriving (Generic, GQLType)  decideUnion ::-  ([TypeName], value -> Eventless (f1 a)) ->-  ([TypeName], value -> Eventless (f2 a)) ->+  ([TypeName], value -> ResolverState (f1 a)) ->+  ([TypeName], value -> ResolverState (f2 a)) ->   TypeName ->   value ->-  Eventless ((:+:) f1 f2 a)+  ResolverState ((:+:) f1 f2 a) decideUnion (left, f1) (right, f2) name value   | name `elem` left =     L1 <$> f1 value@@ -163,7 +159,7 @@ -- class DecodeRep f where   tags :: Proxy f -> TypeName -> Info-  decodeRep :: (ValidValue, Cont) -> Eventless (f a)+  decodeRep :: (ValidValue, Cont) -> ResolverState (f a)  instance (Datatype d, DecodeRep f) => DecodeRep (M1 D d f) where   tags _ = tags (Proxy @f)@@ -172,16 +168,16 @@       <$> decodeRep         (x, y {typeName = datatypeNameProxy (Proxy @d)}) -getEnumTag :: ValidObject -> Eventless TypeName+getEnumTag :: ValidObject -> ResolverState TypeName getEnumTag x = case elems x of   [ObjectEntry "enum" (Enum value)] -> pure value-  _ -> internalError "bad union enum object"+  _ -> failure ("bad union enum object" :: InternalError)  instance (DecodeRep a, DecodeRep b) => DecodeRep (a :+: b) where   tags _ = tags (Proxy @a) <> tags (Proxy @b)   decodeRep = __decode     where-      __decode (Object obj, cont) = withUnion handleUnion obj+      __decode (Object obj, cont) = withInputUnion handleUnion obj         where           handleUnion name unions object             | name == typeName cont <> "EnumObject" =@@ -203,7 +199,7 @@           (tagName $ tags (Proxy @b) (typeName cxt), decodeRep)           name           (Enum name, cxt)-      __decode _ = internalError "lists and scalars are not allowed in Union"+      __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@@ -220,7 +216,7 @@  class DecodeFields f where   refType :: Proxy f -> Maybe TypeName-  decodeFields :: (ValidValue, Cont) -> Eventless (f a)+  decodeFields :: (ValidValue, Cont) -> ResolverState (f a)  instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where   refType _ = Nothing@@ -234,7 +230,7 @@     where       __decode = fmap (M1 . K1) . decodeRec       fieldName = selNameProxy (Proxy @s)-      decodeRec = withObject (decodeFieldWith decode fieldName)+      decodeRec = withInputObject (decodeFieldWith decode fieldName)  instance DecodeFields U1 where   refType _ = Nothing

@@ -35,6 +35,7 @@     SCALAR,     VContext (..),   )+import Data.Morpheus.Server.Deriving.Channels (ChannelCon, getChannels) import Data.Morpheus.Server.Deriving.Decode   ( DecodeType,     decodeArguments,@@ -57,26 +58,25 @@ import Data.Morpheus.Types.Internal.AST   ( FieldName,     FieldName (..),+    InternalError,     MUTATION,-    Message,     OperationType (..),     QUERY,     SUBSCRIPTION,     TypeName,   ) import Data.Morpheus.Types.Internal.Resolving-  ( Eventless,-    FieldResModel,+  ( FieldResModel,     LiftOperation,-    MapStrategy (..),     ObjectResModel (..),     ResModel (..),     Resolver,+    ResolverState,     RootResModel (..),+    SubscriptionField (..),     failure,-    liftStateless,-    toResolver,-    unsafeBind,+    getArguments,+    liftResolverState,   ) import Data.Proxy (Proxy (..)) import Data.Semigroup ((<>))@@ -114,31 +114,34 @@   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+  encode (SubscriptionField _ res) = encode res+ --  GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY instance   ( DecodeType a,     Generic a,     Monad m,-    LiftOperation fo,-    Encode b fo e m,-    MapStrategy fo o+    LiftOperation o,+    Encode b o e m   ) =>-  Encode (a -> Resolver fo e m b) o e m+  Encode (a -> b) o e m   where-  encode x =-    mapStrategy $-      toResolver decodeArguments x `unsafeBind` encode+  encode f =+    getArguments+      >>= liftResolverState . decodeArguments+      >>= encode . f  --  GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY instance   ( Monad m,-    LiftOperation o,-    Encode b fo e m,-    MapStrategy fo o+    Encode b o e m,+    LiftOperation o   ) =>-  Encode (Resolver fo e m b) o e m+  Encode (Resolver o e m b) o e m   where-  encode = mapStrategy . (`unsafeBind` encode)+  encode x = x >>= encode  -- ENCODE GQL KIND class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where@@ -150,13 +153,13 @@  -- ENUM instance (Generic a, ExploreResolvers (CUSTOM a) a o e m, Monad m) => EncodeKind ENUM a o e m where-  encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value+  encodeKind (VContext value) = liftResolverState $ exploreResolvers (Proxy @(CUSTOM a)) value  instance (Monad m, Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where-  encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value+  encodeKind (VContext value) = liftResolverState $ exploreResolvers (Proxy @(CUSTOM a)) value  instance (Monad m, Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind INTERFACE a o e m where-  encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value+  encodeKind (VContext value) = liftResolverState $ exploreResolvers (Proxy @(CUSTOM a)) value  convertNode ::   (Monad m, LiftOperation o) =>@@ -194,7 +197,7 @@  --- GENERICS ------------------------------------------------ class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where-  exploreResolvers :: Proxy custom -> a -> Eventless (ResModel o e m)+  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 =@@ -210,7 +213,7 @@     LiftOperation o   ) =>   a ->-  Eventless (ResModel o e m)+  ResolverState (ResModel o e m) objectResolvers value =   exploreResolvers (Proxy @(CUSTOM a)) value     >>= constraintOnject@@ -218,7 +221,7 @@     constraintOnject obj@ResObject {} =       pure obj     constraintOnject _ =-      failure ("resolver must be an object" :: Message)+      failure ("resolver must be an object" :: InternalError)  type Con o e m a =   ExploreResolvers@@ -235,6 +238,7 @@   ( Con QUERY e m query,     Con MUTATION e m mut,     Con SUBSCRIPTION e m sub,+    ChannelCon e m sub,     Applicative m,     Monad m   ) =>@@ -249,7 +253,8 @@     RootResModel       { query = objectResolvers queryResolver,         mutation = objectResolvers mutationResolver,-        subscription = objectResolvers subscriptionResolver+        subscription = objectResolvers subscriptionResolver,+        channelMap = Just (getChannels subscriptionResolver)       }  toFieldRes :: FieldNode o e m -> FieldResModel o e m

@@ -9,14 +9,15 @@ where  -- MORPHEUS-+import Data.Morpheus.Core (debugConfig, defaultConfig) import Data.Morpheus.Server.Deriving.Resolve-  ( RootResCon,+  ( RootResolverConstraint,     coreResolver,     statelessResolver,   ) import Data.Morpheus.Types-  ( RootResolver (..),+  ( Event,+    RootResolver (..),   ) import Data.Morpheus.Types.IO   ( GQLRequest,@@ -49,19 +50,25 @@ class Interpreter e m a b where   interpreter ::     Monad m =>-    (RootResCon m e query mut sub) =>+    (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 = statelessResolver+  interpreter root = statelessResolver root defaultConfig+  debugInterpreter root = statelessResolver root debugConfig -instance Interpreter e m (Input api) (Stream api e m) where-  interpreter root = toOutStream (coreResolver root)+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) =>-  Interpreter e m a (m a)-  where+instance (MapAPI a a) => Interpreter e m a (m a) where   interpreter root = mapAPI (interpreter root)+  debugInterpreter root = mapAPI (debugInterpreter root)

@@ -12,34 +12,38 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}  module Data.Morpheus.Server.Deriving.Introspect-  ( TypeUpdater,-    Introspect (..),+  ( Introspect (..),     DeriveTypeContent (..),     introspectOUT,     IntroCon,-    updateLib,-    buildType,-    introspectObjectFields,     deriveCustomInputObjectType,-    TypeScope (..),     ProxyRep (..),+    TypeUpdater,+    deriveSchema,+    compileTimeSchemaValidation,   ) where -import Data.List (partition)-import Data.Map (Map) -- 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-  ( empty,+  ( Failure (..),+    concatUpdates,+    empty,+    failUpdates,+    resolveUpdates,     singleton,   ) import Data.Morpheus.Kind@@ -57,7 +61,11 @@     isRecordProxy,     selNameProxy,   )-import Data.Morpheus.Server.Types.GQLType (GQLType (..))+import Data.Morpheus.Server.Types.GQLType+  ( GQLType (..),+    GQLType (CUSTOM),+    TypeUpdater,+  ) import Data.Morpheus.Server.Types.Types   ( MapKind,     Pair,@@ -65,41 +73,53 @@ 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 (..),-    TypeUpdater,     UnionMember (..),-    createAlias,-    createEnumValue,-    defineType,+    VALID,     fieldsToArguments,-    mkField,+    initTypeLib,+    insertType,+    mkEnumContent,+    mkInputValue,+    mkType,+    mkTypeRef,     mkUnionMember,     msg,     toListField,-    toNullableField,+    toNullable,     unsafeFromFields,     updateSchema,   ) import Data.Morpheus.Types.Internal.Resolving-  ( Failure (..),+  ( Eventless,     Resolver,-    resolveUpdates,+    Result (..),+    SubscriptionField (..),   ) import Data.Proxy (Proxy (..)) import Data.Semigroup ((<>))@@ -108,12 +128,92 @@   ( 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) @@ -126,19 +226,19 @@   isObject :: proxy cat a -> Bool   default isObject :: GQLType a => proxy cat a -> Bool   isObject _ = isObjectKind (Proxy @a)-  field :: proxy cat a -> FieldName -> FieldDefinition cat+  field :: proxy cat a -> FieldName -> FieldDefinition cat CONST   -----------------------------------------------   default field ::     GQLType a =>     proxy cat a ->     FieldName ->-    FieldDefinition cat+    FieldDefinition cat CONST   field _ = buildField (Proxy @a) Nothing  -- Maybe instance Introspect cat a => Introspect cat (Maybe a) where   isObject _ = False-  field _ = toNullableField . field (ProxyRep :: ProxyRep cat a)+  field _ = toNullable . field (ProxyRep :: ProxyRep cat a)   introspect _ = introspect (ProxyRep :: ProxyRep cat a)  -- List@@ -171,23 +271,25 @@   field _ name = fieldObj {fieldContent = Just (FieldArgs fieldArgs)}     where       fieldObj = field (ProxyRep :: ProxyRep OUT b) name-      fieldArgs :: ArgumentsDefinition+      fieldArgs :: ArgumentsDefinition CONST       fieldArgs =         fieldsToArguments           $ fst           $ introspectInputObjectFields             (Proxy :: Proxy 'False)             (__typeName (Proxy @b), Proxy @a)-  introspect _ typeLib =-    resolveUpdates-      typeLib-      (introspect (ProxyRep :: ProxyRep OUT b) : inputs)+  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@@ -202,14 +304,15 @@ 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 =-        buildType $ DataEnum $ map (createEnumValue . TypeName) $ enumTags (Proxy @(Rep a))+      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@@ -248,15 +351,13 @@   (TypeName, proxy a) ->   TypeUpdater deriveCustomInputObjectType (name, proxy) =-  flip-    resolveUpdates-    (snd $ introspectInputObjectFields (Proxy :: Proxy TRUE) (name, proxy))+  concatUpdates (snd $ introspectInputObjectFields (Proxy :: Proxy TRUE) (name, proxy))  introspectInputObjectFields ::   DeriveTypeContent IN custom a =>   proxy1 (custom :: Bool) ->   (TypeName, proxy2 a) ->-  (FieldsDefinition IN, [TypeUpdater])+  (FieldsDefinition IN CONST, [TypeUpdater]) introspectInputObjectFields p1 (name, proxy) =   withObject (deriveTypeContent p1 (proxy, ([], []), InputType, "", DataFingerprint "" []))   where@@ -267,7 +368,7 @@   DeriveTypeContent OUT custom a =>   proxy1 (custom :: Bool) ->   (TypeName, proxy2 a) ->-  (FieldsDefinition OUT, [TypeUpdater])+  (FieldsDefinition OUT CONST, [TypeUpdater]) introspectObjectFields p1 (name, proxy) =   withObject (deriveTypeContent p1 (proxy, ([], []), OutputType, "", DataFingerprint "" []))   where@@ -275,11 +376,14 @@     withObject _ = (empty, [introspectFailure (msg name <> " should have only one nonempty constructor")])  introspectFailure :: Message -> TypeUpdater-introspectFailure = const . failure . globalErrorMessage . ("invalid schema: " <>)+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, [TypeUpdater])+  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) =@@ -294,19 +398,19 @@ buildField ::   GQLType a =>   Proxy a ->-  Maybe (FieldContent TRUE cat) ->+  Maybe (FieldContent TRUE cat CONST) ->   FieldName ->-  FieldDefinition cat+  FieldDefinition cat CONST buildField proxy fieldContent fieldName =   FieldDefinition-    { fieldType = createAlias (__typeName proxy),+    { fieldType = mkTypeRef (__typeName proxy),       fieldDescription = Nothing,       fieldDirectives = empty,       fieldContent = fieldContent,       ..     } -buildType :: GQLType a => TypeContent TRUE cat -> Proxy a -> TypeDefinition cat+buildType :: GQLType a => TypeContent TRUE cat CONST -> Proxy a -> TypeDefinition cat CONST buildType typeContent proxy =   TypeDefinition     { typeName = __typeName proxy,@@ -318,7 +422,7 @@  updateLib ::   GQLType a =>-  (Proxy a -> TypeDefinition cat) ->+  (Proxy a -> TypeDefinition cat CONST) ->   [TypeUpdater] ->   Proxy a ->   TypeUpdater@@ -326,7 +430,7 @@  updateLibOUT ::   GQLType a =>-  (Proxy a -> TypeDefinition OUT) ->+  (Proxy a -> TypeDefinition OUT CONST) ->   [TypeUpdater] ->   Proxy a ->   TypeUpdater@@ -342,7 +446,7 @@  data FieldRep cat = FieldRep   { fieldTypeName :: TypeName,-    fieldData :: FieldDefinition cat,+    fieldData :: FieldDefinition cat CONST,     fieldTypeUpdater :: TypeUpdater,     fieldIsObject :: Bool   }@@ -385,38 +489,37 @@     (unionRecordRep, anyonimousUnionRep) = partition consIsRecord left2  buildInputUnion ::-  (TypeName, DataFingerprint) -> [ConsRep IN] -> (TypeContent TRUE IN, [TypeUpdater])+  (TypeName, DataFingerprint) -> [ConsRep IN] -> (TypeContent TRUE IN CONST, [TypeUpdater]) buildInputUnion (baseName, baseFingerprint) cons =   datatype     (analyseRep baseName cons)   where-    datatype :: ResRep IN -> (TypeContent TRUE IN, [TypeUpdater])-    datatype ResRep {unionRef = [], unionRecordRep = [], enumCons} =-      (DataEnum (map createEnumValue enumCons), types)+    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]+        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 -> TypeContent TRUE IN)+    wrapInputObject :: (FieldsDefinition IN CONST -> TypeContent TRUE IN CONST)     wrapInputObject = DataInputObject  buildUnionType ::+  (ELEM LEAF cat ~ TRUE) =>   (TypeName, DataFingerprint) ->-  (DataUnion -> TypeContent TRUE cat) ->-  (FieldsDefinition cat -> TypeContent TRUE cat) ->+  (DataUnion CONST -> TypeContent TRUE cat CONST) ->+  (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->   [ConsRep cat] ->-  (TypeContent TRUE cat, [TypeUpdater])+  (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} =-      (DataEnum (map createEnumValue enumCons), types)+    datatype ResRep {unionRef = [], unionRecordRep = [], enumCons} = (mkEnumContent enumCons, types)     datatype ResRep {unionRef, unionRecordRep, enumCons} =       (wrapUnion (map mkUnionMember typeMembers), types <> enumTypes <> unionTypes)       where@@ -427,7 +530,7 @@           buildUnions wrapObject baseFingerprint unionRecordRep     types = map fieldTypeUpdater $ concatMap consFields cons -buildObject :: ([TypeName], [TypeUpdater]) -> TypeScope cat -> [FieldRep cat] -> (TypeContent TRUE cat, [TypeUpdater])+buildObject :: ([TypeName], [TypeUpdater]) -> TypeScope cat -> [FieldRep cat] -> (TypeContent TRUE cat CONST, [TypeUpdater]) buildObject (interfaces, interfaceTypes) scope consFields =   ( wrapWith scope fields,     types <> interfaceTypes@@ -435,31 +538,28 @@   where     (fields, types) = buildDataObject consFields     --- wrap with-    wrapWith :: TypeScope cat -> FieldsDefinition cat -> TypeContent TRUE cat+    wrapWith :: TypeScope cat -> FieldsDefinition cat CONST -> TypeContent TRUE cat CONST     wrapWith InputType = DataInputObject     wrapWith OutputType = DataObject interfaces -buildDataObject :: [FieldRep cat] -> (FieldsDefinition cat, [TypeUpdater])+buildDataObject :: [FieldRep cat] -> (FieldsDefinition cat CONST, [TypeUpdater]) buildDataObject consFields = (fields, types)   where     fields = unsafeFromFields $ map fieldData consFields     types = map fieldTypeUpdater consFields  buildUnions ::-  (FieldsDefinition cat -> TypeContent TRUE cat) ->+  (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->   DataFingerprint ->   [ConsRep cat] ->   ([TypeName], [TypeUpdater]) buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons)   where-    buildURecType consRep =-      pure-        . defineType-          (buildUnionRecord wrapObject baseFingerprint consRep)+    buildURecType = insertType . buildUnionRecord wrapObject baseFingerprint     members = map consName cons  buildUnionRecord ::-  (FieldsDefinition cat -> TypeContent TRUE cat) -> DataFingerprint -> ConsRep cat -> TypeDefinition cat+  (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) -> DataFingerprint -> ConsRep cat -> TypeDefinition cat CONST buildUnionRecord wrapObject typeFingerprint ConsRep {consName, consFields} =   TypeDefinition     { typeName = consName,@@ -473,7 +573,7 @@     }  buildUnionEnum ::-  (FieldsDefinition cat -> TypeContent TRUE cat) ->+  (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->   TypeName ->   DataFingerprint ->   [TypeName] ->@@ -501,34 +601,34 @@  buildEnum :: TypeName -> DataFingerprint -> [TypeName] -> TypeUpdater buildEnum typeName typeFingerprint tags =-  pure-    . defineType-      TypeDefinition+  insertType+    ( TypeDefinition         { typeDescription = Nothing,           typeDirectives = empty,-          typeContent = DataEnum $ map createEnumValue tags,+          typeContent = mkEnumContent tags,           ..-        }+        } ::+        TypeDefinition LEAF CONST+    )  buildEnumObject ::-  (FieldsDefinition cat -> TypeContent TRUE cat) ->+  (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->   TypeName ->   DataFingerprint ->   TypeName ->   TypeUpdater buildEnumObject wrapObject typeName typeFingerprint enumTypeName =-  pure-    . defineType-      TypeDefinition-        { typeName,-          typeFingerprint,-          typeDescription = Nothing,-          typeDirectives = empty,-          typeContent =-            wrapObject $-              singleton-                (mkField "enum" ([], enumTypeName))-        }+  insertType+    TypeDefinition+      { typeName,+        typeFingerprint,+        typeDescription = Nothing,+        typeDirectives = empty,+        typeContent =+          wrapObject+            $ singleton+            $ mkInputValue "enum" [] enumTypeName+      }  data TypeScope (cat :: TypeCategory) where   InputType :: TypeScope IN

@@ -1,18 +1,14 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}  module Data.Morpheus.Server.Deriving.Resolve   ( statelessResolver,-    RootResCon,-    fullSchema,+    RootResolverConstraint,     coreResolver,-    EventCon,+    deriveSchema,   ) where @@ -20,20 +16,18 @@ -- MORPHEUS  import Data.Morpheus.Core-  ( runApi,-  )-import Data.Morpheus.Internal.Utils-  ( empty,+  ( Config,+    runApi,   )+import Data.Morpheus.Server.Deriving.Channels (ChannelCon) import Data.Morpheus.Server.Deriving.Encode   ( EncodeCon,     deriveModel,   ) import Data.Morpheus.Server.Deriving.Introspect   ( IntroCon,-    introspectObjectFields,+    deriveSchema,   )-import Data.Morpheus.Server.Types.GQLType (GQLType (CUSTOM)) import Data.Morpheus.Types   ( RootResolver (..),   )@@ -43,126 +37,46 @@     renderResponse,   ) import Data.Morpheus.Types.Internal.AST-  ( DataFingerprint (..),-    FieldsDefinition,-    MUTATION,-    OUT,+  ( MUTATION,     QUERY,     SUBSCRIPTION,-    Schema (..),-    TypeContent (..),-    TypeDefinition (..),-    TypeName,-    ValidValue,-    initTypeLib,+    VALID,+    Value,   ) import Data.Morpheus.Types.Internal.Resolving-  ( Eventless,-    GQLChannel (..),-    Resolver,+  ( Resolver,     ResponseStream,     ResultT (..),-    cleanEvents,-    resolveUpdates,   )-import Data.Proxy (Proxy (..))-import Data.Typeable (Typeable) -type EventCon event =-  (Eq (StreamChannel event), Typeable event, GQLChannel event)--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))+type OperationConstraint operation event m a =+  ( EncodeCon operation event m (a (Resolver operation event m)),+    IntroCon (a (Resolver operation event m))   ) -type RootResCon m event query mutation subscription =-  ( EventCon event,-    Typeable m,-    IntrospectConstraint m event query mutation subscription,-    EncodeCon QUERY event m (query (Resolver QUERY event m)),-    EncodeCon MUTATION event m (mutation (Resolver MUTATION event m)),-    EncodeCon-      SUBSCRIPTION-      event-      m-      (subscription (Resolver SUBSCRIPTION 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 ::-  (Monad m, RootResCon m event query mut sub) =>+  RootResolverConstraint m event query mut sub =>   RootResolver m event query mut sub ->+  Config ->   GQLRequest ->   m GQLResponse-statelessResolver root req =-  renderResponse <$> runResultT (coreResolver root req)+statelessResolver root config req =+  renderResponse <$> runResultT (coreResolver root config req)  coreResolver ::-  forall event m query mut sub.-  (Monad m, RootResCon m event query mut sub) =>+  RootResolverConstraint m event query mut sub =>   RootResolver m event query mut sub ->+  Config ->   GQLRequest ->-  ResponseStream event m ValidValue-coreResolver root request =-  validRequest-    >>= execOperator-  where-    validRequest ::-      Monad m => ResponseStream event m Schema-    validRequest = cleanEvents $ ResultT $ pure $ fullSchema $ Identity root-    ---------------------------------------    execOperator schema = runApi schema (deriveModel root) request--fullSchema ::-  forall proxy m event query mutation subscription.-  (IntrospectConstraint m event query mutation subscription) =>-  proxy (RootResolver m event query mutation subscription) ->-  Eventless Schema-fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema-  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 -> TypeName -> Maybe (TypeDefinition OUT)-    maybeOperator fields-      | null fields = const Nothing-      | otherwise = Just . operatorType fields-    --------------------------------------------------    operatorType :: FieldsDefinition OUT -> TypeName -> TypeDefinition OUT-    operatorType fields typeName =-      TypeDefinition-        { typeContent = DataObject [] fields,-          typeName,-          typeFingerprint = DataFingerprint typeName [],-          typeDescription = Nothing,-          typeDirectives = empty-        }+  ResponseStream event m (Value VALID)+coreResolver root config request = do+  schema <- deriveSchema (Identity root)+  runApi schema (deriveModel root) config request

@@ -22,20 +22,19 @@   ) import Data.Proxy (Proxy (..)) import Data.Text-  ( Text,-    pack,+  ( pack,   ) import GHC.Generics  -- MORPHEUS class EnumRep (f :: * -> *) where-  enumTags :: Proxy f -> [Text]+  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 _ = [pack $ conName (undefined :: (M1 C c U1 x))]+  enumTags _ = [conNameProxy (Proxy @c)]  instance (EnumRep a, EnumRep b) => EnumRep (a :+: b) where   enumTags _ = enumTags (Proxy @a) ++ enumTags (Proxy @b)

@@ -1,99 +1,111 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}  module Data.Morpheus.Server.Internal.TH.Decode-  ( withObject,+  ( withInputObject,     withMaybe,     withList,     withEnum,-    withUnion,+    withInputUnion,     decodeFieldWith,-    decodeObjectExpQ,+    withScalar,   ) where  -- MORPHEUS-import Data.Morpheus.Error-  ( internalTypeMismatch,-  )-import Data.Morpheus.Internal.TH-  ( nameConE,-    nameVarE,-  ) import Data.Morpheus.Internal.Utils   ( empty,     selectBy,     selectOr,   )+import Data.Morpheus.Types.GQLScalar+  ( toScalar,+  ) import Data.Morpheus.Types.Internal.AST-  ( ConsD (..),-    FieldDefinition (..),-    FieldName,-    Message,+  ( FieldName,+    InternalError,     Message,     ObjectEntry (..),+    ScalarValue,+    Token,     TypeName (..),+    VALID,     ValidObject,     ValidValue,     Value (..),     msg,+    msgInternal,     toFieldName,   ) import Data.Morpheus.Types.Internal.Resolving-  ( Eventless,-    Failure (..),+  ( Failure (..),   ) import Data.Semigroup ((<>))-import Language.Haskell.TH-  ( ExpQ,-    uInfixE,-    varE,-  ) -decodeObjectExpQ :: ExpQ -> ConsD cat -> ExpQ-decodeObjectExpQ fieldDecoder ConsD {cName, cFields} = handleFields cFields-  where-    consName = nameConE cName-    -----------------------------------------------------------------------------------    handleFields fNames = uInfixE consName (varE '(<$>)) (applyFields fNames)-      where-        applyFields [] = fail $ show ("No Empty fields on " <> msg cName :: Message)-        applyFields [x] = defField x-        applyFields (x : xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs)-        -------------------------------------------------------------------------        defField FieldDefinition {fieldName} =-          uInfixE-            (nameVarE "o")-            fieldDecoder-            [|fieldName|]--withObject :: (ValidObject -> Eventless a) -> ValidValue -> Eventless a-withObject f (Object object) = f object-withObject _ isType = internalTypeMismatch "Object" isType+withInputObject ::+  Failure InternalError m =>+  (ValidObject -> m a) ->+  ValidValue ->+  m a+withInputObject f (Object object) = f object+withInputObject _ isType = failure (typeMismatch "Object" isType)  withMaybe :: Monad m => (ValidValue -> m a) -> ValidValue -> m (Maybe a) withMaybe _ Null = pure Nothing withMaybe decode x = Just <$> decode x -withList :: (ValidValue -> Eventless a) -> ValidValue -> Eventless [a]+withList ::+  (Failure InternalError m, Monad m) =>+  (ValidValue -> m a) ->+  ValidValue ->+  m [a] withList decode (List li) = traverse decode li-withList _ isType = internalTypeMismatch "List" isType+withList _ isType = failure (typeMismatch "List" isType) -withEnum :: (TypeName -> Eventless a) -> ValidValue -> Eventless a+withEnum :: Failure InternalError m => (TypeName -> m a) -> Value VALID -> m a withEnum decode (Enum value) = decode value-withEnum _ isType = internalTypeMismatch "Enum" isType+withEnum _ isType = failure (typeMismatch "Enum" isType) -withUnion :: (TypeName -> ValidObject -> ValidObject -> Eventless a) -> ValidObject -> Eventless a-withUnion decoder unions = do-  (enum :: ValidValue) <- entryValue <$> selectBy ("__typename not found on Input Union" :: Message) "__typename" unions-  case enum of-    (Enum key) -> selectOr notfound onFound (toFieldName key) unions+withInputUnion ::+  (Failure InternalError m, Monad m) =>+  (TypeName -> ValidObject -> ValidObject -> m a) ->+  ValidObject ->+  m a+withInputUnion decoder unions =+  selectBy+    ("__typename not found on Input Union" :: InternalError)+    ("__typename" :: FieldName)+    unions+    >>= providesValueFor . entryValue+  where+    providesValueFor (Enum key) = selectOr notfound onFound (toFieldName key) unions       where-        notfound = withObject (decoder key unions) (Object empty)-        onFound = withObject (decoder key unions) . entryValue-    _ -> failure ("__typename must be Enum" :: Message)+        notfound = withInputObject (decoder key unions) (Object empty)+        onFound = withInputObject (decoder key unions) . entryValue+    providesValueFor _ = failure ("__typename must be Enum" :: InternalError) -decodeFieldWith :: (ValidValue -> Eventless a) -> FieldName -> ValidObject -> Eventless a+withScalar ::+  (Applicative m, Failure InternalError m) =>+  TypeName ->+  (ScalarValue -> Either Token a) ->+  Value VALID ->+  m a+withScalar typename parseValue value = case toScalar value >>= parseValue of+  Right scalar -> pure scalar+  Left message ->+    failure+      ( typeMismatch+          ("SCALAR(" <> msg typename <> ")" <> msg message)+          value+      )++decodeFieldWith :: (Value VALID -> m a) -> FieldName -> ValidObject -> m a decodeFieldWith decoder = selectOr (decoder Null) (decoder . entryValue)++-- if value is already validated but value has different type+typeMismatch :: Message -> Value s -> InternalError+typeMismatch text jsType =+  "Type mismatch! expected:" <> msgInternal text <> ", got: "+    <> msgInternal jsType

@@ -14,12 +14,12 @@   )  --- Core-data ServerTypeDefinition cat = ServerTypeDefinition+data ServerTypeDefinition cat s = ServerTypeDefinition   { tName :: TypeName,     tNamespace :: [FieldName],-    typeArgD :: [ServerTypeDefinition IN],-    tCons :: [ConsD cat],+    typeArgD :: [ServerTypeDefinition IN s],+    tCons :: [ConsD cat s],     tKind :: TypeKind,-    typeOriginal :: Maybe (TypeDefinition ANY)+    typeOriginal :: Maybe (TypeDefinition ANY s)   }   deriving (Show)

@@ -0,0 +1,71 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.Internal.TH.Utils+  ( kindName,+    constraintTypeable,+    typeNameStringE,+    withPure,+    o',+    e',+    mkTypeableConstraints,+  )+where++import Data.Morpheus.Internal.TH+  ( apply,+    toName,+    vars,+  )+import Data.Morpheus.Kind+  ( ENUM,+    INPUT,+    INTERFACE,+    OUTPUT,+    SCALAR,+    WRAPPER,+  )+import Data.Morpheus.Types.Internal.AST+  ( TypeKind (..),+    TypeName (..),+  )+import Data.Text (unpack)+import Data.Typeable (Typeable)+import Language.Haskell.TH+  ( CxtQ,+    Exp (..),+    Lit (..),+    Name,+    Type (..),+    cxt,+  )++o' :: Type+o' = VarT $ toName ("oparation" :: TypeName)++e' :: Type+e' = VarT $ toName ("encodeEvent" :: TypeName)++withPure :: Exp -> Exp+withPure = AppE (VarE 'pure)++typeNameStringE :: TypeName -> Exp+typeNameStringE = LitE . StringL . (unpack . readTypeName)++constraintTypeable :: Type -> Type+constraintTypeable name = apply ''Typeable [name]++mkTypeableConstraints :: [TypeName] -> CxtQ+mkTypeableConstraints args = cxt $ map (pure . constraintTypeable) (vars args)++kindName :: TypeKind -> Name+kindName KindObject {} = ''OUTPUT+kindName KindScalar = ''SCALAR+kindName KindEnum = ''ENUM+kindName KindUnion = ''OUTPUT+kindName KindInputObject = ''INPUT+kindName KindList = ''WRAPPER+kindName KindNonNull = ''WRAPPER+kindName KindInputUnion = ''INPUT+kindName KindInterface = ''INTERFACE

@@ -0,0 +1,66 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Data.Morpheus.Server.Playground+  ( httpPlayground,+  )+where++import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Semigroup ((<>))++link :: ByteString -> ByteString -> ByteString+link rel href = "<link rel=\"" <> rel <> "\"  href=\"" <> href <> "\" />"++meta :: [(ByteString, ByteString)] -> ByteString+meta attr = t "meta" attr []++tag :: ByteString -> [ByteString] -> ByteString+tag tagName = t tagName []++t :: ByteString -> [(ByteString, ByteString)] -> [ByteString] -> ByteString+t tagName attr children =+  "<" <> tagName <> " " <> mconcat (map renderAttr attr) <> " >" <> mconcat children <> "</" <> tagName <> ">"+  where+    renderAttr (name, value) = name <> "=\"" <> value <> "\" "++script :: [(ByteString, ByteString)] -> [ByteString] -> ByteString+script = t "script"++html :: [ByteString] -> ByteString+html = docType . t "html" []++docType :: ByteString -> ByteString+docType x = "<!DOCTYPE html>" <> x++httpPlayground :: ByteString+httpPlayground =+  html+    [ tag+        "head"+        [ meta [("charset", "utf-8")],+          meta+            [ ("name", "viewport"),+              ("content", "user-scalable=no, initial-scale=1.0, minimum-scale=1.0, maximum-scale=1.0, minimal-ui")+            ],+          tag "title" ["GraphQL Playground"],+          link "stylesheet" "//cdn.jsdelivr.net/npm/graphql-playground-react/build/static/css/index.css",+          link "shortcut icon" "//cdn.jsdelivr.net/npm/graphql-playground-react/build/favicon.png",+          script+            [("src", "//cdn.jsdelivr.net/npm/graphql-playground-react/build/static/js/middleware.js")]+            []+        ],+      tag+        "body"+        [ t "div" [("id", "root")] [],+          script+            []+            [ "  window.addEventListener('load', (_) => \+              \    GraphQLPlayground.init(document.getElementById('root'), {}) \+              \  );"+            ]+        ]+    ]

@@ -13,6 +13,9 @@ import Data.Morpheus.Server.Internal.TH.Types   ( ServerTypeDefinition (..),   )+import Data.Morpheus.Server.TH.Declare.Channels+  ( deriveChannels,+  ) import Data.Morpheus.Server.TH.Declare.Decode   ( deriveDecode,   )@@ -46,13 +49,13 @@   type DeclareCtx [a] = DeclareCtx a   declare namespace = fmap concat . traverse (declare namespace) -instance Declare TypeDec where-  type DeclareCtx TypeDec = Bool+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) where-  type DeclareCtx (ServerTypeDefinition cat) = Bool+instance Declare (ServerTypeDefinition cat s) where+  type DeclareCtx (ServerTypeDefinition cat s) = Bool   declare namespace typeD@ServerTypeDefinition {tKind, typeArgD, typeOriginal} =     do       let mainType = declareType namespace typeD@@ -68,11 +71,11 @@             | isObject tKind && isInput tKind =               [deriveObjectRep typeD, deriveDecode typeD]             | isObject tKind =-              [deriveObjectRep typeD, deriveEncode typeD]+              [deriveObjectRep typeD, deriveEncode typeD, deriveChannels typeD]             | otherwise =               [] -declareArgTypes :: Bool -> [ServerTypeDefinition IN] -> Q [Dec]+declareArgTypes :: Bool -> [ServerTypeDefinition IN s] -> Q [Dec] declareArgTypes namespace types = do   introspectArgs <- concat <$> traverse deriveObjectRep types   decodeArgs <- concat <$> traverse deriveDecode types

@@ -0,0 +1,79 @@+{-# 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 []

@@ -14,8 +14,10 @@ -- MORPHEUS  import Data.Morpheus.Internal.TH-  ( instanceHeadT,-    nameVarP,+  ( applyCons,+    decodeObjectE,+    funDSimple,+    v',   ) import Data.Morpheus.Server.Deriving.Decode   ( Decode (..),@@ -23,29 +25,36 @@   ) import Data.Morpheus.Server.Internal.TH.Decode   ( decodeFieldWith,-    decodeObjectExpQ,-    withObject,+    withInputObject,   ) import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..)) import Data.Morpheus.Types.Internal.AST-  ( FieldName,+  ( ConsD (..),+    FieldName,+    TypeName,     ValidValue,   ) import Data.Morpheus.Types.Internal.Resolving-  ( Eventless,+  ( ResolverState,   ) import Language.Haskell.TH -(.:) :: Decode a => ValidValue -> FieldName -> Eventless a-value .: selectorName = withObject (decodeFieldWith decode selectorName) value+decodeFieldValue :: Decode a => ValidValue -> FieldName -> ResolverState a+decodeFieldValue value selectorName = withInputObject (decodeFieldWith decode selectorName) value -deriveDecode :: ServerTypeDefinition cat -> Q [Dec]-deriveDecode ServerTypeDefinition {tName, tCons = [cons]} =-  pure <$> instanceD (cxt []) appHead methods+mkTypeClass :: TypeName -> Q Type+mkTypeClass tName = applyCons ''DecodeType [tName]++decodeValueD :: ConsD cat s -> DecQ+decodeValueD ConsD {cName, cFields} = funDSimple 'decodeType [v'] body   where-    appHead = instanceHeadT ''DecodeType tName []-    methods = [funD 'decodeType [clause argsE (normalB body) []]]-      where-        argsE = map nameVarP ["o"]-        body = decodeObjectExpQ [|(.:)|] cons+    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 []

@@ -12,120 +12,96 @@ -- MORPHEUS  import Data.Morpheus.Internal.TH-  ( applyT,+  ( _',+    apply,     destructRecord,-    instanceHeadMultiT,-    mkTypeName,-    nameStringE,-    nameVarE,-    nameVarP,-    nameVarT,-    typeT,+    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.Types.GQLType (TRUE)+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 (..),-    QUERY,-    SUBSCRIPTION,+    TRUE,     TypeName (..),-    isSubscription,   ) import Data.Morpheus.Types.Internal.Resolving   ( LiftOperation,-    MapStrategy (..),-    ObjectResModel (..),-    ResModel (..),+    ResModel,     Resolver,+    mkObject,   ) import Data.Semigroup ((<>))-import Data.Typeable (Typeable) import Language.Haskell.TH -m_ :: TypeName-m_ = "m"+vars :: [Type]+vars = [o', e', m'] -fo_ :: TypeName-fo_ = "fieldOperationKind"+mkType :: TypeName -> Type+mkType tName = mainType+  where+    mainTypeArg = [apply ''Resolver vars]+    mainType = apply tName mainTypeArg -po_ :: TypeName-po_ = "parentOparation"+genHeadType :: TypeName -> [Type]+genHeadType tName = mkType tName : vars -e_ :: TypeName-e_ = "encodeEvent"+-- defines Constraint: (Monad m, ...)+mkConstrains :: TypeName -> [Type]+mkConstrains tName =+  [ apply ''Monad [m'],+    apply ''Encode (genHeadType tName),+    apply ''LiftOperation [o']+  ]+    <> map constraintTypeable [o', e', m'] -encodeVars :: [TypeName]-encodeVars = [e_, m_]+mkObjectE :: TypeName -> Exp -> Exp+mkObjectE name = AppE (AppE (VarE 'mkObject) (typeNameStringE name)) -encodeVarsT :: [TypeQ]-encodeVarsT = map nameVarT encodeVars+mkEntry ::+  Encode resolver o e m =>+  a ->+  resolver ->+  (a, Resolver o e m (ResModel o e m))+mkEntry name field = (name, encode field) -deriveEncode :: ServerTypeDefinition cat -> Q [Dec]-deriveEncode ServerTypeDefinition {tName, tCons = [ConsD {cFields}], tKind} =-  pure <$> instanceD (cxt constrains) appHead methods+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-    subARgs = conT ''SUBSCRIPTION : encodeVarsT-    instanceArgs-      | isSubscription tKind = subARgs-      | otherwise = map nameVarT (po_ : encodeVars)-    mainType = applyT (mkTypeName tName) [mainTypeArg]-      where-        mainTypeArg-          | isSubscription tKind = applyT ''Resolver subARgs-          | otherwise = typeT ''Resolver (fo_ : encodeVars)-    ------------------------------------------------------------------------------------------    typeables-      | isSubscription tKind =-        [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]]-      | otherwise =-        [ iLiftOp po_,-          iLiftOp fo_,-          typeT ''MapStrategy [fo_, po_],-          iTypeable fo_,-          iTypeable po_-        ]-    --------------------------    iLiftOp op = applyT ''LiftOperation [nameVarT op]-    --------------------------    iTypeable name = typeT ''Typeable [name]-    --------------------------------------------    -- defines Constraint: (Typeable m, Monad m)-    constrains =-      typeables-        <> [ typeT ''Monad [m_],-             applyT ''Encode (mainType : instanceArgs),-             iTypeable e_,-             iTypeable m_-           ]-    --------------------------------------------------------------------    -- defines: instance <constraint> =>  ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value) where-    appHead =-      instanceHeadMultiT-        ''ExploreResolvers-        (conT ''TRUE)-        (mainType : instanceArgs)-    -------------------------------------------------------------------    -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...]-    methods = [funD 'exploreResolvers [clause argsE (normalB body) []]]-      where-        argsE = [nameVarP "_", destructRecord tName varNames]-        body =-          appE (varE 'pure)-            $ appE-              (conE 'ResObject)-            $ appE-              ( appE-                  (conE 'ObjectResModel)-                  (nameStringE tName)-              )-              (listE $ map decodeVar varNames)-        decodeVar name = [|(name, encode $(varName))|]-          where-            varName = nameVarE name-        varNames = map fieldName cFields+    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 []

@@ -13,54 +13,47 @@ -- -- MORPHEUS import Data.Morpheus.Internal.TH-  ( instanceHeadT,-    instanceProxyFunD,-    mkTypeName,+  ( apply,+    applyVars,+    funDProxy,+    toName,     tyConArgs,     typeInstanceDec,-    typeT,   )-import Data.Morpheus.Kind-  ( ENUM,-    INPUT,-    INTERFACE,-    OUTPUT,-    SCALAR,-    WRAPPER,-  ) import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))+import Data.Morpheus.Server.Internal.TH.Utils+  ( kindName,+    mkTypeableConstraints,+  ) import Data.Morpheus.Server.Types.GQLType   ( GQLType (..),-    TRUE,   ) import Data.Morpheus.Types (Resolver, interface) import Data.Morpheus.Types.Internal.AST   ( ANY,     QUERY,+    TRUE,     TypeContent (..),     TypeDefinition (..),-    TypeKind (..),     TypeName,     isObject,   ) import Data.Proxy (Proxy (..)) import Data.Semigroup ((<>))-import Data.Typeable (Typeable) import Language.Haskell.TH  interfaceF :: Name -> ExpQ interfaceF name = [|interface (Proxy :: (Proxy ($(conT name) (Resolver QUERY () Maybe))))|]  introspectInterface :: TypeName -> ExpQ-introspectInterface = interfaceF . mkTypeName+introspectInterface = interfaceF . toName -deriveGQLType :: ServerTypeDefinition cat -> Q [Dec]+deriveGQLType :: ServerTypeDefinition cat s -> Q [Dec] deriveGQLType ServerTypeDefinition {tName, tKind, typeOriginal} =-  pure <$> instanceD (cxt constrains) iHead (functions <> typeFamilies)+  pure <$> instanceD constrains iHead (functions <> typeFamilies)   where     functions =-      map-        instanceProxyFunD+      funDProxy         [ ('__typeName, [|tName|]),           ('description, [|tDescription|]),           ('implements, implementsFunc)@@ -71,12 +64,10 @@     --------------------------------     typeArgs = tyConArgs tKind     ---------------------------------    iHead = instanceHeadT ''GQLType tName typeArgs-    headSig = typeT (mkTypeName tName) typeArgs+    iHead = apply ''GQLType [applyVars tName typeArgs]+    headSig = applyVars tName typeArgs     ----------------------------------------------------    constrains = map conTypeable typeArgs-      where-        conTypeable name = typeT ''Typeable [name]+    constrains = mkTypeableConstraints typeArgs     -------------------------------------------------     typeFamilies       | isObject tKind = [deriveKIND, deriveCUSTOM]@@ -90,17 +81,6 @@           typeN <- headSig           pure $ typeInstanceDec insName typeN (ConT tyName) -kindName :: TypeKind -> Name-kindName KindObject {} = ''OUTPUT-kindName KindScalar = ''SCALAR-kindName KindEnum = ''ENUM-kindName KindUnion = ''OUTPUT-kindName KindInputObject = ''INPUT-kindName KindList = ''WRAPPER-kindName KindNonNull = ''WRAPPER-kindName KindInputUnion = ''INPUT-kindName KindInterface = ''INTERFACE--interfacesFrom :: Maybe (TypeDefinition ANY) -> [TypeName]+interfacesFrom :: Maybe (TypeDefinition ANY s) -> [TypeName] interfacesFrom (Just TypeDefinition {typeContent = DataObject {objectImplements}}) = objectImplements interfacesFrom _ = []

@@ -13,84 +13,84 @@  -- MORPHEUS import Data.Morpheus.Internal.TH-  ( instanceFunD,-    instanceHeadMultiT,-    instanceProxyFunD,-    mkTypeName,-    nameConT,-    nameVarT,+  ( _',+    _2',+    apply,+    applyVars,+    cat',+    funDSimple,+    toCon,+    toVarT,     tyConArgs,-    typeT,   )+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.Types+  ( ServerTypeDefinition (..),+  )+import Data.Morpheus.Server.Internal.TH.Utils+  ( mkTypeableConstraints,+  ) import Data.Morpheus.Server.Types.GQLType   ( GQLType (__typeName, implements),-    TRUE,+    TypeUpdater,   ) import Data.Morpheus.Types.Internal.AST   ( ArgumentsDefinition (..),+    CONST,     ConsD (..),     FieldContent (..),     FieldDefinition (..),     IN,+    LEAF,     OUT,+    TRUE,     TypeContent (..),     TypeDefinition (..),     TypeKind (..),     TypeName,     TypeRef (..),-    TypeUpdater,     insertType,     unsafeFromFields,   )-import Data.Morpheus.Types.Internal.Resolving-  ( resolveUpdates,-  ) import Data.Proxy (Proxy (..))-import Data.Typeable (Typeable) import Language.Haskell.TH -cat_ :: TypeQ-cat_ = varT (mkName "cat")--instanceIntrospect :: Maybe (TypeDefinition cat) -> Q [Dec]+instanceIntrospect :: Maybe (TypeDefinition cat s) -> Q [Dec] instanceIntrospect (Just typeDef@TypeDefinition {typeName, typeContent = DataEnum {}}) =   pure <$> instanceD (cxt []) iHead [defineIntrospect]   where-    iHead = instanceHeadMultiT ''Introspect cat_ [conT $ mkTypeName typeName]-    defineIntrospect = instanceProxyFunD ('introspect, body)-      where-        body = [|insertType typeDef|]+    iHead = pure (apply ''Introspect [cat', toCon typeName])+    defineIntrospect = funDSimple 'introspect [_'] [|insertType (typeDef :: TypeDefinition LEAF CONST)|] instanceIntrospect _ = pure []  -- [(FieldDefinition, TypeUpdater)]-deriveObjectRep :: ServerTypeDefinition cat -> Q [Dec]+deriveObjectRep :: ServerTypeDefinition cat s -> Q [Dec] deriveObjectRep   ServerTypeDefinition     { tName,       tCons = [ConsD {cFields}],       tKind     } =-    pure <$> instanceD (cxt constrains) iHead methods+    pure <$> instanceD constrains iHead methods     where-      mainTypeName = typeT (mkTypeName tName) typeArgs+      mainTypeName = applyVars tName typeArgs       typeArgs = tyConArgs tKind-      constrains = map conTypeable typeArgs-        where-          conTypeable name = typeT ''Typeable [name]+      constrains = mkTypeableConstraints typeArgs       ------------------------------------------------      iHead = instanceHeadMultiT ''DeriveTypeContent instCat [conT ''TRUE, mainTypeName]+      iHead = apply ''DeriveTypeContent [instCat, conT ''TRUE, mainTypeName]       instCat         | tKind == KindInputObject =           conT ''IN         | otherwise = conT ''OUT-      methods = [instanceFunD 'deriveTypeContent ["_proxy1", "_proxy2"] body]+      methods = [funDSimple 'deriveTypeContent [_', _2'] body]         where           body             | tKind == KindInputObject =@@ -110,9 +110,9 @@ deriveObjectRep _ = pure []  deriveInputObject ::-  [FieldDefinition IN] ->+  [FieldDefinition IN s] ->   [TypeUpdater] ->-  ( TypeContent TRUE IN,+  ( TypeContent TRUE IN s,     [TypeUpdater]   ) deriveInputObject fields typeUpdates =@@ -121,9 +121,9 @@ deriveOutputObject ::   (GQLType a) =>   Proxy a ->-  [FieldDefinition OUT] ->+  [FieldDefinition OUT s] ->   [TypeUpdater] ->-  ( TypeContent TRUE OUT,+  ( TypeContent TRUE OUT s,     [TypeUpdater]   ) deriveOutputObject proxy fields typeUpdates =@@ -137,16 +137,16 @@ interfaceNames = map fst . implements  interfaceTypes :: GQLType a => Proxy a -> TypeUpdater-interfaceTypes = flip resolveUpdates . map snd . implements+interfaceTypes = concatUpdates . map snd . implements -buildTypes :: TypeQ -> [FieldDefinition cat] -> ExpQ+buildTypes :: TypeQ -> [FieldDefinition cat s] -> ExpQ buildTypes cat = listE . concatMap (introspectField cat) -introspectField :: TypeQ -> FieldDefinition cat -> [ExpQ]+introspectField :: TypeQ -> FieldDefinition cat s -> [ExpQ] introspectField cat FieldDefinition {fieldType, fieldContent} =   [|introspect $(proxyRepT cat fieldType)|] : inputTypes fieldContent   where-    inputTypes :: Maybe (FieldContent TRUE cat) -> [ExpQ]+    inputTypes :: Maybe (FieldContent TRUE cat s) -> [ExpQ]     inputTypes (Just (FieldArgs ArgumentsDefinition {argumentsTypename = Just argsTypeName}))       | argsTypeName /= "()" = [[|deriveCustomInputObjectType (argsTypeName, $(proxyT tAlias))|]]       where@@ -156,16 +156,16 @@ proxyRepT :: TypeQ -> TypeRef -> Q Exp proxyRepT cat TypeRef {typeConName, typeArgs} = [|(ProxyRep :: ProxyRep $(cat) $(genSig typeArgs))|]   where-    genSig (Just m) = appT (nameConT typeConName) (nameVarT m)-    genSig _ = nameConT typeConName+    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 (nameConT typeConName) (nameVarT m)-    genSig _ = nameConT typeConName+    genSig (Just m) = appT (toCon typeConName) (toVarT m)+    genSig _ = toCon typeConName -buildFields :: [FieldDefinition cat] -> ExpQ+buildFields :: [FieldDefinition cat s] -> ExpQ buildFields = listE . map buildField   where     buildField f@FieldDefinition {fieldType} = [|f {fieldType = fieldType {typeConName = __typeName $(proxyT fieldType)}}|]

@@ -11,10 +11,9 @@ import Data.Morpheus.Internal.TH   ( declareTypeRef,     m',-    mkFieldName,-    mkTypeName,     nameSpaceField,     nameSpaceType,+    toName,     tyConArgs,   ) import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))@@ -31,10 +30,13 @@     isOutputObject,     isSubscription,   )+import Data.Morpheus.Types.Internal.Resolving+  ( SubscriptionField,+  ) import GHC.Generics (Generic) import Language.Haskell.TH -declareType :: Bool -> ServerTypeDefinition cat -> [Dec]+declareType :: Bool -> ServerTypeDefinition cat s -> [Dec] declareType _ ServerTypeDefinition {tKind = KindScalar} = [] declareType namespace ServerTypeDefinition {tName, tCons, tKind, tNamespace} =   [ DataD@@ -48,7 +50,7 @@   where     tVars = declareTyVar (tyConArgs tKind)       where-        declareTyVar = map (PlainTV . mkTypeName)+        declareTyVar = map (PlainTV . toName)     cons = declareCons namespace tKind (tNamespace, tName) tCons  derive :: TypeKind -> [DerivClause]@@ -62,13 +64,13 @@ deriveClasses classNames = DerivClause Nothing (map ConT classNames)  mkNamespace :: [FieldName] -> TypeName -> Name-mkNamespace tNamespace = mkTypeName . nameSpaceType tNamespace+mkNamespace tNamespace = toName . nameSpaceType tNamespace  declareCons ::   Bool ->   TypeKind ->   ([FieldName], TypeName) ->-  [ConsD cat] ->+  [ConsD cat s] ->   [Con] declareCons namespace tKind (tNamespace, tName) = map consR   where@@ -81,7 +83,7 @@   Bool ->   TypeKind ->   TypeName ->-  FieldDefinition cat ->+  FieldDefinition cat s ->   (Name, Bang, Type) declareField namespace tKind tName field@FieldDefinition {fieldName} =   ( fieldTypeName namespace tName fieldName,@@ -91,30 +93,47 @@  renderFieldType ::   TypeKind ->-  FieldDefinition cat ->+  FieldDefinition cat s ->   Type renderFieldType tKind FieldDefinition {fieldContent, fieldType} =-  genFieldT-    (declareTypeRef (isSubscription tKind) fieldType)-    tKind-    fieldContent+  withFieldWrappers tKind fieldContent (declareTypeRef fieldType)  fieldTypeName :: Bool -> TypeName -> FieldName -> Name fieldTypeName namespace tName fieldName-  | namespace = mkFieldName (nameSpaceField tName fieldName)-  | otherwise = mkFieldName fieldName+  | namespace = toName (nameSpaceField tName fieldName)+  | otherwise = toName fieldName --------------------------------------------------genFieldT :: Type -> TypeKind -> Maybe (FieldContent TRUE cat) -> Type-genFieldT result _ (Just (FieldArgs ArgumentsDefinition {argumentsTypename = Just argsTypename})) =-  AppT-    (AppT arrowType argType)-    (AppT m' result)+-- withSubscriptionField: t => SubscriptionField t+withSubscriptionField :: TypeKind -> Type -> Type+withSubscriptionField kind x+  | isSubscription kind = AppT (ConT ''SubscriptionField) x+  | otherwise = x++-- withArgs: t => a -> t+withArgs :: TypeName -> Type -> Type+withArgs argsTypename = AppT (AppT arrowType argType)   where-    argType = ConT $ mkTypeName argsTypename+    argType = ConT $ toName argsTypename     arrowType = ConT ''Arrow-genFieldT result kind _-  | isOutputObject kind = AppT m' result-  | otherwise = result +-- withMonad: t => m t+withMonad :: Type -> Type+withMonad = AppT m'+ type Arrow = (->)++------------------------------------------------+withFieldWrappers ::+  TypeKind ->+  Maybe (FieldContent TRUE cat s) ->+  Type ->+  Type+withFieldWrappers kind (Just (FieldArgs ArgumentsDefinition {argumentsTypename = Just argsTypename})) =+  withArgs argsTypename+    . withSubscriptionField kind+    . withMonad+withFieldWrappers kind _+  | isOutputObject kind =+    withSubscriptionField kind+      . withMonad+  | otherwise = id

@@ -4,7 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}  module Data.Morpheus.Server.TH.Transform   ( toTHDefinitions,@@ -15,7 +14,7 @@ -- MORPHEUS import Data.Morpheus.Internal.TH   ( infoTyVars,-    mkTypeName,+    toName,   ) import Data.Morpheus.Internal.Utils   ( capitalTypeName,@@ -55,7 +54,7 @@ m_ :: TypeName m_ = "m" -getTypeArgs :: TypeName -> [TypeDefinition ANY] -> Q (Maybe TypeName)+getTypeArgs :: TypeName -> [TypeDefinition ANY s] -> Q (Maybe TypeName) getTypeArgs "__TypeKind" _ = pure Nothing getTypeArgs "Boolean" _ = pure Nothing getTypeArgs "String" _ = pure Nothing@@ -63,26 +62,30 @@ getTypeArgs "Float" _ = pure Nothing getTypeArgs key lib = case typeContent <$> lookupWith typeName key lib of   Just x -> pure (kindToTyArgs x)-  Nothing -> getTyArgs <$> reify (mkTypeName key)+  Nothing -> getTyArgs <$> reify (toName key)  getTyArgs :: Info -> Maybe TypeName getTyArgs x   | null (infoTyVars x) = Nothing   | otherwise = Just m_ -kindToTyArgs :: TypeContent TRUE ANY -> Maybe TypeName+kindToTyArgs :: TypeContent TRUE ANY s -> Maybe TypeName kindToTyArgs DataObject {} = Just m_ kindToTyArgs DataUnion {} = Just m_ kindToTyArgs DataInterface {} = Just m_ kindToTyArgs _ = Nothing -data TypeDec = InputType (ServerTypeDefinition IN) | OutputType (ServerTypeDefinition OUT)+data TypeDec s = InputType (ServerTypeDefinition IN s) | OutputType (ServerTypeDefinition OUT s) -toTHDefinitions :: Bool -> [TypeDefinition ANY] -> Q [TypeDec]+toTHDefinitions ::+  forall s.+  Bool ->+  [TypeDefinition ANY s] ->+  Q [TypeDec s] toTHDefinitions namespace schema = traverse generateType schema   where     ---------------------------------------------    generateType :: TypeDefinition ANY -> Q TypeDec+    generateType :: TypeDefinition ANY s -> Q (TypeDec s)     generateType       typeDef@TypeDefinition         { typeName,@@ -113,7 +116,7 @@                   ..                 } -mkObjectCons :: TypeName -> FieldsDefinition cat -> [ConsD cat]+mkObjectCons :: TypeName -> FieldsDefinition cat s -> [ConsD cat s] mkObjectCons typeName fields = [mkCons typeName fields]  mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName@@ -123,7 +126,11 @@   where     argTName = capitalTypeName (fieldName <> "Args") -mkObjectField :: [TypeDefinition ANY] -> (FieldName -> TypeName) -> FieldDefinition OUT -> Q (FieldDefinition OUT)+mkObjectField ::+  [TypeDefinition ANY s] ->+  (FieldName -> TypeName) ->+  FieldDefinition OUT s ->+  Q (FieldDefinition OUT s) mkObjectField schema genArgsTypeName FieldDefinition {fieldName, fieldContent = cont, fieldType = typeRef@TypeRef {typeConName}, ..} =   do     typeArgs <- getTypeArgs typeConName schema@@ -135,7 +142,7 @@           ..         }   where-    fieldCont :: FieldContent TRUE OUT -> Maybe (FieldContent TRUE OUT)+    fieldCont :: FieldContent TRUE OUT s -> Maybe (FieldContent TRUE OUT s)     fieldCont (FieldArgs ArgumentsDefinition {arguments})       | not (null arguments) =         Just $ FieldArgs $@@ -145,16 +152,16 @@             }     fieldCont _ = Nothing -data BuildPlan-  = ConsIN [ConsD IN]-  | ConsOUT [ServerTypeDefinition IN] [ConsD OUT]+data BuildPlan s+  = ConsIN [ConsD IN s]+  | ConsOUT [ServerTypeDefinition IN s] [ConsD OUT s]  genTypeContent ::-  [TypeDefinition ANY] ->+  [TypeDefinition ANY s] ->   (FieldName -> TypeName) ->   TypeName ->-  TypeContent TRUE ANY ->-  Q BuildPlan+  TypeContent TRUE ANY s ->+  Q (BuildPlan s) genTypeContent _ _ _ DataScalar {} = pure (ConsIN []) genTypeContent _ _ _ (DataEnum tags) = pure $ ConsIN (map mkConsEnum tags) genTypeContent _ _ typeName (DataInputObject fields) =@@ -194,11 +201,11 @@         cName = hsTypeName typeName <> utName         utName = hsTypeName memberName -genArgumentTypes :: (FieldName -> TypeName) -> FieldsDefinition OUT -> Q [ServerTypeDefinition IN]+genArgumentTypes :: (FieldName -> TypeName) -> FieldsDefinition OUT s -> Q [ServerTypeDefinition IN s] genArgumentTypes genArgsTypeName fields =   concat <$> traverse (genArgumentType genArgsTypeName) (elems fields) -genArgumentType :: (FieldName -> TypeName) -> FieldDefinition OUT -> Q [ServerTypeDefinition IN]+genArgumentType :: (FieldName -> TypeName) -> FieldDefinition OUT s -> Q [ServerTypeDefinition IN s] genArgumentType namespaceWith FieldDefinition {fieldName, fieldContent = Just (FieldArgs ArgumentsDefinition {arguments})}   | not (null arguments) =     pure

@@ -7,17 +7,17 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module Data.Morpheus.Server.Types.GQLType   ( GQLType (..),-    TRUE,-    FALSE,+    TypeUpdater,   ) where  import Data.Map (Map) -- MORPHEUS++import Data.Morpheus.Internal.Utils (UpdateT) import Data.Morpheus.Kind import Data.Morpheus.Server.Types.Types   ( MapKind,@@ -26,14 +26,18 @@   ) import Data.Morpheus.Types.ID (ID) import Data.Morpheus.Types.Internal.AST-  ( DataFingerprint (..),+  ( CONST,+    DataFingerprint (..),+    FALSE,     QUERY,+    Schema,     TypeName (..),-    TypeUpdater,     internalFingerprint,   ) import Data.Morpheus.Types.Internal.Resolving-  ( Resolver,+  ( Eventless,+    Resolver,+    SubscriptionField,   ) import Data.Proxy (Proxy (..)) import Data.Set (Set)@@ -53,9 +57,7 @@     typeRepTyCon,   ) -type TRUE = 'True--type FALSE = 'False+type TypeUpdater = UpdateT Eventless (Schema CONST)  resolverCon :: TyCon resolverCon = typeRepTyCon $ typeRep $ Proxy @(Resolver QUERY () Maybe)@@ -206,6 +208,11 @@  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)++instance GQLType a => GQLType (SubscriptionField a) where+  type KIND (SubscriptionField a) = WRAPPER   __typeName _ = __typeName (Proxy @a)   __typeFingerprint _ = __typeFingerprint (Proxy @a) 

@@ -31,9 +31,7 @@     publish,     subscribe,     unsafeInternalContext,-    Context (..),-    SubField,-    ComposedSubField,+    ResolverContext (..),     Input,     Stream,     WS,@@ -55,6 +53,7 @@     IOMutRes,     IOSubRes,     interface,+    SubscriptionField,   ) where @@ -62,7 +61,11 @@ import Data.Either (either) -- MORPHEUS -import Data.Morpheus.Server.Deriving.Introspect (Introspect (..), introspectOUT)+import Data.Morpheus.Server.Deriving.Introspect+  ( Introspect (..),+    TypeUpdater,+    introspectOUT,+  ) import Data.Morpheus.Server.Types.GQLType (GQLType (..)) import Data.Morpheus.Server.Types.Types (Undefined (..)) import Data.Morpheus.Types.GQLScalar@@ -84,19 +87,17 @@     SUBSCRIPTION,     ScalarValue (..),     TypeName,-    TypeUpdater,     msg,   ) import Data.Morpheus.Types.Internal.Resolving-  ( Context (..),-    Event (..),+  ( Event (..),     Failure,     PushEvents (..),     Resolver,-    UnSubResolver,+    ResolverContext (..),+    SubscriptionField,     WithOperation,     failure,-    lift,     pushEvents,     subscribe,     unsafeInternalContext,@@ -134,7 +135,7 @@  type ResolverM e m a = Flexible (Resolver MUTATION e m) a -type ResolverS e m a = Resolver SUBSCRIPTION e m (a (Resolver QUERY e m))+type ResolverS e m a = Flexible (Resolver SUBSCRIPTION e m) a  {-# DEPRECATED Res "use ResolverQ" #-} @@ -171,11 +172,6 @@ {-# DEPRECATED ResolveS "use ResolverS" #-}  type ResolveS e m a = ResolverS e m a---- Subsciption Object Resolver Fields-type SubField m a = (m (a (UnSubResolver m)))--type ComposedSubField m f a = (m (f (a (UnSubResolver m))))  publish :: Monad m => [e] -> Resolver MUTATION e m () publish = pushEvents

@@ -25,7 +25,6 @@     Store (..),     initDefaultStore,     publishEventWith,-    GQLChannel (..),     ClientConnectionStore,     empty,     toList,@@ -52,7 +51,7 @@   ( empty,   ) import Data.Morpheus.Types.Internal.Resolving-  ( GQLChannel (..),+  ( Event,   ) import Data.Morpheus.Types.Internal.Subscription.Apollo   ( acceptApolloRequest,@@ -95,21 +94,16 @@   }  publishEventWith ::-  ( MonadIO m,-    (Eq (StreamChannel event)),-    (GQLChannel event)-  ) =>-  Store event m ->-  event ->+  (MonadIO m, Eq channel) =>+  Store (Event channel cont) m ->+  Event channel cont ->   m () publishEventWith store event = readStore store >>= publish event  -- | initializes empty GraphQL state initDefaultStore ::   ( MonadIO m,-    MonadIO m2,-    (Eq (StreamChannel event)),-    (GQLChannel event)+    MonadIO m2   ) =>   m2 (Store event m) initDefaultStore = do

@@ -43,8 +43,8 @@   ) import Data.Morpheus.Types.Internal.Resolving   ( Event (..),-    GQLChannel (..),     SubEvent,+    eventChannels,   ) import Data.Morpheus.Types.Internal.Subscription.Apollo   ( toApolloResponse,@@ -78,12 +78,11 @@       <> " }"  publish ::-  ( Eq (StreamChannel event),-    GQLChannel event,-    Monad m+  ( Monad m,+    Eq channel   ) =>-  event ->-  ClientConnectionStore event m ->+  Event channel content ->+  ClientConnectionStore (Event channel content) m ->   m () publish event = traverse_ sendMessage . elems   where@@ -92,13 +91,13 @@       | otherwise = traverse_ send (filterByChannels connectionSessions)       where         send (sid, Event {content = subscriptionRes}) =-          toApolloResponse sid <$> subscriptionRes event >>= connectionCallback+          subscriptionRes event >>= connectionCallback . toApolloResponse sid         ---------------------------         filterByChannels =           filter             ( not                 . null-                . intersect (streamChannels event)+                . intersect (eventChannels event)                 . channels                 . snd             )@@ -149,8 +148,7 @@ toList :: ClientConnectionStore e m -> [(UUID, ClientConnection e m)] toList = HM.toList . unpackStore -instance KeyOf (ClientConnection e m) where-  type KEY (ClientConnection e m) = ID+instance KeyOf UUID (ClientConnection e m) where   keyOf = connectionId  instance Collection (ClientConnection e m) (ClientConnectionStore e m) where

@@ -37,13 +37,11 @@   ) import Data.Morpheus.Types.Internal.AST   ( GQLErrors,-    Message,     VALID,     Value (..),   ) import Data.Morpheus.Types.Internal.Resolving-  ( GQLChannel (..),-    ResponseEvent (..),+  ( ResponseEvent (..),     ResponseStream,     Result (..),     ResultT (..),@@ -108,9 +106,7 @@     Stream HTTP e m  handleResponseStream ::-  ( Eq (StreamChannel e),-    GQLChannel e,-    Monad m+  ( Monad m   ) =>   Session ->   ResponseStream e m (Value VALID) ->@@ -129,8 +125,6 @@  handleWSRequest ::   ( Monad m,-    Eq (StreamChannel e),-    GQLChannel e,     Functor m   ) =>   ( GQLRequest ->@@ -176,11 +170,7 @@   streamHTTP scope  toOutStream ::-  ( Monad m,-    Eq (StreamChannel e),-    GQLChannel e,-    Functor m-  ) =>+  (Monad m) =>   ( GQLRequest ->     ResponseStream e m (Value VALID)   ) ->@@ -196,9 +186,7 @@ toOutStream app (Request req) = StreamHTTP $ handleResponseHTTP (app req)  handleResponseHTTP ::-  ( Eq (StreamChannel e),-    GQLChannel e,-    Monad m+  ( Monad m   ) =>   ResponseStream e m (Value VALID) ->   Scope HTTP e m ->@@ -214,13 +202,10 @@       Failure err -> pure (Errors err)     where       execute (Publish event) = pure event-      execute Subscribe {} = failure ("http can't handle subscription" :: Message)+      execute Subscribe {} = failure (globalErrorMessage "http server can't handle subscription")  handleRes ::-  ( Eq (StreamChannel e),-    GQLChannel e,-    Monad m-  ) =>+  (Monad m) =>   ResponseStream e m a ->   (ResponseEvent e m -> ResultT e' m e') ->   ResultT e' m a

@@ -73,8 +73,8 @@       mutationResolver = Mutation {createUser = const user},       subscriptionResolver =         Subscription-          { newUser = subscribe [Channel] (pure $ const user),-            newAddress = subscribe [Channel] (pure resolveAddress)+          { newUser = subscribe Channel (pure $ const user),+            newAddress = subscribe Channel (pure resolveAddress)           }     }   where

@@ -4,5 +4,5 @@   } } fragment UserFragment on Address {-  aText+  houseNumber }

@@ -1,9 +1,8 @@ {-  "errors": [{-    "message": "Fragment \"UserFragment\" cannot be spread here as objects of type \"User\" can never be of type \"Address\".",-    "locations": [{-      "line": 3,-      "column": 5-    }]-  }]+  "errors": [+    {+      "message": "Fragment \"UserFragment\" cannot be spread here as objects of type \"User\", \"Person\" can never be of type \"Address\".",+      "locations": [{ "line": 3, "column": 5 }]+    }+  ] }

@@ -1,13 +1,8 @@ {   "errors": [     {-      "message": "Fragment cannot be spread here as objects of type \"User\" can never be of type \"Address\".",-      "locations": [-        {-          "line": 3,-          "column": 5-        }-      ]+      "message": "Fragment cannot be spread here as objects of type \"User\", \"Person\" can never be of type \"Address\".",+      "locations": [{ "line": 3, "column": 5 }]     }   ] }

@@ -1,32 +1,12 @@ {   "errors": [     {-      "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [null, [[], [{uid: \"1\"}]]].",-      "locations": [{ "line": 8, "column": 23 }]-    },-    {-      "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [].",-      "locations": [{ "line": 11, "column": 23 }]-    },-    {-      "message": "Argument \"cityID\" got invalid value. Expected type \"TestEnum!\" found HH.",-      "locations": [{ "line": 15, "column": 25 }]-    },-    {-      "message": "Variable \"$v\" of type \"[[[ID!]]!]\" used in position expecting type \"[Int!]\".",-      "locations": [{ "line": 15, "column": 21 }]-    },-    {-      "message": "Cannot query field \"home\" on type \"User\".",-      "locations": [{ "line": 25, "column": 5 }]-    },-    {-      "message": "Cannot query field \"myUnion\" on type \"User\".",-      "locations": [{ "line": 26, "column": 5 }]+      "message": "Field \"street\" argument \"argInputObject\" is required but not provided.",+      "locations": [{ "line": 54, "column": 3 }]     },     {       "message": "Cannot query field \"myUnion\" on type \"User\".",-      "locations": [{ "line": 32, "column": 5 }]+      "locations": [{ "line": 43, "column": 3 }]     }   ] }

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=51:\nunexpected '@'\nexpecting '#', ')', ',', Argument, IgnoredTokens, or white space\n",+      "message": "offset=51:\nunexpected '@'\nexpecting ')', Argument, Ignored, IgnoredTokens, or white space\n",       "locations": [         {           "line": 2,

@@ -1,13 +1,8 @@ {   "errors": [     {-      "message": "offset=22:\nunexpected '@'\nexpecting '!', '#', ')', ',', '=', IgnoredTokens, VariableDefinition, or white space\n",-      "locations": [-        {-          "line": 1,-          "column": 23-        }-      ]+      "message": "offset=22:\nunexpected '@'\nexpecting '!', ')', '=', Ignored, IgnoredTokens, VariableDefinition, or white space\n",+      "locations": [{ "line": 1, "column": 23 }]     }   ] }

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Arguments, Directives, IgnoredTokens, Selection, SelectionContent, digit, letter, or white space\n",+      "message": "offset=26:\nunexpected '<'\nexpecting '_', '}', Arguments, Directives, Ignored, IgnoredTokens, Selection, SelectionContent, digit, letter, or white space\n",       "locations": [{ "line": 1, "column": 27 }]     }   ]

@@ -1,13 +1,8 @@ {   "errors": [     {-      "message": "offset=20:\nunexpected '@'\nexpecting '!', '#', ']', '_', IgnoredTokens, digit, letter, or white space\n",-      "locations": [-        {-          "line": 1,-          "column": 21-        }-      ]+      "message": "offset=20:\nunexpected '@'\nexpecting '!', ']', '_', Ignored, IgnoredTokens, digit, letter, or white space\n",+      "locations": [{ "line": 1, "column": 21 }]     }   ] }

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=66:\nunexpected end of input\nexpecting '#', ',', '}', Selection, or white space\n",+      "message": "offset=66:\nunexpected end of input\nexpecting '}', Ignored, IgnoredTokens, Selection, or white space\n",       "locations": [         {           "line": 5,

@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module Feature.Input.Enum.API   ( api,

@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module Feature.Input.Object.API   ( api,

@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module Feature.Input.Scalar.API   ( api,@@ -17,6 +16,7 @@     RootResolver (..),     Undefined (..),   )+import Data.Text (Text) import GHC.Generics (Generic)  -- types & args@@ -32,14 +32,20 @@ -- resolver data Query m = Query   { testFloat :: Arg Float -> m Float,-    testInt :: Arg Int -> m Int+    testInt :: Arg Int -> m Int,+    testString :: Arg Text -> m Text   }   deriving (Generic, GQLType)  rootResolver :: RootResolver IO () Query Undefined Undefined rootResolver =   RootResolver-    { queryResolver = Query {testFloat = testRes, testInt = testRes},+    { queryResolver =+        Query+          { testFloat = testRes,+            testInt = testRes,+            testString = testRes+          },       mutationResolver = Undefined,       subscriptionResolver = Undefined     }

@@ -1,10 +1,30 @@ [   {-    "path": "decodeFloat",+    "path": "numbers/decodeFloat",     "description": "test signed float and float with expotential"   },   {-    "path": "decodeInt",+    "path": "numbers/decodeInt",     "description": "test signed int and int with expotential"+  },+  {+    "path": "strings/block",+    "description": "parse block string"+  },+  {+    "path": "strings/escaped",+    "description": "parse escaped string string"+  },+  {+    "path": "strings/regular",+    "description": "parse regular string string"+  },+  {+    "path": "strings/wrong-newline",+    "description": "fail on newline on sinle line string"+  },+  {+    "path": "strings/wrong-escaped",+    "description": "fail on unsupported escaped char on sinle line string"   } ]

@@ -1,7 +0,0 @@-query ValidDecoding {-  one: testFloat(value: 1.00)-  negOne: testFloat(value: -1)-  negNummber: testFloat(value: -1.235)-  expNumber: testFloat(value: 0.3e5)-  negExpNumber: testFloat(value: - 0.12e-35)-}

@@ -1,9 +0,0 @@-{-  "data": {-    "one": 1,-    "negOne": -1,-    "negNummber": -1.235,-    "expNumber": 30000,-    "negExpNumber": -1.2e-36-  }-}

@@ -1,7 +0,0 @@-query ValidDecoding {-  one: testInt(value: 1)-  negOne: testInt(value: -1)-  negNummber: testInt(value: -1235)-  expNumber: testInt(value: 123e5)-  negExpNumber: testInt(value: - 123e5)-}

@@ -1,9 +0,0 @@-{-  "data": {-    "one": 1,-    "negOne": -1,-    "negNummber": -1235,-    "expNumber": 12300000,-    "negExpNumber": -12300000-  }-}

@@ -0,0 +1,7 @@+query ValidDecoding {+  one: testFloat(value: 1.00)+  negOne: testFloat(value: -1)+  negNummber: testFloat(value: -1.235)+  expNumber: testFloat(value: 0.3e5)+  negExpNumber: testFloat(value: - 0.12e-35)+}

@@ -0,0 +1,9 @@+{+  "data": {+    "one": 1,+    "negOne": -1,+    "negNummber": -1.235,+    "expNumber": 30000,+    "negExpNumber": -1.2e-36+  }+}

@@ -0,0 +1,7 @@+query ValidDecoding {+  one: testInt(value: 1)+  negOne: testInt(value: -1)+  negNummber: testInt(value: -1235)+  expNumber: testInt(value: 123e5)+  negExpNumber: testInt(value: - 123e5)+}

@@ -0,0 +1,9 @@+{+  "data": {+    "one": 1,+    "negOne": -1,+    "negNummber": -1235,+    "expNumber": 12300000,+    "negExpNumber": -12300000+  }+}

@@ -0,0 +1,20 @@+query ValidDecoding {+  simple: testString(+    value: """+    bla bla \n+    """+  )+  sophisticated: testString(+    value: """+    ewrwe+        sdfd+        werte+      erqewr+++      this is some text++      bla+          bla+    """+  )+}

@@ -0,0 +1,6 @@+{+  "data": {+    "simple": "\n    bla bla \\n\n    ",+    "sophisticated": "\n    ewrwe\n        sdfd\n        werte\n      erqewr+\n\n      this is some text\n\n      bla\n          bla\n    "+  }+}

@@ -0,0 +1,3 @@+query ValidDecoding {+  testString(value: " a b  \n \\ / bla  ")+}

@@ -0,0 +1,1 @@+{ "data": { "testString": " a b  \n \\ / bla  " } }

@@ -0,0 +1,3 @@+query ValidDecoding {+  testString(value: "some string bla b jasd qweq ")+}

@@ -0,0 +1,5 @@+{+  "data": {+    "testString": "some string bla b jasd qweq "+  }+}

@@ -0,0 +1,3 @@+query ValidDecoding {+  testString(value: " a b  \k  / bla  ")+}

@@ -0,0 +1,8 @@+{+  "errors": [+    {+      "message": "offset=50:\nunexpected 'k'\nexpecting '\"', '/', '\\', 'b', 'f', 'n', 'r', or 't'\n",+      "locations": [{ "line": 2, "column": 29 }]+    }+  ]+}

@@ -0,0 +1,7 @@+query ValidDecoding {+  testString+    (value: +      "some string bla b +      jasd qweq "+    )+}

@@ -0,0 +1,8 @@+{+  "errors": [+    {+      "message": "offset=73:\nunexpected newline\nexpecting '\"' or EscapedChar\n",+      "locations": [{ "line": 4, "column": 26 }]+    }+  ]+}

@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module Feature.InputType.API   ( api,

@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module Feature.Schema.API   ( api,

@@ -4,7 +4,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module Feature.TypeInference.API   ( api,

@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module Feature.UnionType.API   ( api,

@@ -5,5 +5,5 @@ }  fragment FC on C {-  aText+  cText }

@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module Feature.WrappedTypeName.API   ( api,@@ -11,12 +10,12 @@  import Data.Morpheus (interpreter) import Data.Morpheus.Types-  ( ComposedSubField,-    Event,+  ( Event,     GQLRequest,     GQLResponse,     GQLType (..),     RootResolver (..),+    SubscriptionField,     constRes,     subscribe,   )@@ -60,9 +59,9 @@ type EVENT = Event Channel ()  data Subscription (m :: * -> *) = Subscription-  { sub1 :: ComposedSubField m Maybe WA,-    sub2 :: m (Maybe Wrapped1),-    sub3 :: m (Maybe Wrapped2)+  { sub1 :: SubscriptionField (m (Maybe (WA m))),+    sub2 :: SubscriptionField (m (Maybe Wrapped1)),+    sub3 :: SubscriptionField (m (Maybe Wrapped2))   }   deriving (Generic, GQLType) @@ -73,9 +72,9 @@       mutationResolver = Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing},       subscriptionResolver =         Subscription-          { sub1 = subscribe [Channel] (pure $ constRes Nothing),-            sub2 = subscribe [Channel] (pure $ constRes Nothing),-            sub3 = subscribe [Channel] (pure $ constRes Nothing)+          { sub1 = subscribe Channel (pure $ constRes Nothing),+            sub2 = subscribe Channel (pure $ constRes Nothing),+            sub3 = subscribe Channel (pure $ constRes Nothing)           }     } 

@@ -11,15 +11,14 @@ {-# LANGUAGE TypeFamilies #-}  module Rendering.Schema-  ( schemaProxy,+  ( proxy,+    path,   ) where  import Data.Morpheus.Document (importGQLDocumentWithNamespace)-import Data.Morpheus.Kind (SCALAR) import Data.Morpheus.Types   ( GQLScalar (..),-    GQLType (..),     ID (..),     RootResolver (..),     ScalarValue (..),@@ -33,14 +32,14 @@   = TestScalar   deriving (Show, Generic) -instance GQLType TestScalar where-  type KIND TestScalar = SCALAR- instance GQLScalar TestScalar where   parseValue _ = pure TestScalar   serialize TestScalar = Int 0  importGQLDocumentWithNamespace "test/Rendering/schema.gql" -schemaProxy :: Proxy (RootResolver IO () Query Undefined Undefined)-schemaProxy = Proxy @(RootResolver IO () Query Undefined Undefined)+path :: String+path = "test/Rendering/schema.gql"++proxy :: Proxy (RootResolver IO () Query Undefined Undefined)+proxy = Proxy @(RootResolver IO () Query Undefined Undefined)

@@ -1,19 +1,20 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Rendering.TestSchemaRendering   ( testSchemaRendering,   ) where +import Data.ByteString.Lazy.Char8 (readFile) import Data.Morpheus.Document (toGraphQLDocument)-import Rendering.Schema (schemaProxy)+import Rendering.Schema (path, proxy) import Test.Tasty (TestTree) import Test.Tasty.HUnit (assertEqual, testCase)+import Prelude (($)) --- TODO: better Test testSchemaRendering :: TestTree-testSchemaRendering = testCase "Test Rendering" $ assertEqual "test schema Rendering" expected schema-  where-    schema = toGraphQLDocument schemaProxy-    expected =-      "enum TestEnum { \n  EnumA\n  EnumB\n  EnumC\n}\n\ntype Address { \n  street: [[[[String!]!]!]]\n}\n\ninput Coordinates { \n  latitude: TestScalar!\n  longitude: Int!\n}\n\ntype User { \n  type: String!\n  address(coordinates: Coordinates!, type: String): Int!\n  friend(id: ID!, cityID: TestEnum): User!\n}\n\ntype Query { \n  user: User!\n  testUnion: TestUnion\n}\n\nunion TestUnion =\n    User\n  | Address\n\nscalar TestScalar"+testSchemaRendering = testCase "Test Rendering" $ do+  let schema = toGraphQLDocument proxy+  expected <- readFile path+  assertEqual "test schema Rendering" expected schema

@@ -4,22 +4,24 @@   EnumC } +type Address {+  street: [[[[String!]!]!]]+}+ input Coordinates {   latitude: TestScalar!   longitude: Int! } -union TestUnion = User | Address--type Address {-    street: [[[[String!]!]!]]-}- type User {   type: String!   address(coordinates: Coordinates!, type: String): Int!-  friend(id: ID! , cityID: TestEnum): User!+  friend(id: ID!, cityID: TestEnum): User! }++union TestUnion = User | Address++scalar TestScalar  type Query {   user: User!

@@ -63,8 +63,8 @@           },       subscriptionResolver =         Subscription-          { newDeity = subscribe [DEITY] (pure characterSub),-            newHuman = subscribe [HUMAN] (pure characterSub)+          { newDeity = subscribe DEITY (pure characterSub),+            newHuman = subscribe HUMAN (pure characterSub)           }     } 

@@ -10,12 +10,12 @@  import Data.ByteString.Lazy.Char8 (ByteString) import Data.Morpheus.Types-  ( Input,+  ( Event,+    Input,     Stream,   ) import Data.Morpheus.Types.Internal.Subscription-  ( GQLChannel (..),-    WS,+  ( WS,   ) import Subscription.Utils   ( SimulationState (..),@@ -37,10 +37,8 @@   )  testUnknownType ::-  ( Eq (StreamChannel e),-    GQLChannel e-  ) =>-  (Input WS -> Stream WS e (SubM e)) ->+  (Eq ch) =>+  (Input WS -> Stream WS (Event ch a) (SubM (Event ch a))) ->   IO TestTree testUnknownType =   testSimulation@@ -58,10 +56,8 @@         ]  testConnectionInit ::-  ( Eq (StreamChannel e),-    GQLChannel e-  ) =>-  (Input WS -> Stream WS e (SubM e)) ->+  (Eq ch) =>+  (Input WS -> Stream WS (Event ch a) (SubM (Event ch a))) ->   IO TestTree testConnectionInit = testSimulation test [apolloInit]   where@@ -80,10 +76,8 @@ startSub = apolloStart "subscription MySubscription { newDeity { name }}"  testSubscriptionStart ::-  ( Eq (StreamChannel e),-    GQLChannel e-  ) =>-  (Input WS -> Stream WS e (SubM e)) ->+  (Eq ch) =>+  (Input WS -> Stream WS (Event ch a) (SubM (Event ch a))) ->   IO TestTree testSubscriptionStart =   testSimulation@@ -107,10 +101,8 @@         ]  testSubscriptionStop ::-  ( Eq (StreamChannel e),-    GQLChannel e-  ) =>-  (Input WS -> Stream WS e (SubM e)) ->+  (Eq ch) =>+  (Input WS -> Stream WS (Event ch a) (SubM (Event ch a))) ->   IO TestTree testSubscriptionStop =   testSimulation@@ -135,10 +127,8 @@         ]  testApolloRequest ::-  ( Eq (StreamChannel e),-    GQLChannel e-  ) =>-  (Input WS -> Stream WS e (SubM e)) ->+  (Eq ch) =>+  (Input WS -> Stream WS (Event ch a) (SubM (Event ch a))) ->   IO TestTree testApolloRequest api = do   unknownType <- testUnknownType api

@@ -37,12 +37,12 @@   ( isJust,   ) import Data.Morpheus.Types-  ( Input,+  ( Event,+    Input,     Stream,   ) import Data.Morpheus.Types.Internal.Subscription   ( ClientConnectionStore,-    GQLChannel (..),     Input (..),     Scope (..),     SessionID,@@ -100,10 +100,10 @@     (api input)  simulatePublish ::-  (GQLChannel e, Eq (StreamChannel e)) =>-  e ->-  SimulationState e ->-  IO (SimulationState e)+  Eq ch =>+  Event ch con ->+  SimulationState (Event ch con) ->+  IO (SimulationState (Event ch con)) simulatePublish event s = snd <$> runStateT (publish event (store s)) s  simulate ::@@ -112,7 +112,7 @@   SimulationState e ->   IO (SimulationState e) simulate _ _ s@SimulationState {inputs = []} = pure s-simulate api input s = snd <$> runStateT (wsApp api input) s >>= simulate api input+simulate api input s = runStateT (wsApp api input) s >>= simulate api input . snd  testSimulation ::   (Input WS -> SimulationState e -> TestTree) ->