morpheus-graphql 0.6.2 → 0.7.0

raw patch · 122 files changed

+6828/−4913 lines, 122 filesdep +th-lift-instancesPVP ok

version bump matches the API change (PVP)

Dependencies added: th-lift-instances

API changes (from Hackage documentation)

Files

• README.md +41/−29
• changelog.md +133/−0
• morpheus-graphql.cabal +24/−19
• src/Data/Morpheus.hs +4/−2
• src/Data/Morpheus/Client.hs +32/−25
• src/Data/Morpheus/Document.hs +55/−31
• src/Data/Morpheus/Error/Arguments.hs +33/−27
• src/Data/Morpheus/Error/Client/Client.hs +50/−6
• src/Data/Morpheus/Error/Document/Interface.hs +32/−16
• src/Data/Morpheus/Error/Fragment.hs +52/−49
• src/Data/Morpheus/Error/Input.hs +33/−28
• src/Data/Morpheus/Error/Internal.hs +24/−15
• src/Data/Morpheus/Error/Mutation.hs +7/−4
• src/Data/Morpheus/Error/Schema.hs +11/−8
• src/Data/Morpheus/Error/Selection.hs +47/−24
• src/Data/Morpheus/Error/Subscription.hs +7/−4
• src/Data/Morpheus/Error/Utils.hs +26/−18
• src/Data/Morpheus/Error/Variable.hs +53/−50
• src/Data/Morpheus/Execution/Client/Aeson.hs +108/−90
• src/Data/Morpheus/Execution/Client/Build.hs +64/−34
• src/Data/Morpheus/Execution/Client/Compile.hs +48/−25
• src/Data/Morpheus/Execution/Client/Fetch.hs +29/−19
• src/Data/Morpheus/Execution/Client/Selection.hs +282/−181
• src/Data/Morpheus/Execution/Document/Compile.hs +42/−28
• src/Data/Morpheus/Execution/Document/Convert.hs +166/−126
• src/Data/Morpheus/Execution/Document/Declare.hs +54/−38
• src/Data/Morpheus/Execution/Document/Decode.hs +28/−15
• src/Data/Morpheus/Execution/Document/Encode.hs +85/−52
• src/Data/Morpheus/Execution/Document/GQLType.hs +75/−55
• src/Data/Morpheus/Execution/Document/Introspect.hs +24/−13
• src/Data/Morpheus/Execution/Internal/Declare.hs +76/−58
• src/Data/Morpheus/Execution/Internal/Decode.hs +50/−38
• src/Data/Morpheus/Execution/Internal/GraphScanner.hs +0/−14
• src/Data/Morpheus/Execution/Internal/Utils.hs +13/−8
• src/Data/Morpheus/Execution/Server/Decode.hs +57/−35
• src/Data/Morpheus/Execution/Server/Encode.hs +157/−95
• src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs +12/−8
• src/Data/Morpheus/Execution/Server/Interpreter.hs +49/−28
• src/Data/Morpheus/Execution/Server/Introspect.hs +117/−94
• src/Data/Morpheus/Execution/Server/Resolve.hs +188/−112
• src/Data/Morpheus/Execution/Subscription/ClientRegister.hs +84/−69
• src/Data/Morpheus/Kind.hs +5/−3
• src/Data/Morpheus/Parsing/Document/Parser.hs +28/−19
• src/Data/Morpheus/Parsing/Document/TypeSystem.hs +137/−129
• src/Data/Morpheus/Parsing/Internal/Create.hs +0/−67
• src/Data/Morpheus/Parsing/Internal/Internal.hs +40/−19
• src/Data/Morpheus/Parsing/Internal/Pattern.hs +101/−40
• src/Data/Morpheus/Parsing/Internal/Terms.hs +103/−72
• src/Data/Morpheus/Parsing/Internal/Value.hs +64/−49
• src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +81/−54
• src/Data/Morpheus/Parsing/Request/Arguments.hs +37/−19
• src/Data/Morpheus/Parsing/Request/Operation.hs +86/−57
• src/Data/Morpheus/Parsing/Request/Parser.hs +51/−34
• src/Data/Morpheus/Parsing/Request/Selection.hs +95/−62
• src/Data/Morpheus/Rendering/Haskell/Render.hs +0/−87
• src/Data/Morpheus/Rendering/Haskell/Terms.hs +0/−85
• src/Data/Morpheus/Rendering/Haskell/Types.hs +0/−93
• src/Data/Morpheus/Rendering/Haskell/Values.hs +0/−84
• src/Data/Morpheus/Rendering/RenderGQL.hs +71/−42
• src/Data/Morpheus/Rendering/RenderIntrospection.hs +190/−151
• src/Data/Morpheus/Schema/Schema.hs +8/−5
• src/Data/Morpheus/Schema/SchemaAPI.hs +75/−48
• src/Data/Morpheus/Schema/TypeKind.hs +5/−4
• src/Data/Morpheus/Server.hs +75/−49
• src/Data/Morpheus/Types.hs +44/−20
• src/Data/Morpheus/Types/Custom.hs +0/−44
• src/Data/Morpheus/Types/GQLScalar.hs +10/−5
• src/Data/Morpheus/Types/GQLType.hs +41/−27
• src/Data/Morpheus/Types/ID.hs +12/−8
• src/Data/Morpheus/Types/IO.hs +35/−22
• src/Data/Morpheus/Types/Internal/AST.hs +162/−0
• src/Data/Morpheus/Types/Internal/AST/Base.hs +55/−0
• src/Data/Morpheus/Types/Internal/AST/Data.hs +659/−0
• src/Data/Morpheus/Types/Internal/AST/Operation.hs +48/−22
• src/Data/Morpheus/Types/Internal/AST/RawSelection.hs +0/−61
• src/Data/Morpheus/Types/Internal/AST/Selection.hs +62/−14
• src/Data/Morpheus/Types/Internal/AST/Value.hs +156/−0
• src/Data/Morpheus/Types/Internal/Base.hs +0/−58
• src/Data/Morpheus/Types/Internal/Data.hs +0/−338
• src/Data/Morpheus/Types/Internal/DataD.hs +0/−37
• src/Data/Morpheus/Types/Internal/Resolver.hs +0/−263
• src/Data/Morpheus/Types/Internal/Resolving.hs +34/−0
• src/Data/Morpheus/Types/Internal/Resolving/Core.hs +160/−0
• src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +382/−0
• src/Data/Morpheus/Types/Internal/Stream.hs +0/−117
• src/Data/Morpheus/Types/Internal/TH.hs +5/−17
• src/Data/Morpheus/Types/Internal/Validation.hs +0/−34
• src/Data/Morpheus/Types/Internal/Value.hs +0/−195
• src/Data/Morpheus/Types/Internal/WebSocket.hs +15/−10
• src/Data/Morpheus/Types/Types.hs +38/−25
• src/Data/Morpheus/Validation/Document/Validation.hs +65/−41
• src/Data/Morpheus/Validation/Internal/Utils.hs +23/−53
• src/Data/Morpheus/Validation/Internal/Value.hs +98/−62
• src/Data/Morpheus/Validation/Query/Arguments.hs +137/−80
• src/Data/Morpheus/Validation/Query/Fragment.hs +92/−67
• src/Data/Morpheus/Validation/Query/Selection.hs +190/−122
• src/Data/Morpheus/Validation/Query/Utils/Selection.hs +0/−32
• src/Data/Morpheus/Validation/Query/Validation.hs +45/−38
• src/Data/Morpheus/Validation/Query/Variable.hs +132/−85
• test/Feature/Holistic/API.gql +0/−51
• test/Feature/Holistic/API.hs +43/−30
• test/Feature/Holistic/cases.json +24/−0
• test/Feature/Holistic/fragment/loopingFragment/response.json +4/−13
• test/Feature/Holistic/introspection/deprecated/enumValue/query.gql +9/−0
• test/Feature/Holistic/introspection/deprecated/enumValue/response.json +15/−0
• test/Feature/Holistic/introspection/deprecated/field/query.gql +9/−0
• test/Feature/Holistic/introspection/deprecated/field/response.json +19/−0
• test/Feature/Holistic/introspection/description/enum/query.gql +9/−0
• test/Feature/Holistic/introspection/description/enum/response.json +12/−0
• test/Feature/Holistic/introspection/description/inputObject/query.gql +9/−0
• test/Feature/Holistic/introspection/description/inputObject/response.json +17/−0
• test/Feature/Holistic/introspection/description/object/query.gql +13/−0
• test/Feature/Holistic/introspection/description/object/response.json +26/−0
• test/Feature/Holistic/introspection/description/union/query.gql +5/−0
• test/Feature/Holistic/introspection/description/union/response.json +7/−0
• test/Feature/Holistic/introspection/kinds/ENUM/response.json +4/−12
• test/Feature/Holistic/introspection/kinds/OBJECT/response.json +7/−22
• test/Feature/Holistic/parsing/complex/response.json +21/−6
• test/Feature/Holistic/parsing/extraCommas/response.json +25/−6
• test/Feature/Holistic/schema.gql +103/−0
• test/Feature/InputType/API.hs +22/−13
• test/Rendering/TestSchemaRendering.hs +1/−1

@@ -29,7 +29,7 @@ resolver: lts-14.8  extra-deps:-  - morpheus-graphql-0.6.2+  - morpheus-graphql-0.7.0 ```  As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update`@@ -45,9 +45,15 @@   deity(name: String!): Deity! } +"""+Description for Deity+""" type Deity {+  """+  Description for name+  """   name: String!-  power: String+  power: String String! @deprecated(reason: "some reason for") } ``` @@ -95,6 +101,8 @@  Template Haskell Generates types: `Query` , `Deity`, `DeityArgs`, that can be used by `rootResolver` +`descriptions` and `deprecations` will be displayed in intropsection.+ `importGQLDocumentWithNamespace` will generate Types with namespaced fields. if you don't need napespacing use `importGQLDocument`  ### with Native Haskell Types@@ -138,7 +146,7 @@  ```haskell resolveDeity :: DeityArgs -> IORes e Deity-resolveDeity DeityArgs { name, mythology } = liftEitherM $ dbDeity name mythology+resolveDeity DeityArgs { name, mythology } = liftEither $ dbDeity name mythology  askDB :: Text -> Maybe Text -> IO (Either String Deity) askDB = ...@@ -281,25 +289,23 @@ ### Mutations  In addition to queries, Morpheus also supports mutations. The behave just like regular queries and are defined similarly:-Just exchange deriving `GQLQuery` for `GQLMutation` and declare them separately at the `GQLRootResolver` definition  ```haskell newtype Mutation m = Mutation-  { createDeity :: Form -> m Deity+  { createDeity :: MutArgs -> m Deity   } deriving (Generic, GQLType) -createDeityMutation :: Form -> m (Deity m)-createDeityMutation = ...--rootResolver :: GQLRootResolver IO Query Mutation Undefined+rootResolver :: GQLRootResolver IO  () Query Mutation Undefined rootResolver =   GQLRootResolver     { queryResolver = Query {...}-    , mutationResolver = Mutation {-       createDeity = createDeityMutation-    }+    , mutationResolver = Mutation { createDeity }     , subscriptionResolver = Undefined     }+    where+      -- Mutation Without Event Triggering+      createDeity :: MutArgs -> ResolveM () IO Deity+      createDeity_args = lift setDBAddress  gqlApi :: ByteString -> IO ByteString gqlApi = interpreter rootResolver@@ -321,6 +327,8 @@   = ContentA Int   | ContentB Text +type MyEvent = Event Channel Content+ newtype Query m = Query   { deity :: () -> m Deity   } deriving (Generic)@@ -329,29 +337,33 @@   { createDeity :: () -> m Deity   } deriving (Generic) -newtype Subscription m = Subscription+newtype Subscription (m ::  * -> * ) = Subscription   { newDeity :: () -> m  Deity   } deriving (Generic)  type APIEvent = Event Channel Content  rootResolver :: GQLRootResolver IO APIEvent Query Mutation Subscription-rootResolver =-  GQLRootResolver-    { queryResolver = Query {deity = const fetchDeity}-    , mutationResolver = Mutation {createDeity}-    , subscriptionResolver = Subscription {newDeity}-    }-  where-    createDeity _args = MutResolver events updateDeity-        where-        events = [Event {channels = [ChannelA], content = ContentA 1}]-        updateDeity = updateDBDeity-    newDeity _args = SubResolver [ChannelA] subResolver-      where-        subResolver (Event [ChannelA] (ContentA _value)) = fetchDeity  -- resolve New State-        subResolver (Event [ChannelA] (ContentB _value)) = fetchDeity   -- resolve New State-        subResolver _                                    = fetchDeity -- Resolve Old State+rootResolver = GQLRootResolver+  { queryResolver        = Query { deity }+  , mutationResolver     = Mutation { createDeity }+  , subscriptionResolver = Subscription { newDeity }+  }+ where+  deity _args = fetchDeity+  -- Mutation Without Event Triggering+  createDeity :: () -> ResolveM EVENT IO Address+  createDeity _args = MutResolver \$ do+      value <- lift dbCreateDeity+      pure (+        [Event { channels = [ChannelA], content = ContentA 1 }],+        value+      )+  newDeity _args = SubResolver [ChannelA] subResolver+   where+    subResolver (Event [ChannelA] (ContentA _value)) = fetchDeity  -- resolve New State+    subResolver (Event [ChannelA] (ContentB _value)) = fetchDeity   -- resolve New State+    subResolver _ = fetchDeity -- Resolve Old State ```  ## Morpheus `GraphQL Client` with Template haskell QuasiQuotes

@@ -1,3 +1,136 @@+## [0.7.0] - 24.11.2019++## Removed++- `toMorpheusHaskellAPi` from `Data.Morpheus.Document` functionality will be migrated in `morpheus-graphql-cli`++## Changed++- `liftM` to `MonadTrans` instance method `lift`++- `liftEitherM` to `liftEither`++- `Resolver operation m event value` -> `Resolver operation event m value` , monad trans needs that last 2 type arguments are monad and value that why it was necessary++- exposed `Data.Morpheus.Types.Internal.AST`++- Mutation Resolver was changed from++```+resolver :: () -> ResolveM EVENT IO Address+resolver = MutResolver  {+  mutEvents = [someEventForSubscription],+  mutResolver = lift setDBAddress+}+```++```haskell+-- Mutation Wit Event Triggering : sends events to subscription+resolver :: () -> ResolveM EVENT IO Address+resolver = MutResolver \$ do+  value <- lift setDBAddress+  pure ([someEventForSubscription], value)+-- or+-- Mutation Without Event Triggering+resolver :: () -> ResolveM EVENT IO Address+resolver _args = lift setDBAddress+```++### Added++- added `parseDSL` to `Data.Morpheus.Document`++- GraphQL SDL support fully supports descriptions: onTypes, fields , args ...+  with (enums, inputObjects , union, object)+  for example :++  ```gql+  """+  Description for Type Address+  """+  type Address {+    """+    Description for Field city+    """+    city: String!+    street(+      """+      Description argument id+      """+      id: ID!+    ): Int!+  }+  ```++  ###### GraphQL SDL++  ```gql+  type User {+    name: String! @deprecated(reason: "some reason")+  }+  ```++  will displayed in introspection++  ###### introspection.json++  ```json+  {+    "data": {+      "__type": {+        "fields": [+          {+            "name": "city",+            "isDeprecated": true,+            "deprecationReason": "test deprecation field with reason"+          }+        ]+      }+    }+  }+  ```++- basic support of directive `@deprecated` on `enumValue` and object `field`, only on introspection++- GraphQL Client deprecation warnings++  on type++  ```gql+  type Human {+    humanName: String!+    lifetime: Lifetime! @deprecated(reason: "some reason")+    profession: Profession+  }+  ```++  compiler output:++  ```+  warning:+    Morpheus Client Warning:+    {+      "message":"the field \"Human.lifetime\" is deprecated. some reason",+      "locations":[{"line":24,"column":15}]+    }+  ```++- new helper resolver types aliases:++  - ResolveQ : for Query+  - ResolveM : for Mutation+  - ResolveS : for Subscription++  `ResolveM EVENT IO Address` is same as `MutRes EVENT IO (Address (MutRes EVENT IO))`++  is helpfull wenn you want to resolve GraphQL object++### Fixed++- added missing Monad instance for Mutation resolver+- `defineByIntrospectionFile` does not breaks if schema contains interfaces+- Morpheus Client supports `Subscription` and `Mutation`operations+ ## [0.6.2] - 2.11.2019  ## Added

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 6d77e1db039ce6a4a5ef7761d0b18beb9ea7067fbb99372bd3a97510e4da4a43+-- hash: a97de9ffea5713a01a84ffef6bd7ee41104d3d898f2d6a90ae0ef0be27ba7568  name:           morpheus-graphql-version:        0.6.2+version:        0.7.0 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -23,7 +23,6 @@     changelog.md     README.md data-files:-    test/Feature/Holistic/API.gql     test/Feature/Holistic/arguments/nameConflict/query.gql     test/Feature/Holistic/arguments/undefinedArgument/query.gql     test/Feature/Holistic/arguments/unknownArguments/query.gql@@ -39,6 +38,12 @@     test/Feature/Holistic/introspection/defaultTypes/ID/query.gql     test/Feature/Holistic/introspection/defaultTypes/Int/query.gql     test/Feature/Holistic/introspection/defaultTypes/String/query.gql+    test/Feature/Holistic/introspection/deprecated/enumValue/query.gql+    test/Feature/Holistic/introspection/deprecated/field/query.gql+    test/Feature/Holistic/introspection/description/enum/query.gql+    test/Feature/Holistic/introspection/description/inputObject/query.gql+    test/Feature/Holistic/introspection/description/object/query.gql+    test/Feature/Holistic/introspection/description/union/query.gql     test/Feature/Holistic/introspection/kinds/ENUM/query.gql     test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/query.gql     test/Feature/Holistic/introspection/kinds/OBJECT/query.gql@@ -68,6 +73,7 @@     test/Feature/Holistic/parsing/missingCloseBrace/query.gql     test/Feature/Holistic/parsing/notNullSpacing/query.gql     test/Feature/Holistic/parsing/singleLineComments/query.gql+    test/Feature/Holistic/schema.gql     test/Feature/Holistic/selection/AliasNameConflict/query.gql     test/Feature/Holistic/selection/AliasResolve/query.gql     test/Feature/Holistic/selection/AliasUnknownField/query.gql@@ -133,6 +139,12 @@     test/Feature/Holistic/introspection/defaultTypes/ID/response.json     test/Feature/Holistic/introspection/defaultTypes/Int/response.json     test/Feature/Holistic/introspection/defaultTypes/String/response.json+    test/Feature/Holistic/introspection/deprecated/enumValue/response.json+    test/Feature/Holistic/introspection/deprecated/field/response.json+    test/Feature/Holistic/introspection/description/enum/response.json+    test/Feature/Holistic/introspection/description/inputObject/response.json+    test/Feature/Holistic/introspection/description/object/response.json+    test/Feature/Holistic/introspection/description/union/response.json     test/Feature/Holistic/introspection/kinds/ENUM/response.json     test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/response.json     test/Feature/Holistic/introspection/kinds/OBJECT/response.json@@ -242,6 +254,7 @@       Data.Morpheus.Server       Data.Morpheus.Document       Data.Morpheus.Client+      Data.Morpheus.Types.Internal.AST   other-modules:       Data.Morpheus.Error.Arguments       Data.Morpheus.Error.Client.Client@@ -269,7 +282,6 @@       Data.Morpheus.Execution.Document.Introspect       Data.Morpheus.Execution.Internal.Declare       Data.Morpheus.Execution.Internal.Decode-      Data.Morpheus.Execution.Internal.GraphScanner       Data.Morpheus.Execution.Internal.Utils       Data.Morpheus.Execution.Server.Decode       Data.Morpheus.Execution.Server.Encode@@ -281,7 +293,6 @@       Data.Morpheus.Execution.Subscription.ClientRegister       Data.Morpheus.Parsing.Document.Parser       Data.Morpheus.Parsing.Document.TypeSystem-      Data.Morpheus.Parsing.Internal.Create       Data.Morpheus.Parsing.Internal.Internal       Data.Morpheus.Parsing.Internal.Pattern       Data.Morpheus.Parsing.Internal.Terms@@ -292,30 +303,23 @@       Data.Morpheus.Parsing.Request.Operation       Data.Morpheus.Parsing.Request.Parser       Data.Morpheus.Parsing.Request.Selection-      Data.Morpheus.Rendering.Haskell.Render-      Data.Morpheus.Rendering.Haskell.Terms-      Data.Morpheus.Rendering.Haskell.Types-      Data.Morpheus.Rendering.Haskell.Values       Data.Morpheus.Rendering.RenderGQL       Data.Morpheus.Rendering.RenderIntrospection       Data.Morpheus.Schema.Schema       Data.Morpheus.Schema.SchemaAPI       Data.Morpheus.Schema.TypeKind-      Data.Morpheus.Types.Custom       Data.Morpheus.Types.GQLScalar       Data.Morpheus.Types.GQLType       Data.Morpheus.Types.ID+      Data.Morpheus.Types.Internal.AST.Base+      Data.Morpheus.Types.Internal.AST.Data       Data.Morpheus.Types.Internal.AST.Operation-      Data.Morpheus.Types.Internal.AST.RawSelection       Data.Morpheus.Types.Internal.AST.Selection-      Data.Morpheus.Types.Internal.Base-      Data.Morpheus.Types.Internal.Data-      Data.Morpheus.Types.Internal.DataD-      Data.Morpheus.Types.Internal.Resolver-      Data.Morpheus.Types.Internal.Stream+      Data.Morpheus.Types.Internal.AST.Value+      Data.Morpheus.Types.Internal.Resolving+      Data.Morpheus.Types.Internal.Resolving.Core+      Data.Morpheus.Types.Internal.Resolving.Resolver       Data.Morpheus.Types.Internal.TH-      Data.Morpheus.Types.Internal.Validation-      Data.Morpheus.Types.Internal.Value       Data.Morpheus.Types.Internal.WebSocket       Data.Morpheus.Types.IO       Data.Morpheus.Types.Types@@ -325,7 +329,6 @@       Data.Morpheus.Validation.Query.Arguments       Data.Morpheus.Validation.Query.Fragment       Data.Morpheus.Validation.Query.Selection-      Data.Morpheus.Validation.Query.Utils.Selection       Data.Morpheus.Validation.Query.Validation       Data.Morpheus.Validation.Query.Variable       Paths_morpheus_graphql@@ -342,6 +345,7 @@     , scientific >=0.3.6.2 && <0.4     , template-haskell >=2.0 && <=2.16     , text >=1.2.3.0 && <1.3+    , th-lift-instances >=0.1.1 && <=0.2.0     , transformers >=0.3.0.0 && <0.6     , unordered-containers >=0.2.8.0 && <0.3     , uuid >=1.0 && <=1.4@@ -381,6 +385,7 @@     , tasty-hunit     , template-haskell >=2.0 && <=2.16     , text >=1.2.3.0 && <1.3+    , th-lift-instances >=0.1.1 && <=0.2.0     , transformers >=0.3.0.0 && <0.6     , unordered-containers >=0.2.8.0 && <0.3     , uuid >=1.0 && <=1.4

@@ -1,6 +1,8 @@ -- | Build GraphQL APIs with your favourite functional language! module Data.Morpheus   ( Interpreter(..)-  ) where+  )+where -import           Data.Morpheus.Execution.Server.Interpreter (Interpreter (..))+import           Data.Morpheus.Execution.Server.Interpreter+                                                ( Interpreter(..) )

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Client@@ -10,38 +9,46 @@   , defineByDocumentFile   , defineByIntrospection   , defineByIntrospectionFile-  ) where+  )+where -import           Data.ByteString.Lazy                    (ByteString)-import qualified Data.ByteString.Lazy                    as L (readFile)+import           Data.ByteString.Lazy           ( ByteString )+import qualified Data.ByteString.Lazy          as L+                                                ( readFile ) import           Language.Haskell.TH import           Language.Haskell.TH.Quote -import           Data.Morpheus.Document                  (parseFullGQLDocument)+import           Data.Morpheus.Document         ( parseFullGQLDocument ) -- MORPHEUS-import           Data.Morpheus.Execution.Client.Build    (defineQuery)-import           Data.Morpheus.Execution.Client.Compile  (compileSyntax)-import           Data.Morpheus.Execution.Client.Fetch    (Fetch (..))-import           Data.Morpheus.Parsing.JSONSchema.Parse  (decodeIntrospection)-import           Data.Morpheus.Types.Internal.Data       (DataTypeLib)-import           Data.Morpheus.Types.Internal.Validation (Validation)-import           Data.Morpheus.Types.Types               (GQLQueryRoot)+import           Data.Morpheus.Execution.Client.Build+                                                ( defineQuery )+import           Data.Morpheus.Execution.Client.Compile+                                                ( compileSyntax )+import           Data.Morpheus.Execution.Client.Fetch+                                                ( Fetch(..) )+import           Data.Morpheus.Parsing.JSONSchema.Parse+                                                ( decodeIntrospection )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation )+import           Data.Morpheus.Types.Internal.AST+                                                ( GQLQuery+                                                , DataTypeLib+                                                )  gql :: QuasiQuoter-gql =-  QuasiQuoter-    { quoteExp = compileSyntax-    , quotePat = notHandled "Patterns"-    , quoteType = notHandled "Types"-    , quoteDec = notHandled "Declarations"-    }-  where-    notHandled things = error $ things ++ " are not supported by the GraphQL QuasiQuoter"+gql = QuasiQuoter { quoteExp  = compileSyntax+                  , quotePat  = notHandled "Patterns"+                  , quoteType = notHandled "Types"+                  , quoteDec  = notHandled "Declarations"+                  }+ where+  notHandled things =+    error $ things ++ " are not supported by the GraphQL QuasiQuoter" -defineByDocumentFile :: String -> (GQLQueryRoot, String) -> Q [Dec]+defineByDocumentFile :: String -> (GQLQuery, String) -> Q [Dec] defineByDocumentFile = defineByDocument . L.readFile -defineByIntrospectionFile :: String -> (GQLQueryRoot, String) -> Q [Dec]+defineByIntrospectionFile :: String -> (GQLQuery, String) -> Q [Dec] defineByIntrospectionFile = defineByIntrospection . L.readFile  --@@ -49,11 +56,11 @@ -- TODO: Define By API -- Validates By Server API ---defineByDocument :: IO ByteString -> (GQLQueryRoot, String) -> Q [Dec]+defineByDocument :: IO ByteString -> (GQLQuery, String) -> Q [Dec] defineByDocument doc = defineQuery (schemaByDocument doc)  schemaByDocument :: IO ByteString -> IO (Validation DataTypeLib) schemaByDocument documentGQL = parseFullGQLDocument <$> documentGQL -defineByIntrospection :: IO ByteString -> (GQLQueryRoot, String) -> Q [Dec]+defineByIntrospection :: IO ByteString -> (GQLQuery, String) -> Q [Dec] defineByIntrospection json = defineQuery (decodeIntrospection <$> json)

@@ -1,39 +1,64 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns   #-}  module Data.Morpheus.Document   ( toGraphQLDocument-  , toMorpheusHaskellAPi   , gqlDocument   , parseFullGQLDocument   , importGQLDocument   , importGQLDocumentWithNamespace-  ) where+  , parseDSL+  )+where -import           Control.Monad                                ((>=>))-import           Data.ByteString.Lazy.Char8                   (ByteString, pack)-import           Data.Text                                    (Text)-import qualified Data.Text.Lazy                               as LT (toStrict)-import           Data.Text.Lazy.Encoding                      (decodeUtf8)+import           Control.Monad                  ( (>=>) )+import           Data.ByteString.Lazy.Char8     ( ByteString+                                                , pack+                                                )+import           Data.Text                      ( Text )+import qualified Data.Text.Lazy                as LT+                                                ( toStrict )+import           Data.Text.Lazy.Encoding        ( decodeUtf8 ) import           Language.Haskell.TH  -- -- MORPHEUS-import           Data.Morpheus.Execution.Document.Compile     (compileDocument, gqlDocument)-import           Data.Morpheus.Execution.Server.Resolve       (RootResCon, fullSchema)-import           Data.Morpheus.Rendering.Haskell.Render       (renderHaskellDocument)-import           Data.Morpheus.Rendering.RenderGQL            (renderGraphQLDocument)-import           Data.Morpheus.Types                          (GQLRootResolver)+import           Data.Morpheus.Execution.Document.Compile+                                                ( compileDocument+                                                , gqlDocument+                                                )+import           Data.Morpheus.Execution.Server.Resolve+                                                ( RootResCon+                                                , fullSchema+                                                )+import           Data.Morpheus.Parsing.Document.Parser+                                                ( parseTypes ) -import           Data.Morpheus.Parsing.Document.Parser        (parseTypes)-import           Data.Morpheus.Parsing.Internal.Create        (createDataTypeLib)-import           Data.Morpheus.Schema.SchemaAPI               (defaultTypes)-import           Data.Morpheus.Types.Internal.Data            (DataTypeLib)-import           Data.Morpheus.Types.Internal.Validation      (Validation)-import           Data.Morpheus.Validation.Document.Validation (validatePartialDocument)+import           Data.Morpheus.Rendering.RenderGQL+                                                ( renderGraphQLDocument )+import           Data.Morpheus.Schema.SchemaAPI ( defaultTypes )+import           Data.Morpheus.Types            ( GQLRootResolver )+import           Data.Morpheus.Types.Internal.AST+                                                ( DataTypeLib+                                                , createDataTypeLib+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation+                                                , Result(..)+                                                )+import           Data.Morpheus.Validation.Document.Validation+                                                ( validatePartialDocument ) +                                              +parseDSL :: ByteString -> Either String DataTypeLib+parseDSL doc = case parseGraphQLDocument doc of+  Failure errors     -> Left (show errors)+  Success { result } -> Right result++ parseDocument :: Text -> Validation DataTypeLib-parseDocument doc = parseTypes doc >>= validatePartialDocument >>= createDataTypeLib+parseDocument doc =+  parseTypes doc >>= validatePartialDocument >>= createDataTypeLib  parseGraphQLDocument :: ByteString -> Validation DataTypeLib parseGraphQLDocument x = parseDocument (LT.toStrict $ decodeUtf8 x)@@ -42,20 +67,19 @@ parseFullGQLDocument = parseGraphQLDocument >=> defaultTypes  -- | Generates schema.gql file from 'GQLRootResolver'-toGraphQLDocument :: RootResCon m event query mut sub => proxy (GQLRootResolver m event query mut sub) -> ByteString-toGraphQLDocument x =-  case fullSchema x of-    Left errors -> pack (show errors)-    Right lib   -> renderGraphQLDocument lib+toGraphQLDocument+  :: RootResCon m event query mut sub+  => proxy (GQLRootResolver m event query mut sub)+  -> ByteString+toGraphQLDocument x = case fullSchema x of+  Failure errors           -> pack (show errors)+  Success { result = lib } -> renderGraphQLDocument lib -toMorpheusHaskellAPi :: String -> ByteString -> Either ByteString ByteString-toMorpheusHaskellAPi moduleName doc =-  case parseGraphQLDocument doc of-    Left errors -> Left $ pack (show errors)-    Right lib   -> Right $ renderHaskellDocument moduleName lib + importGQLDocument :: String -> Q [Dec] importGQLDocument src = runIO (readFile src) >>= compileDocument False  importGQLDocumentWithNamespace :: String -> Q [Dec]-importGQLDocumentWithNamespace src = runIO (readFile src) >>= compileDocument True+importGQLDocumentWithNamespace src =+  runIO (readFile src) >>= compileDocument True

@@ -5,13 +5,21 @@   , unknownArguments   , argumentGotInvalidValue   , argumentNameCollision-  ) where+  )+where -import           Data.Morpheus.Error.Utils               (errorMessage)-import           Data.Morpheus.Types.Internal.Base       (EnhancedKey (..), Position)-import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)-import           Data.Text                               (Text)-import qualified Data.Text                               as T (concat)+import           Data.Morpheus.Error.Utils      ( errorMessage )+import           Data.Morpheus.Types.Internal.AST.Base+                                                ( Ref(..)+                                                , Position+                                                )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLError(..)+                                                , GQLErrors+                                                )+import           Data.Text                      ( Text )+import qualified Data.Text                     as T+                                                ( concat )  {-   ARGUMENTS:@@ -28,29 +36,27 @@   - date(name: "name") -> "Unknown argument \"name\" on field \"date\" of type \"Experience\"." -} argumentGotInvalidValue :: Text -> Text -> Position -> GQLErrors-argumentGotInvalidValue key' inputMessage' position' =-  errorMessage position' text-  where-    text = T.concat ["Argument ", key', " got invalid value ;", inputMessage']+argumentGotInvalidValue key' inputMessage' position' = errorMessage position'+                                                                    text+ where+  text = T.concat ["Argument ", key', " got invalid value ;", inputMessage'] -unknownArguments :: Text -> [EnhancedKey] -> GQLErrors+unknownArguments :: Text -> [Ref] -> GQLErrors unknownArguments fieldName = map keyToError-  where-    keyToError (EnhancedKey argName pos) =-      GQLError {desc = toMessage argName, positions = [pos]}-    toMessage argName =-      T.concat-        ["Unknown Argument \"", argName, "\" on Field \"", fieldName, "\"."]+ where+  keyToError (Ref argName pos) =+    GQLError { message = toMessage argName, locations = [pos] }+  toMessage argName = T.concat+    ["Unknown Argument \"", argName, "\" on Field \"", fieldName, "\"."] -argumentNameCollision :: [EnhancedKey] -> GQLErrors+argumentNameCollision :: [Ref] -> GQLErrors argumentNameCollision = map keyToError-  where-    keyToError (EnhancedKey argName pos) =-      GQLError {desc = toMessage argName, positions = [pos]}-    toMessage argName =-      T.concat ["There can Be only One Argument Named \"", argName, "\""]+ where+  keyToError (Ref argName pos) =+    GQLError { message = toMessage argName, locations = [pos] }+  toMessage argName =+    T.concat ["There can Be only One Argument Named \"", argName, "\""] -undefinedArgument :: EnhancedKey -> GQLErrors-undefinedArgument (EnhancedKey key' position') = errorMessage position' text-  where-    text = T.concat ["Required Argument: \"", key', "\" was not Defined"]+undefinedArgument :: Ref -> GQLErrors+undefinedArgument (Ref key' position') = errorMessage position' text+  where text = T.concat ["Required Argument: \"", key', "\" was not Defined"]

@@ -1,11 +1,55 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+ module Data.Morpheus.Error.Client.Client   ( renderGQLErrors-  ) where+  , deprecatedEnum+  , deprecatedField+  , gqlWarnings+  )+where -import           Data.Aeson                              (encode)-import           Data.ByteString.Lazy.Char8              (unpack)-import           Data.Morpheus.Error.Utils               (renderErrors)-import           Data.Morpheus.Types.Internal.Validation (GQLErrors)+import           Data.Aeson                     ( encode )+import           Data.ByteString.Lazy.Char8     ( unpack )+import           Data.Morpheus.Error.Utils      ( errorMessage )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLErrors )+import           Data.Morpheus.Types.Internal.AST.Base+                                                ( Ref(..)+                                                , Description+                                                , Name+                                                )+import           Language.Haskell.TH            ( Q+                                                , reportWarning+                                                )+import           Data.Semigroup                 ( (<>) )  renderGQLErrors :: GQLErrors -> String-renderGQLErrors = unpack . encode . renderErrors+renderGQLErrors = unpack . encode++deprecatedEnum :: Name -> Ref -> Maybe Description -> GQLErrors+deprecatedEnum typeName Ref { refPosition, refName } reason =+  errorMessage refPosition+    $  "the enum value "+    <> typeName+    <> "."+    <> refName+    <> "\" is deprecated."+    <> maybe "" (" " <>) reason++deprecatedField :: Name -> Ref -> Maybe Description -> GQLErrors+deprecatedField typeName Ref { refPosition, refName } reason =+  errorMessage refPosition+    $  "the field \""+    <> typeName+    <> "."+    <> refName+    <> "\" is deprecated."+    <> maybe "" (" " <>) reason++gqlWarnings :: GQLErrors -> Q ()+gqlWarnings []       = pure ()+gqlWarnings warnings = mapM_ handleWarning warnings+ where+  handleWarning warning =+    reportWarning ("Morpheus GraphQL Warning: " <> (unpack . encode) warning)

@@ -5,17 +5,21 @@   ( unknownInterface   , partialImplements   , ImplementsError(..)-  ) where+  )+where -import           Data.Morpheus.Error.Utils               (globalErrorMessage)-import           Data.Morpheus.Types.Internal.Base       (Key)-import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)-import           Data.Semigroup                          ((<>))+import           Data.Morpheus.Error.Utils      ( globalErrorMessage )+import           Data.Morpheus.Types.Internal.AST.Base+                                                ( Key )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLError(..)+                                                , GQLErrors+                                                )+import           Data.Semigroup                 ( (<>) )  unknownInterface :: Key -> GQLErrors unknownInterface name = globalErrorMessage message-  where-    message = "Unknown Interface \"" <> name <> "\"."+  where message = "Unknown Interface \"" <> name <> "\"."  data ImplementsError   = UnexpectedType { expectedType :: Key@@ -24,12 +28,24 @@  partialImplements :: Key -> [(Key, Key, ImplementsError)] -> GQLErrors partialImplements name = map impError-  where-    impError (interfaceName, key, errorType) = GQLError {desc = message, positions = []}-      where-        message =-          "type \"" <> name <> "\" implements Interface \"" <> interfaceName <> "\" Partially," <>-          detailedMessage errorType-        detailedMessage UnexpectedType {expectedType, foundType} =-          " on key \"" <> key <> "\" expected type \"" <> expectedType <> "\" found \"" <> foundType <> "\"."-        detailedMessage UndefinedField = " key \"" <> key <> "\" not found ."+ where+  impError (interfaceName, key, errorType) = GQLError { message   = message+                                                      , locations = []+                                                      }+   where+    message =+      "type \""+        <> name+        <> "\" implements Interface \""+        <> interfaceName+        <> "\" Partially,"+        <> detailedMessage errorType+    detailedMessage UnexpectedType { expectedType, foundType } =+      " on key \""+        <> key+        <> "\" expected type \""+        <> expectedType+        <> "\" found \""+        <> foundType+        <> "\"."+    detailedMessage UndefinedField = " key \"" <> key <> "\" not found ."

@@ -7,16 +7,23 @@   , unknownFragment   , cannotBeSpreadOnType   , fragmentNameCollision-  ) where+  )+where -import           Data.Semigroup                          ((<>))-import           Data.Text                               (Text)-import qualified Data.Text                               as T+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( Text )+import qualified Data.Text                     as T  -- MORPHEUS-import           Data.Morpheus.Error.Utils               (errorMessage)-import           Data.Morpheus.Types.Internal.Base       (EnhancedKey (..), Position)-import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)+import           Data.Morpheus.Error.Utils      ( errorMessage )+import           Data.Morpheus.Types.Internal.AST.Base+                                                ( Ref(..)+                                                , Position+                                                )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLError(..)+                                                , GQLErrors+                                                )  {-   FRAGMENT:@@ -29,57 +36,53 @@     fragment H on D {...}  ->  "Unknown type \"D\"."     {...H} -> "Unknown fragment \"H\"." -}-fragmentNameCollision :: [EnhancedKey] -> GQLErrors+fragmentNameCollision :: [Ref] -> GQLErrors fragmentNameCollision = map toError-  where-    toError EnhancedKey {uid, location} =-      GQLError-        { desc = "There can be only one fragment named \"" <> uid <> "\"."-        , positions = [location]-        }+ where+  toError Ref { refName, refPosition } = GQLError+    { message      = "There can be only one fragment named \"" <> refName <> "\"."+    , locations = [refPosition]+    } -unusedFragment :: [EnhancedKey] -> GQLErrors+unusedFragment :: [Ref] -> GQLErrors unusedFragment = map toError-  where-    toError EnhancedKey {uid, location} =-      GQLError-        { desc = "Fragment \"" <> uid <> "\" is never used."-        , positions = [location]-        }+ where+  toError Ref { refName, refPosition } = GQLError+    { message      = "Fragment \"" <> refName <> "\" is never used."+    , locations = [refPosition]+    } -cannotSpreadWithinItself :: [EnhancedKey] -> GQLErrors+cannotSpreadWithinItself :: [Ref] -> GQLErrors cannotSpreadWithinItself fragments =-  [GQLError {desc = text, positions = map location fragments}]-  where-    text =-      T.concat-        [ "Cannot spread fragment \""-        , uid $ head fragments-        , "\" within itself via "-        , T.intercalate "," (map uid fragments)-        , "."-        ]+  [GQLError { message = text, locations = map refPosition fragments }]+ where+  text = T.concat+    [ "Cannot spread fragment \""+    , refName $ head fragments+    , "\" within itself via "+    , T.intercalate "," (map refName fragments)+    , "."+    ]  -- {...H} -> "Unknown fragment \"H\"." unknownFragment :: Text -> Position -> GQLErrors unknownFragment key' position' = errorMessage position' text-  where-    text = T.concat ["Unknown Fragment \"", key', "\"."]+  where text = T.concat ["Unknown Fragment \"", key', "\"."]  -- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"." cannotBeSpreadOnType :: Maybe Text -> Text -> Position -> Text -> GQLErrors-cannotBeSpreadOnType key' type' position' selectionType' =-  errorMessage position' text-  where-    text =-      T.concat-        [ "Fragment"-        , getName key'-        , " cannot be spread here as objects of type \""-        , selectionType'-        , "\" can never be of type \""-        , type'-        , "\"."-        ]-    getName (Just x') = T.concat [" \"", x', "\""]-    getName Nothing   = ""+cannotBeSpreadOnType key' type' position' selectionType' = errorMessage+  position'+  text+ where+  text = T.concat+    [ "Fragment"+    , getName key'+    , " cannot be spread here as objects of type \""+    , selectionType'+    , "\" can never be of type \""+    , type'+    , "\"."+    ]+  getName (Just x') = T.concat [" \"", x', "\""]+  getName Nothing   = ""

@@ -1,18 +1,25 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}  module Data.Morpheus.Error.Input   ( inputErrorMessage   , InputError(..)   , Prop(..)   , InputValidation-  ) where--import           Data.Aeson                         (encode)-import           Data.ByteString.Lazy.Char8         (unpack)-import           Data.Morpheus.Types.Internal.Value (Value)-import           Data.Text                          (Text)-import qualified Data.Text                          as T (concat, intercalate, pack)+  )+where +import           Data.Aeson                     ( encode )+import           Data.ByteString.Lazy.Char8     ( unpack )+import           Data.Morpheus.Types.Internal.AST.Value+                                                ( Value )+import           Data.Text                      ( Text )+import qualified Data.Text                     as T+                                                ( concat+                                                , intercalate+                                                , pack+                                                ) type InputValidation a = Either InputError a  data InputError@@ -30,33 +37,31 @@ inputErrorMessage (UnexpectedType path type' value errorMessage) =   expectedTypeAFoundB path type' value errorMessage inputErrorMessage (UndefinedField path' field') = undefinedField path' field'-inputErrorMessage (UnknownField path' field') = unknownField path' field'+inputErrorMessage (UnknownField   path' field') = unknownField path' field'  pathToText :: [Prop] -> Text pathToText []    = "" pathToText path' = T.concat ["on ", T.intercalate "." $ fmap propKey path']  expectedTypeAFoundB :: [Prop] -> Text -> Value -> Maybe Text -> Text-expectedTypeAFoundB path' expected found Nothing =-  T.concat-    [ pathToText path'-    , " Expected type \""-    , expected-    , "\" found "-    , T.pack (unpack $ encode found)-    , "."-    ]-expectedTypeAFoundB path' expected found (Just errorMessage) =-  T.concat-    [ pathToText path'-    , " Expected type \""-    , expected-    , "\" found "-    , T.pack (unpack $ encode found)-    , "; "-    , errorMessage-    , "."-    ]+expectedTypeAFoundB path' expected found Nothing = T.concat+  [ pathToText path'+  , " Expected type \""+  , expected+  , "\" found "+  , T.pack (unpack $ encode found)+  , "."+  ]+expectedTypeAFoundB path' expected found (Just errorMessage) = T.concat+  [ pathToText path'+  , " Expected type \""+  , expected+  , "\" found "+  , T.pack (unpack $ encode found)+  , "; "+  , errorMessage+  , "."+  ]  undefinedField :: [Prop] -> Text -> Text undefinedField path' field' =

@@ -5,33 +5,42 @@   , internalArgumentError   , internalUnknownTypeMessage   , internalError-  ) where+  )+where -import           Data.Text                               (Text)-import qualified Data.Text                               as T (concat, pack)+import           Data.Text                      ( Text )+import qualified Data.Text                     as T+                                                ( concat+                                                , pack+                                                )+import           Data.Semigroup                 ( (<>) )  -- MORPHEUS-import           Data.Morpheus.Error.Utils               (globalErrorMessage)-import           Data.Morpheus.Types.Internal.Validation (GQLErrors)-import           Data.Morpheus.Types.Internal.Value      (Value (..))+import           Data.Morpheus.Error.Utils      ( globalErrorMessage )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( Validation+                                                , GQLErrors+                                                , Failure(..)+                                                )+import           Data.Morpheus.Types.Internal.AST.Value+                                                ( Value(..) )   -- GQL:: if no mutation defined -> "Schema is not configured for mutations." -- all kind internal error in development-internalError :: Text -> Either GQLErrors b-internalError x = Left $ globalErrorMessage $ T.concat ["INTERNAL ERROR: ", x]+internalError :: Text -> Validation b+internalError x = failure $ globalErrorMessage $ "INTERNAL ERROR: " <> x  -- if type did not not found, but was defined by Schema internalUnknownTypeMessage :: Text -> GQLErrors-internalUnknownTypeMessage x =-  globalErrorMessage $-  T.concat ["type did not not found, but was defined by Schema", x]+internalUnknownTypeMessage x = globalErrorMessage+  $ T.concat ["type did not not found, but was defined by Schema", x]  -- if arguments is already validated but has not found required argument-internalArgumentError :: Text -> Either GQLErrors b-internalArgumentError x = internalError $ T.concat ["Argument ", x]+internalArgumentError :: Text -> Validation b+internalArgumentError x = internalError $ "Argument " <> x  -- if value is already validated but value has different type-internalTypeMismatch :: Text -> Value -> Either GQLErrors b+internalTypeMismatch :: Text -> Value -> Validation b internalTypeMismatch text jsType =-  internalError $ T.concat ["Type mismatch ", text, T.pack $ show jsType]+  internalError $ "Type mismatch " <> text <> T.pack (show jsType)

@@ -2,11 +2,14 @@  module Data.Morpheus.Error.Mutation   ( mutationIsNotDefined-  ) where+  )+where -import           Data.Morpheus.Error.Utils               (errorMessage)-import           Data.Morpheus.Types.Internal.Base       (Position)-import           Data.Morpheus.Types.Internal.Validation (GQLErrors)+import           Data.Morpheus.Error.Utils      ( errorMessage )+import           Data.Morpheus.Types.Internal.AST.Base+                                                ( Position )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLErrors )  mutationIsNotDefined :: Position -> GQLErrors mutationIsNotDefined position' =

@@ -3,12 +3,14 @@ module Data.Morpheus.Error.Schema   ( nameCollisionError   , schemaValidationError-  ) where+  )+where -import           Data.Morpheus.Error.Utils               (globalErrorMessage)-import           Data.Morpheus.Types.Internal.Validation (GQLErrors)-import           Data.Semigroup                          ((<>))-import           Data.Text                               (Text)+import           Data.Morpheus.Error.Utils      ( globalErrorMessage )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLErrors )+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( Text )  schemaValidationError :: Text -> GQLErrors schemaValidationError error' =@@ -16,6 +18,7 @@  nameCollisionError :: Text -> GQLErrors nameCollisionError name =-  schemaValidationError $-  "Name collision: \"" <> name <>-  "\" is used for different dataTypes in two separate modules"+  schemaValidationError+    $  "Name collision: \""+    <> name+    <> "\" is used for different dataTypes in two separate modules"

@@ -5,43 +5,66 @@   , subfieldsNotSelected   , duplicateQuerySelections   , hasNoSubfields-  , fieldNotResolved-  , resolverError-  ) where+  , resolvingFailedError+  )+where -import           Data.Morpheus.Error.Utils               (errorMessage)-import           Data.Morpheus.Types.Internal.Base       (EnhancedKey (..), Position)-import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)-import           Data.Text                               (Text, pack)-import qualified Data.Text                               as T (concat)+import           Data.Semigroup                 ( (<>) )+import           Data.Morpheus.Error.Utils      ( errorMessage )+import           Data.Morpheus.Types.Internal.AST.Base+                                                ( Ref(..)+                                                , Position+                                                )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLError(..)+                                                , GQLErrors+                                                )+import           Data.Text                      ( Text )+import qualified Data.Text                     as T+                                                ( concat ) -resolverError :: Position -> Text -> String -> GQLErrors-resolverError pos name message = fieldNotResolved pos name (pack message) -fieldNotResolved :: Position -> Text -> Text -> GQLErrors-fieldNotResolved position' key' message' = errorMessage position' text-  where-    text = T.concat ["Failure on Resolving Field \"", key', "\": ", message']+resolvingFailedError :: Position -> Text -> Text -> GQLError+resolvingFailedError position name reason = GQLError+  { message   = "Failure on Resolving Field \"" <> name <> "\": " <> reason+  , locations = [position]+  } + -- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields." hasNoSubfields :: Text -> Text -> Position -> GQLErrors hasNoSubfields key typeName position = errorMessage position text-  where-    text = T.concat ["Field \"", key, "\" must not have a selection since type \"", typeName, "\" has no subfields."]+ where+  text = T.concat+    [ "Field \""+    , key+    , "\" must not have a selection since type \""+    , typeName+    , "\" has no subfields."+    ]  cannotQueryField :: Text -> Text -> Position -> GQLErrors cannotQueryField key typeName position = errorMessage position text-  where-    text = T.concat ["Cannot query field \"", key, "\" on type \"", typeName, "\"."]+ where+  text =+    T.concat ["Cannot query field \"", key, "\" on type \"", typeName, "\"."] -duplicateQuerySelections :: Text -> [EnhancedKey] -> GQLErrors+duplicateQuerySelections :: Text -> [Ref] -> GQLErrors duplicateQuerySelections parentType = map keyToError-  where-    keyToError (EnhancedKey key' pos) = GQLError {desc = toMessage key', positions = [pos]}-    toMessage key' = T.concat ["duplicate selection of key \"", key', "\" on type \"", parentType, "\"."]+ where+  keyToError (Ref key' pos) =+    GQLError { message = toMessage key', locations = [pos] }+  toMessage key' = T.concat+    ["duplicate selection of key \"", key', "\" on type \"", parentType, "\"."]  -- GQL:: Field \"hobby\" of type \"Hobby!\" must have a selection of subfields. Did you mean \"hobby { ... }\"? subfieldsNotSelected :: Text -> Text -> Position -> GQLErrors subfieldsNotSelected key typeName position = errorMessage position text-  where-    text = T.concat ["Field \"", key, "\" of type \"", typeName, "\" must have a selection of subfields"]+ where+  text = T.concat+    [ "Field \""+    , key+    , "\" of type \""+    , typeName+    , "\" must have a selection of subfields"+    ]

@@ -2,11 +2,14 @@  module Data.Morpheus.Error.Subscription   ( subscriptionIsNotDefined-  ) where+  )+where -import           Data.Morpheus.Error.Utils               (errorMessage)-import           Data.Morpheus.Types.Internal.Base       (Position)-import           Data.Morpheus.Types.Internal.Validation (GQLErrors)+import           Data.Morpheus.Error.Utils      ( errorMessage )+import           Data.Morpheus.Types.Internal.AST.Base+                                                ( Position )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLErrors )  subscriptionIsNotDefined :: Position -> GQLErrors subscriptionIsNotDefined position' =

@@ -3,31 +3,39 @@ module Data.Morpheus.Error.Utils   ( errorMessage   , globalErrorMessage-  , renderErrors   , badRequestError   , toLocation-  ) where+  )+where -import           Data.ByteString.Lazy.Char8              (ByteString, pack)-import           Data.Morpheus.Types.Internal.Base       (Position)-import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors, JSONError (..), Location (..))-import           Data.Text                               (Text)-import           Text.Megaparsec                         (SourcePos (SourcePos), sourceColumn, sourceLine, unPos)+import           Data.ByteString.Lazy.Char8     ( ByteString+                                                , pack+                                                )+import           Data.Morpheus.Types.Internal.AST.Base+                                                ( Position )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLError(..)+                                                , GQLErrors+                                                , GQLError(..)+                                                , Position(..)+                                                )+import           Data.Text                      ( Text )+import           Text.Megaparsec                ( SourcePos(SourcePos)+                                                , sourceColumn+                                                , sourceLine+                                                , unPos+                                                )  errorMessage :: Position -> Text -> GQLErrors-errorMessage position text = [GQLError {desc = text, positions = [position]}]+errorMessage position message = [GQLError { message, locations = [position] }]  globalErrorMessage :: Text -> GQLErrors-globalErrorMessage text = [GQLError {desc = text, positions = []}]--renderErrors :: [GQLError] -> [JSONError]-renderErrors = map renderError--renderError :: GQLError -> JSONError-renderError GQLError {desc, positions} = JSONError {message = desc, locations = positions}+globalErrorMessage message = [GQLError { message, locations = [] }] -toLocation :: SourcePos -> Location-toLocation SourcePos {sourceLine, sourceColumn} = Location {line = unPos sourceLine, column = unPos sourceColumn}+toLocation :: SourcePos -> Position+toLocation SourcePos { sourceLine, sourceColumn } =+  Position { line = unPos sourceLine, column = unPos sourceColumn }  badRequestError :: String -> ByteString-badRequestError aesonError' = pack $ "Bad Request. Could not decode Request body: " ++ aesonError'+badRequestError aesonError' =+  pack $ "Bad Request. Could not decode Request body: " ++ aesonError'

@@ -7,75 +7,78 @@   , uninitializedVariable   , unusedVariables   , incompatibleVariableType-  ) where+  )+where -import           Data.Morpheus.Error.Utils               (errorMessage)-import           Data.Morpheus.Types.Internal.Base       (EnhancedKey (..), Position)-import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)-import           Data.Semigroup                          ((<>))-import           Data.Text                               (Text)-import qualified Data.Text                               as T (concat)+import           Data.Morpheus.Error.Utils      ( errorMessage )+import           Data.Morpheus.Types.Internal.AST.Base+                                                ( Ref(..)+                                                , Position+                                                )+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLError(..)+                                                , GQLErrors+                                                )+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( Text )+import qualified Data.Text                     as T+                                                ( concat )  -- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"." incompatibleVariableType :: Text -> Text -> Text -> Position -> GQLErrors incompatibleVariableType variableName variableType argType argPosition =   errorMessage argPosition text-  where-    text =-      "Variable \"$" <> variableName <> "\" of type \"" <> variableType <>-      "\" used in position expecting type \"" <>-      argType <>-      "\"."+ where+  text =+    "Variable \"$"+      <> variableName+      <> "\" of type \""+      <> variableType+      <> "\" used in position expecting type \""+      <> argType+      <> "\"."  -- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".",-unusedVariables :: Text -> [EnhancedKey] -> GQLErrors+unusedVariables :: Text -> [Ref] -> GQLErrors unusedVariables operator' = map keyToError-  where-    keyToError (EnhancedKey key' position') =-      GQLError {desc = text key', positions = [position']}-    text key' =-      T.concat-        [ "Variable \"$"-        , key'-        , "\" is never used in operation \""-        , operator'-        , "\"."-        ]+ where+  keyToError (Ref key' position') =+    GQLError { message = text key', locations = [position'] }+  text key' = T.concat+    ["Variable \"$", key', "\" is never used in operation \"", operator', "\"."]  -- type mismatch -- { "v": 1  }        "Variable \"$v\" got invalid value 1; Expected type LANGUAGE." variableGotInvalidValue :: Text -> Text -> Position -> GQLErrors-variableGotInvalidValue name' inputMessage' position' =-  errorMessage position' text-  where-    text =-      T.concat ["Variable \"$", name', "\" got invalid value; ", inputMessage']+variableGotInvalidValue name' inputMessage' position' = errorMessage+  position'+  text+ where+  text =+    T.concat ["Variable \"$", name', "\" got invalid value; ", inputMessage']  unknownType :: Text -> Position -> GQLErrors unknownType type' position' = errorMessage position' text-  where-    text = T.concat ["Unknown type \"", type', "\"."]+  where text = T.concat ["Unknown type \"", type', "\"."]  undefinedVariable :: Text -> Position -> Text -> GQLErrors undefinedVariable operation' position' key' = errorMessage position' text-  where-    text =-      T.concat-        [ "Variable \""-        , key'-        , "\" is not defined by operation \""-        , operation'-        , "\"."-        ]+ where+  text = T.concat+    [ "Variable \""+    , key'+    , "\" is not defined by operation \""+    , operation'+    , "\"."+    ]  uninitializedVariable :: Position -> Text -> Text -> GQLErrors uninitializedVariable position' type' key' = errorMessage position' text-  where-    text =-      T.concat-        [ "Variable \"$"-        , key'-        , "\" of required type \""-        , type'-        , "!\" was not provided."-        ]+ where+  text = T.concat+    [ "Variable \"$"+    , key'+    , "\" of required type \""+    , type'+    , "!\" was not provided."+    ]

@@ -12,129 +12,147 @@   ( deriveFromJSON   , deriveToJSON   , takeValueType-  ) where+  )+where  import           Data.Aeson import           Data.Aeson.Types-import qualified Data.HashMap.Lazy                      as H (lookup)-import           Data.Semigroup                         ((<>))-import           Data.Text                              (unpack)+import qualified Data.HashMap.Lazy             as H+                                                ( lookup )+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( unpack ) import           Language.Haskell.TH -import           Data.Morpheus.Execution.Internal.Utils (nameSpaceTypeString)+import           Data.Morpheus.Execution.Internal.Utils+                                                ( nameSpaceTypeString )  -- -- MORPHEUS-import           Data.Morpheus.Types.Internal.Data      (DataField (..), isFieldNullable)-import           Data.Morpheus.Types.Internal.DataD     (ConsD (..), TypeD (..))-import           Data.Morpheus.Types.Internal.TH        (destructRecord, instanceFunD, instanceHeadT)+import           Data.Morpheus.Types.Internal.AST+                                                ( DataField(..)+                                                , isFieldNullable+                                                , ConsD(..)+                                                , TypeD(..)+                                                )+import           Data.Morpheus.Types.Internal.TH+                                                ( destructRecord+                                                , instanceFunD+                                                , instanceHeadT+                                                )  -- FromJSON deriveFromJSON :: TypeD -> Q Dec-deriveFromJSON TypeD {tCons = []} = fail "Type Should Have at least one Constructor"-deriveFromJSON TypeD {tName, tNamespace, tCons = [cons]} = defineFromJSON name (aesonObject tNamespace) cons-  where-    name = nameSpaceTypeString tNamespace tName-deriveFromJSON typeD@TypeD {tName, tCons, tNamespace}+deriveFromJSON TypeD { tCons = [] } =+  fail "Type Should Have at least one Constructor"+deriveFromJSON TypeD { tName, tNamespace, tCons = [cons] } = defineFromJSON+  name+  (aesonObject tNamespace)+  cons+  where name = nameSpaceTypeString tNamespace tName+deriveFromJSON typeD@TypeD { tName, tCons, tNamespace }   | isEnum tCons = defineFromJSON name aesonEnum tCons-  | otherwise = defineFromJSON name (aesonUnionObject tNamespace) typeD-  where-    name = nameSpaceTypeString tNamespace tName+  | otherwise    = defineFromJSON name (aesonUnionObject tNamespace) typeD+  where name = nameSpaceTypeString tNamespace tName  aesonObject :: [String] -> ConsD -> ExpQ-aesonObject tNamespace con@ConsD {cName} =-  appE [|withObject name|] (lamE [varP (mkName "o")] ((aesonObjectBody tNamespace) con))-  where-    name = nameSpaceTypeString tNamespace cName+aesonObject tNamespace con@ConsD { cName } = appE+  [|withObject name|]+  (lamE [varP (mkName "o")] (aesonObjectBody tNamespace con))+  where name = nameSpaceTypeString tNamespace cName  aesonObjectBody :: [String] -> ConsD -> ExpQ-aesonObjectBody namespace ConsD {cName, cFields} = handleFields cFields-  where-    consName = mkName $ nameSpaceTypeString namespace cName-    -------------------------------------------    handleFields [] = fail $ "No Empty Object"-    handleFields fields = startExp fields-    -----------------------------------------------------------------------------------      -- Optional Field-      where-        defField field@DataField {fieldName}-          | isFieldNullable field = [|o .:? fName|]-          | otherwise = [|o .: fName|]-          where-            fName = unpack fieldName-            --------------------------------------------------------------------        startExp fNames = uInfixE (conE consName) (varE '(<$>)) (applyFields fNames)-          where-            applyFields []     = fail "No Empty fields"-            applyFields [x]    = defField x-            applyFields (x:xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs)+aesonObjectBody namespace ConsD { cName, cFields } = handleFields cFields+ where+  consName = mkName $ nameSpaceTypeString namespace cName+  ------------------------------------------+  handleFields []     = fail "No Empty Object"+  handleFields fields = startExp fields+  ----------------------------------------------------------------------------------+   where+    defField field@DataField { fieldName }+      | isFieldNullable field = [|o .:? fName|]+      | otherwise             = [|o .: fName|]+      where fName = unpack fieldName+        -------------------------------------------------------------------+    startExp fNames = uInfixE (conE consName)+                              (varE '(<$>))+                              (applyFields fNames)+     where+      applyFields []  = fail "No Empty fields"+      applyFields [x] = defField x+      applyFields (x : xs) =+        uInfixE (defField x) (varE '(<*>)) (applyFields xs)  aesonUnionObject :: [String] -> TypeD -> ExpQ-aesonUnionObject namespace TypeD {tCons} =-  appE (varE $ 'takeValueType) (lamCaseE ((map buildMatch tCons) <> [elseCaseEXP]))-  where-    buildMatch cons@ConsD {cName} = match pattern body []-      where-        pattern = tupP [litP (stringL cName), varP $ mkName "o"]-        body = normalB $ aesonObjectBody namespace cons+aesonUnionObject namespace TypeD { tCons } = appE+  (varE 'takeValueType)+  (lamCaseE (map buildMatch tCons <> [elseCaseEXP]))+ where+  buildMatch cons@ConsD { cName } = match objectPattern body []+   where+    objectPattern = tupP [litP (stringL cName), varP $ mkName "o"]+    body          = normalB $ aesonObjectBody namespace cons  takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a-takeValueType f (Object hMap) =-  case H.lookup "__typename" hMap of-    Nothing         -> fail "key \"__typename\" not found on object"-    Just (String x) -> pure (unpack x, hMap) >>= f-    Just val        -> fail $ "key \"__typename\" should be string but found: " <> show val-takeValueType _ _ = fail $ "expected Object"+takeValueType f (Object hMap) = case H.lookup "__typename" hMap of+  Nothing         -> fail "key \"__typename\" not found on object"+  Just (String x) -> pure (unpack x, hMap) >>= f+  Just val ->+    fail $ "key \"__typename\" should be string but found: " <> show val+takeValueType _ _ = fail "expected Object"  defineFromJSON :: String -> (t -> ExpQ) -> t -> DecQ defineFromJSON tName parseJ cFields = instanceD (cxt []) iHead [method]-  where-    iHead = instanceHeadT ''FromJSON tName []-    ------------------------------------------    method = instanceFunD 'parseJSON [] (parseJ cFields)+ where+  iHead  = instanceHeadT ''FromJSON tName []+  -----------------------------------------+  method = instanceFunD 'parseJSON [] (parseJ cFields)  isEnum :: [ConsD] -> Bool isEnum = not . isEmpty . filter (isEmpty . cFields)-  where-    isEmpty = (0 ==) . length+  where isEmpty = (0 ==) . length  aesonEnum :: [ConsD] -> ExpQ aesonEnum cons = lamCaseE handlers-  where-    handlers = (map buildMatch cons) <> [elseCaseEXP]-      where-        buildMatch ConsD {cName} = match pattern body []-          where-            pattern = litP $ stringL cName-            body = normalB $ appE (varE 'pure) (conE $ mkName cName)+ where+  handlers = map buildMatch cons <> [elseCaseEXP]+   where+    buildMatch ConsD { cName } = match enumPat body []+     where+      enumPat = litP $ stringL cName+      body    = normalB $ appE (varE 'pure) (conE $ mkName cName)  elseCaseEXP :: MatchQ elseCaseEXP = match (varP varName) body []-  where-    varName = mkName "invalidValue"-    body =-      normalB $-      appE-        (varE $ mkName "fail")-        (uInfixE (appE (varE 'show) (varE varName)) (varE '(<>)) (stringE $ " is Not Valid Union Constructor"))+ where+  varName = mkName "invalidValue"+  body    = normalB $ appE+    (varE $ mkName "fail")+    (uInfixE (appE (varE 'show) (varE varName))+             (varE '(<>))+             (stringE " is Not Valid Union Constructor")+    )  -- ToJSON deriveToJSON :: TypeD -> Q [Dec]-deriveToJSON TypeD {tCons = []} = fail "Type Should Have at least one Constructor"-deriveToJSON TypeD {tName, tCons = [ConsD {cFields}]} = pure <$> instanceD (cxt []) appHead methods-  where-    appHead = instanceHeadT ''ToJSON tName []-    -------------------------------------------------------------------    -- defines: toJSON (User field1 field2 ...)= object ["name" .= name, "age" .= age, ...]-    methods = [funD 'toJSON [clause argsE (normalB body) []]]-      where-        argsE = [destructRecord tName varNames]-        body = appE (varE 'object) (listE $ map decodeVar varNames)-        decodeVar name = [|name .= $(varName)|]-          where-            varName = varE $ mkName name-        varNames = map (unpack . fieldName) cFields-deriveToJSON TypeD {tName, tCons}-  | isEnum tCons = pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) []+deriveToJSON TypeD { tCons = [] } =+  fail "Type Should Have at least one Constructor"+deriveToJSON TypeD { tName, tCons = [ConsD { cFields }] } =+  pure <$> instanceD (cxt []) appHead methods+ where+  appHead = instanceHeadT ''ToJSON tName []+  ------------------------------------------------------------------+  -- defines: toJSON (User field1 field2 ...)= object ["name" .= name, "age" .= age, ...]+  methods = [funD 'toJSON [clause argsE (normalB body) []]]+   where+    argsE = [destructRecord tName varNames]+    body  = appE (varE 'object) (listE $ map decodeVar varNames)+    decodeVar name = [|name .= $(varName)|] where varName = varE $ mkName name+    varNames = map (unpack . fieldName) cFields+deriveToJSON TypeD { tName, tCons }+  | isEnum tCons+  = pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) []+  |     -- enum: uses default aeson instance derivation methods-  | otherwise = fail "Input Unions are not yet supported"+    otherwise+  = fail "Input Unions are not yet supported"

@@ -6,42 +6,70 @@  module Data.Morpheus.Execution.Client.Build   ( defineQuery-  ) where+  )+where -import           Data.Semigroup                           ((<>))+import           Data.Semigroup                 ( (<>) ) import           Language.Haskell.TH  -- -- MORPHEUS-import           Data.Morpheus.Error.Client.Client        (renderGQLErrors)-import           Data.Morpheus.Execution.Client.Aeson     (deriveFromJSON, deriveToJSON)-import           Data.Morpheus.Execution.Client.Compile   (validateWith)-import           Data.Morpheus.Execution.Client.Fetch     (deriveFetch)-import           Data.Morpheus.Execution.Internal.Declare (declareType)-import           Data.Morpheus.Types.Internal.Data        (DataTypeKind (..), DataTypeLib, isOutputObject)-import           Data.Morpheus.Types.Internal.DataD       (GQLTypeD (..), QueryD (..), TypeD (..))-import           Data.Morpheus.Types.Internal.Validation  (Validation)-import           Data.Morpheus.Types.Types                (GQLQueryRoot (..))+import           Data.Morpheus.Error.Client.Client+                                                ( renderGQLErrors+                                                , gqlWarnings+                                                )+import           Data.Morpheus.Execution.Client.Aeson+                                                ( deriveFromJSON+                                                , deriveToJSON+                                                )+import           Data.Morpheus.Execution.Client.Compile+                                                ( validateWith )+import           Data.Morpheus.Execution.Client.Fetch+                                                ( deriveFetch )+import           Data.Morpheus.Execution.Internal.Declare+                                                ( declareType ) -defineQuery :: IO (Validation DataTypeLib) -> (GQLQueryRoot, String) -> Q [Dec]+import           Data.Morpheus.Types.Internal.AST+                                                ( GQLQuery(..)+                                                , DataTypeKind(..)+                                                , DataTypeLib+                                                , isOutputObject+                                                , ClientType(..)+                                                , ClientQuery(..)+                                                , TypeD(..)+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation+                                                , Result(..)+                                                )++++defineQuery :: IO (Validation DataTypeLib) -> (GQLQuery, String) -> Q [Dec] defineQuery ioSchema queryRoot = do   schema <- runIO ioSchema   case schema >>= (`validateWith` queryRoot) of-    Left errors  -> fail (renderGQLErrors errors)-    Right queryD -> defineQueryD queryD+    Failure errors               -> fail (renderGQLErrors errors)+    Success { result, warnings } -> gqlWarnings warnings >> defineQueryD result -defineQueryD :: QueryD -> Q [Dec]-defineQueryD QueryD {queryTypes = rootType:subTypes, queryText, queryArgsType} = do-  rootDecs <- defineOperationType (queryArgumentType queryArgsType) queryText rootType-  subTypeDecs <- concat <$> traverse declareT subTypes-  return $ rootDecs ++ subTypeDecs-  where-    declareT GQLTypeD {typeD, typeKindD}-      | isOutputObject typeKindD || typeKindD == KindUnion = withToJSON declareOutputType typeD-      | typeKindD == KindEnum = withToJSON declareInputType typeD-      | otherwise = declareInputType typeD-defineQueryD QueryD {queryTypes = []} = return [] +defineQueryD :: ClientQuery -> Q [Dec]+defineQueryD ClientQuery { queryTypes = rootType : subTypes, queryText, queryArgsType }+  = do+    rootDecs <- defineOperationType (queryArgumentType queryArgsType)+                                    queryText+                                    rootType+    subTypeDecs <- concat <$> traverse declareT subTypes+    return $ rootDecs ++ subTypeDecs+ where+  declareT ClientType { clientType, clientKind }+    | isOutputObject clientKind || clientKind == KindUnion = withToJSON+      declareOutputType+      clientType+    | clientKind == KindEnum = withToJSON declareInputType clientType+    | otherwise = declareInputType clientType+defineQueryD ClientQuery { queryTypes = [] } = return []+ declareOutputType :: TypeD -> Q [Dec] declareOutputType typeD = pure [declareType False Nothing [''Show] typeD] @@ -53,16 +81,18 @@ withToJSON :: (TypeD -> Q [Dec]) -> TypeD -> Q [Dec] withToJSON f datatype = do   toJson <- deriveFromJSON datatype-  dec <- f datatype+  dec    <- f datatype   pure (toJson : dec)  queryArgumentType :: Maybe TypeD -> (Type, Q [Dec])-queryArgumentType Nothing                       = (ConT $ mkName "()", pure [])-queryArgumentType (Just rootType@TypeD {tName}) = (ConT $ mkName tName, declareInputType rootType)+queryArgumentType Nothing = (ConT $ mkName "()", pure [])+queryArgumentType (Just rootType@TypeD { tName }) =+  (ConT $ mkName tName, declareInputType rootType) -defineOperationType :: (Type, Q [Dec]) -> String -> GQLTypeD -> Q [Dec]-defineOperationType (argType, argumentTypes) query GQLTypeD {typeD} = do-  rootType <- withToJSON declareOutputType typeD-  typeClassFetch <- deriveFetch argType (tName typeD) query-  argsT <- argumentTypes-  pure $ rootType <> typeClassFetch <> argsT+defineOperationType :: (Type, Q [Dec]) -> String -> ClientType -> Q [Dec]+defineOperationType (argType, argumentTypes) query ClientType { clientType } =+  do+    rootType       <- withToJSON declareOutputType clientType+    typeClassFetch <- deriveFetch argType (tName clientType) query+    argsT          <- argumentTypes+    pure $ rootType <> typeClassFetch <> argsT

@@ -5,37 +5,60 @@ module Data.Morpheus.Execution.Client.Compile   ( compileSyntax   , validateWith-  ) where+  )+where -import qualified Data.Text                                  as T (pack)+import qualified Data.Text                     as T+                                                ( pack ) import           Language.Haskell.TH -import           Data.Morpheus.Error.Client.Client          (renderGQLErrors)--import           Data.Morpheus.Execution.Client.Selection   (operationTypes)-import           Data.Morpheus.Parsing.Request.Parser       (parseGQL)-import qualified Data.Morpheus.Types.Internal.AST.Operation as O (Operation (..))-import           Data.Morpheus.Types.Internal.Data          (DataTypeLib)-import           Data.Morpheus.Types.IO                     (GQLRequest (..))- -- --  Morpheus-import           Data.Morpheus.Types.Internal.DataD         (QueryD (..))-import           Data.Morpheus.Types.Internal.Validation    (Validation)-import           Data.Morpheus.Types.Types                  (GQLQueryRoot (..))-import           Data.Morpheus.Validation.Internal.Utils    (VALIDATION_MODE (..))-import           Data.Morpheus.Validation.Query.Validation  (validateRequest) ++import           Data.Morpheus.Error.Client.Client+                                                ( renderGQLErrors+                                                , gqlWarnings+                                                )++import           Data.Morpheus.Execution.Client.Selection+                                                ( operationTypes )+import           Data.Morpheus.Parsing.Request.Parser+                                                ( parseGQL )+import qualified Data.Morpheus.Types.Internal.AST+                                               as O+                                                ( Operation(..) )+import           Data.Morpheus.Types.IO         ( GQLRequest(..) )++import           Data.Morpheus.Types.Internal.AST+                                                ( GQLQuery(..)+                                                , DataTypeLib+                                                , ClientQuery(..)+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation+                                                , Result(..)+                                                )+import           Data.Morpheus.Validation.Internal.Utils+                                                ( VALIDATION_MODE(..) )+import           Data.Morpheus.Validation.Query.Validation+                                                ( validateRequest )+ compileSyntax :: String -> Q Exp-compileSyntax queryText =-  case parseGQL request of-    Left errors -> fail (renderGQLErrors errors)-    Right root  -> [|(root, queryText)|]-  where-    request = GQLRequest {query = T.pack queryText, operationName = Nothing, variables = Nothing}+compileSyntax queryText = case parseGQL request of+  Failure errors -> fail (renderGQLErrors errors)+  Success { result, warnings } ->+    gqlWarnings warnings >> [|(result, queryText)|]+ where+  request = GQLRequest { query         = T.pack queryText+                       , operationName = Nothing+                       , variables     = Nothing+                       } -validateWith :: DataTypeLib -> (GQLQueryRoot, String) -> Validation QueryD-validateWith schema (rawRequest@GQLQueryRoot {operation}, queryText) = do+validateWith :: DataTypeLib -> (GQLQuery, String) -> Validation ClientQuery+validateWith schema (rawRequest@GQLQuery { operation }, queryText) = do   validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest-  (queryArgsType, queryTypes) <- operationTypes schema (O.operationArgs operation) validOperation-  return QueryD {queryText, queryTypes, queryArgsType}+  (queryArgsType, queryTypes) <- operationTypes schema+                                                (O.operationArgs operation)+                                                validOperation+  return ClientQuery { queryText, queryTypes, queryArgsType }

@@ -8,27 +8,36 @@ module Data.Morpheus.Execution.Client.Fetch   ( Fetch(..)   , deriveFetch-  ) where+  )+where -import           Control.Monad                   ((>=>))-import           Data.Aeson                      (FromJSON, ToJSON (..), eitherDecode, encode)-import           Data.ByteString.Lazy            (ByteString)-import           Data.Text                       (pack)+import           Control.Monad                  ( (>=>) )+import           Data.Aeson                     ( FromJSON+                                                , ToJSON(..)+                                                , eitherDecode+                                                , encode+                                                )+import           Data.ByteString.Lazy           ( ByteString )+import           Data.Text                      ( pack ) import           Language.Haskell.TH  -import qualified Data.Aeson                      as A-import qualified Data.Aeson.Types                as A+import qualified Data.Aeson                    as A+import qualified Data.Aeson.Types              as A  -- -- MORPHEUS-import           Data.Morpheus.Types.Internal.TH (instanceHeadT, typeInstanceDec)-import           Data.Morpheus.Types.IO          (GQLRequest (..), JSONResponse (..))+import           Data.Morpheus.Types.Internal.TH+                                                ( instanceHeadT+                                                , typeInstanceDec+                                                )+import           Data.Morpheus.Types.IO         ( GQLRequest(..)+                                                , JSONResponse(..)+                                                )  fixVars :: A.Value -> Maybe A.Value-fixVars x-  | x == A.emptyArray = Nothing-  | otherwise         = Just x+fixVars x | x == A.emptyArray = Nothing+          | otherwise         = Just x  class Fetch a where   type Args a :: *@@ -48,10 +57,11 @@   fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either String a)  deriveFetch :: Type -> String -> String -> Q [Dec]-deriveFetch resultType typeName query = pure <$> instanceD (cxt []) iHead methods-  where-    iHead = instanceHeadT ''Fetch typeName []-    methods =-      [ funD 'fetch [clause [] (normalB [|__fetch query typeName|]) []]-      , pure $ typeInstanceDec  ''Args  (ConT $ mkName typeName) resultType-      ]+deriveFetch resultType typeName queryString =+  pure <$> instanceD (cxt []) iHead methods+ where+  iHead = instanceHeadT ''Fetch typeName []+  methods =+    [ funD 'fetch [clause [] (normalB [|__fetch queryString typeName|]) []]+    , pure $ typeInstanceDec ''Args (ConT $ mkName typeName) resultType+    ]

@@ -6,201 +6,302 @@  module Data.Morpheus.Execution.Client.Selection   ( operationTypes-  ) where+  )+where -import           Data.Maybe                                    (fromMaybe)-import           Data.Semigroup                                ((<>))-import           Data.Text                                     (Text, pack, unpack)+import           Data.Maybe                     ( fromMaybe )+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( Text+                                                , pack+                                                , unpack+                                                ) -- -- MORPHEUS-import           Data.Morpheus.Error.Utils                     (globalErrorMessage)-import           Data.Morpheus.Execution.Internal.GraphScanner (LibUpdater, resolveUpdates)-import           Data.Morpheus.Execution.Internal.Utils        (nameSpaceType)-import           Data.Morpheus.Types.Internal.AST.Operation    (DefaultValue, Operation (..), ValidOperation,-                                                                Variable (..), VariableDefinitions, getOperationName)-import           Data.Morpheus.Types.Internal.AST.Selection    (Selection (..), SelectionRec (..), SelectionSet,-                                                                ValidSelection)-import           Data.Morpheus.Types.Internal.Data             (DataField (..), DataType (..), DataTyCon (..),-                                                                DataTypeKind (..), DataTypeLib (..), Key,-                                                                TypeAlias (..), allDataTypes)-import           Data.Morpheus.Types.Internal.DataD            (ConsD (..), GQLTypeD (..), TypeD (..))-import           Data.Morpheus.Types.Internal.Validation       (GQLErrors, Validation)-import           Data.Morpheus.Validation.Internal.Utils       (lookupType)-import           Data.Set                                      (fromList, toList)+import           Data.Morpheus.Error.Client.Client+                                                ( deprecatedField )+import           Data.Morpheus.Error.Utils      ( globalErrorMessage )+import           Data.Morpheus.Execution.Internal.Utils+                                                ( nameSpaceType )+import           Data.Morpheus.Types.Internal.AST+                                                ( DefaultValue+                                                , Operation(..)+                                                , ValidOperation+                                                , Variable(..)+                                                , VariableDefinitions+                                                , getOperationName+                                                , getOperationDataType+                                                , Selection(..)+                                                , SelectionRec(..)+                                                , SelectionSet+                                                , ValidSelection+                                                , Ref(..) +                                                , DataField(..)+                                                , DataTyCon(..)+                                                , DataType(..)+                                                , DataTypeKind(..)+                                                , DataTypeLib(..)+                                                , Key+                                                , TypeAlias(..)+                                                , DataEnumValue(..)+                                                , allDataTypes+                                                , lookupType+                                                , ConsD(..)+                                                , ClientType(..)+                                                , TypeD(..)+                                                , lookupDeprecated+                                                , lookupDeprecatedReason+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( GQLErrors+                                                , Validation+                                                , Failure(..)+                                                , Result(..)+                                                , Position+                                                , LibUpdater+                                                , resolveUpdates+                                                )+import           Data.Set                       ( fromList+                                                , toList+                                                )  removeDuplicates :: [Text] -> [Text] removeDuplicates = toList . fromList  compileError :: Text -> GQLErrors-compileError x = globalErrorMessage $ "Unhandled Compile Time Error: \"" <> x <> "\" ;"+compileError x =+  globalErrorMessage $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" -operationTypes :: DataTypeLib -> VariableDefinitions -> ValidOperation -> Validation (Maybe TypeD, [GQLTypeD])+operationTypes+  :: DataTypeLib+  -> VariableDefinitions+  -> ValidOperation+  -> Validation (Maybe TypeD, [ClientType]) operationTypes lib variables = genOperation-  where-    genOperation Operation {operationName, operationSelection} = do-      (queryTypes, enums) <- genRecordType [] (getOperationName operationName) queryDataType operationSelection-      inputTypeRequests <- resolveUpdates [] $ map (scanInputTypes lib . variableType . snd) variables-      inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums)-      pure (rootArguments (getOperationName operationName <> "Args"), queryTypes <> inputTypesAndEnums)-      where-        queryDataType = DataObject $ snd $ query lib-    --------------------------------------------------------------------------    buildListedTypes = fmap concat . traverse (buildInputType lib) . removeDuplicates-    --------------------------------------------------------------------------    -- generates argument types for Operation Head-    rootArguments :: Text -> Maybe TypeD-    rootArguments argsName-      | null variables = Nothing-      | otherwise = Just rootArgumentsType+ where+  genOperation operation@Operation { operationName, operationSelection } = do+    datatype            <- DataObject <$> getOperationDataType operation lib+    (queryTypes, enums) <- genRecordType []+                                         (getOperationName operationName)+                                         datatype+                                         operationSelection+    inputTypeRequests <- resolveUpdates []+      $ map (scanInputTypes lib . variableType . snd) variables+    inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums)+    pure+      ( rootArguments (getOperationName operationName <> "Args")+      , queryTypes <> inputTypesAndEnums+      )+  -------------------------------------------------------------------------+  buildListedTypes =+    fmap concat . traverse (buildInputType lib) . removeDuplicates+  -------------------------------------------------------------------------+  -- generates argument types for Operation Head+  rootArguments :: Text -> Maybe TypeD+  rootArguments argsName | null variables = Nothing+                         | otherwise      = Just rootArgumentsType++   where+    rootArgumentsType :: TypeD+    rootArgumentsType = TypeD+      { tName      = unpack argsName+      , tNamespace = []+      , tCons      = [ ConsD { cName   = unpack argsName+                             , cFields = map fieldD variables+                             }+                     ]+      , tMeta      = Nothing+      }+     where+      fieldD :: (Text, Variable DefaultValue) -> DataField+      fieldD (key, Variable { variableType, variableTypeWrappers }) = DataField+        { fieldName     = key+        , fieldArgs     = []+        , fieldArgsType = Nothing+        , fieldType     = TypeAlias { aliasWrappers = variableTypeWrappers+                                    , aliasTyCon    = variableType+                                    , aliasArgs     = Nothing+                                    }+        , fieldMeta     = Nothing+        }+  ---------------------------------------------------------+  -- generates selection Object Types+  genRecordType+    :: [Key]+    -> Key+    -> DataType+    -> SelectionSet+    -> Validation ([ClientType], [Text])+  genRecordType path name dataType recordSelSet = do+    (con, subTypes, requests) <- genConsD (unpack name) dataType recordSelSet+    pure+      ( ClientType+          { clientType = TypeD { tName+                               , tNamespace = map unpack path+                               , tCons      = [con]+                               , tMeta      = Nothing+                               }+          , clientKind = KindObject Nothing+          }+        : subTypes+      , requests+      )+   where+    tName = unpack name+    genConsD+      :: String+      -> DataType+      -> SelectionSet+      -> Validation (ConsD, [ClientType], [Text])+    genConsD cName datatype selSet = do+      (cFields, subTypes, requests) <- unzip3 <$> traverse genField selSet+      pure (ConsD { cName, cFields }, concat subTypes, concat requests)+     where+      genField+        :: (Text, ValidSelection)+        -> Validation (DataField, [ClientType], [Text])+      genField (fName, sel@Selection { selectionAlias, selectionPosition }) =+        do+          (fieldDataType, fieldType) <- lookupFieldType lib+                                                        fieldPath+                                                        datatype+                                                        selectionPosition+                                                        fName+          (subTypes, requests) <- subTypesBySelection fieldDataType sel+          pure+            ( DataField { fieldName+                        , fieldArgs     = []+                        , fieldArgsType = Nothing+                        , fieldType+                        , fieldMeta     = Nothing+                        }+            , subTypes+            , requests+            )+       where+        fieldPath = path <> [fieldName]+        -------------------------------+        fieldName = fromMaybe fName selectionAlias         -------------------------------------------      where-        rootArgumentsType :: TypeD-        rootArgumentsType =-          TypeD-            { tName = unpack argsName-            , tNamespace = []-            , tCons = [ConsD {cName = unpack argsName, cFields = map fieldD variables}]-            }-          where-            fieldD :: (Text, Variable DefaultValue) -> DataField-            fieldD (key, Variable {variableType, variableTypeWrappers}) =-              DataField-                { fieldName = key-                , fieldArgs = []-                , fieldArgsType = Nothing-                , fieldType =-                    TypeAlias {aliasWrappers = variableTypeWrappers, aliasTyCon = variableType, aliasArgs = Nothing}-                , fieldHidden = False-                }-    ----------------------------------------------------------    -- generates selection Object Types-    genRecordType :: [Key] -> Key -> DataType -> SelectionSet -> Validation ([GQLTypeD], [Text])-    genRecordType path name dataType recordSelSet = do-      (con, subTypes, requests) <- genConsD (unpack name) dataType recordSelSet-      pure-        ( GQLTypeD-            { typeD = TypeD {tName, tNamespace = map unpack path, tCons = [con]}-            , typeKindD = KindObject Nothing-            , typeArgD = []-            } :-          subTypes-        , requests)-      where-        tName = unpack name-        genConsD :: String -> DataType -> SelectionSet -> Validation (ConsD, [GQLTypeD], [Text])-        genConsD cName datatype selSet = do-          cFields <- traverse genField selSet-          (subTypes, requests) <- newFieldTypes datatype selSet-          pure (ConsD {cName, cFields}, concat subTypes, concat requests)-          ----------------------------------------------------------------------------------------------          where-            genField :: (Text, ValidSelection) -> Validation DataField-            genField (fieldName, sel@Selection { selectionAlias }) = genFieldD sel-              where-                fieldPath = path <> [fromMaybe fieldName selectionAlias]-                --------------------------------                genFieldD Selection {selectionAlias = Just aliasFieldName} = do-                  fieldType <- snd <$> lookupFieldType lib fieldPath datatype fieldName-                  pure $ DataField {fieldName = aliasFieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}-                genFieldD _ = do-                  fieldType <- snd <$> lookupFieldType lib fieldPath datatype fieldName-                  pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}-            -------------------------------------------------------------------------------------------------------------            newFieldTypes :: DataType -> SelectionSet -> Validation ([[GQLTypeD]], [[Text]])-            newFieldTypes parentType seSet = unzip <$> mapM valSelection seSet-              where-                valSelection (key, selection@Selection { selectionAlias }) = do-                  fieldDatatype <- fst <$> lookupFieldType lib fieldPath parentType key-                  validateSelection fieldDatatype selection-                  ---------------------------------------------------------------------                  where-                    fieldPath = path <> [fromMaybe key selectionAlias]-                    ---------------------------------------------------------------------                    validateSelection :: DataType -> ValidSelection -> Validation ([GQLTypeD], [Text])-                    validateSelection dType Selection {selectionRec = SelectionField} = leafType dType-                    --withLeaf buildLeaf dType-                    validateSelection dType Selection {selectionRec = SelectionSet selectionSet} =-                      genRecordType fieldPath (typeFrom [] dType) dType selectionSet-                    ---- UNION-                    validateSelection dType Selection {selectionRec = UnionSelection unionSelections} = do-                      (tCons, subTypes, requests) <- unzip3 <$> mapM getUnionType unionSelections-                      pure-                        ( GQLTypeD-                            { typeD =-                                TypeD {tNamespace = map unpack fieldPath, tName = unpack $ typeFrom [] dType, tCons}-                            , typeKindD = KindUnion-                            , typeArgD = []-                            } :-                          concat subTypes-                        , concat requests)-                      where-                        getUnionType (selectedTyName, selectionVariant) = do-                          conDatatype <- getType lib selectedTyName-                          genConsD (unpack selectedTyName) conDatatype selectionVariant+        subTypesBySelection+          :: DataType -> ValidSelection -> Validation ([ClientType], [Text])+        subTypesBySelection dType Selection { selectionRec = SelectionField } =+          leafType dType+          --withLeaf buildLeaf dType+        subTypesBySelection dType Selection { selectionRec = SelectionSet selectionSet }+          = genRecordType fieldPath (typeFrom [] dType) dType selectionSet+          ---- UNION+        subTypesBySelection dType Selection { selectionRec = UnionSelection unionSelections }+          = do+            (tCons, subTypes, requests) <-+              unzip3 <$> mapM getUnionType unionSelections+            pure+              ( ClientType+                  { clientType = TypeD { tNamespace = map unpack fieldPath+                                       , tName      = unpack $ typeFrom [] dType+                                       , tCons+                                       , tMeta      = Nothing+                                       }+                  , clientKind = KindUnion+                  }+                : concat subTypes+              , concat requests+              )+         where+          getUnionType (selectedTyName, selectionVariant) = do+            conDatatype <- getType lib selectedTyName+            genConsD (unpack selectedTyName) conDatatype selectionVariant  scanInputTypes :: DataTypeLib -> Key -> LibUpdater [Key]-scanInputTypes lib name collected-  | name `elem` collected = pure collected-  | otherwise = getType lib name >>= scanType-  where-    scanType (DataInputObject DataTyCon {typeData}) = resolveUpdates (name : collected) (map toInputTypeD typeData)-      where-        toInputTypeD :: (Text, DataField) -> LibUpdater [Key]-        toInputTypeD (_, DataField {fieldType = TypeAlias {aliasTyCon}}) = scanInputTypes lib aliasTyCon-    scanType (DataEnum DataTyCon {typeName}) = pure (collected <> [typeName])-    scanType _ = pure collected+scanInputTypes lib name collected | name `elem` collected = pure collected+                                  | otherwise = getType lib name >>= scanType+ where+  scanType (DataInputObject DataTyCon { typeData }) = resolveUpdates+    (name : collected)+    (map toInputTypeD typeData)+   where+    toInputTypeD :: (Text, DataField) -> LibUpdater [Key]+    toInputTypeD (_, DataField { fieldType = TypeAlias { aliasTyCon } }) =+      scanInputTypes lib aliasTyCon+  scanType (DataEnum DataTyCon { typeName }) = pure (collected <> [typeName])+  scanType _ = pure collected -buildInputType :: DataTypeLib -> Text -> Validation [GQLTypeD]+buildInputType :: DataTypeLib -> Text -> Validation [ClientType] buildInputType lib name = getType lib name >>= subTypes-  where-    subTypes (DataInputObject DataTyCon {typeName, typeData}) = do-      fields <- traverse toFieldD typeData-      pure-        [ GQLTypeD-            { typeD =-                TypeD-                  { tName = unpack typeName-                  , tNamespace = []-                  , tCons = [ConsD {cName = unpack typeName, cFields = fields}]-                  }-            , typeArgD = []-            , typeKindD = KindInputObject-            }-        ]-          -----------------------------------------------------------------      where-        toFieldD :: (Text, DataField) -> Validation DataField-        toFieldD (_, field@DataField {fieldType}) = do-          aliasTyCon <- typeFrom [] <$> getType lib (aliasTyCon fieldType)-          pure $ field {fieldType = fieldType {aliasTyCon}}-    subTypes (DataEnum DataTyCon {typeName, typeData}) =-      pure-        [ GQLTypeD-            { typeD = TypeD {tName = unpack typeName, tNamespace = [], tCons = map enumOption typeData}-            , typeArgD = []-            , typeKindD = KindEnum-            }-        ]-      where-        enumOption eName = ConsD {cName = unpack eName, cFields = []}-    subTypes _ = pure []+ where+  subTypes (DataInputObject DataTyCon { typeName, typeData }) = do+    fields <- traverse toFieldD typeData+    pure+      [ ClientType+          { clientType =+            TypeD+              { tName      = unpack typeName+              , tNamespace = []+              , tCons = [ConsD { cName = unpack typeName, cFields = fields }]+              , tMeta      = Nothing+              }+          , clientKind = KindInputObject+          }+      ] -lookupFieldType :: DataTypeLib -> [Key] -> DataType -> Text -> Validation (DataType, TypeAlias)-lookupFieldType lib path (DataObject DataTyCon {typeData}) key =-  case lookup key typeData of-    Just DataField {fieldType = alias@TypeAlias {aliasTyCon}} -> trans <$> getType lib aliasTyCon-      where trans x = (x, alias {aliasTyCon = typeFrom path x, aliasArgs = Nothing})-    Nothing -> Left (compileError $ "cant find field \""<> key<>"\"")-lookupFieldType _ _ dt _ = Left (compileError $ "Type should be output Object \"" <> pack (show dt))+   where+    toFieldD :: (Text, DataField) -> Validation DataField+    toFieldD (_, field@DataField { fieldType }) = do+      aliasTyCon <- typeFrom [] <$> getType lib (aliasTyCon fieldType)+      pure $ field { fieldType = fieldType { aliasTyCon } }+  subTypes (DataEnum DataTyCon { typeName, typeData }) = pure+    [ ClientType+        { clientType = TypeD { tName      = unpack typeName+                             , tNamespace = []+                             , tCons      = map enumOption typeData+                             , tMeta      = Nothing+                             }+        , clientKind = KindEnum+        }+    ]+   where+    enumOption DataEnumValue { enumName } =+      ConsD { cName = unpack enumName, cFields = [] }+  subTypes _ = pure []  -leafType :: DataType -> Validation ([GQLTypeD], [Text])-leafType (DataEnum DataTyCon {typeName}) = pure ([],[typeName])-leafType DataScalar {}                   = pure ([],[])-leafType _                               = Left $ compileError "Invalid schema Expected scalar"+lookupFieldType+  :: DataTypeLib+  -> [Key]+  -> DataType+  -> Position+  -> Text+  -> Validation (DataType, TypeAlias)+lookupFieldType lib path (DataObject DataTyCon { typeData, typeName }) refPosition key+  = case lookup key typeData of+    Just DataField { fieldType = alias@TypeAlias { aliasTyCon }, fieldMeta } ->+      checkDeprecated >> (trans <$> getType lib aliasTyCon)+     where+      trans x =+        (x, alias { aliasTyCon = typeFrom path x, aliasArgs = Nothing })+      ------------------------------------------------------------------+      checkDeprecated :: Validation ()+      checkDeprecated = case fieldMeta >>= lookupDeprecated of+        Just deprecation -> Success { result = (), warnings, events = [] }+         where+          warnings = deprecatedField typeName+                                     Ref { refName = key, refPosition }+                                     (lookupDeprecatedReason deprecation)+        Nothing -> pure ()+    ------------------+    Nothing -> failure+      (compileError $ "cant find field \"" <> pack (show typeData) <> "\"")+lookupFieldType _ _ dt _ _ =+  failure (compileError $ "Type should be output Object \"" <> pack (show dt)) ++leafType :: DataType -> Validation ([ClientType], [Text])+leafType (DataEnum DataTyCon { typeName }) = pure ([], [typeName])+leafType DataScalar{} = pure ([], [])+leafType _ = failure $ compileError "Invalid schema Expected scalar"+ getType :: DataTypeLib -> Text -> Validation DataType-getType lib typename = lookupType (compileError typename) (allDataTypes lib) typename+getType lib typename =+  lookupType (compileError typename) (allDataTypes lib) typename  typeFromScalar :: Text -> Text typeFromScalar "Boolean" = "Bool"@@ -211,9 +312,9 @@ typeFromScalar _         = "ScalarValue"  typeFrom :: [Key] -> DataType -> Text-typeFrom _ (DataScalar DataTyCon {typeName}) = typeFromScalar typeName-typeFrom _ (DataEnum x)                      = typeName x-typeFrom _ (DataInputObject x)               = typeName x-typeFrom path (DataObject x)                 = pack $ nameSpaceType path $ typeName x-typeFrom path (DataUnion x)                  = pack $ nameSpaceType path $ typeName x-typeFrom _ (DataInputUnion x)                = typeName x+typeFrom _ (DataScalar DataTyCon { typeName }) = typeFromScalar typeName+typeFrom _ (DataEnum x) = typeName x+typeFrom _ (DataInputObject x) = typeName x+typeFrom path (DataObject x) = pack $ nameSpaceType path $ typeName x+typeFrom path (DataUnion x) = pack $ nameSpaceType path $ typeName x+typeFrom _ (DataInputUnion x) = typeName x

@@ -1,47 +1,61 @@-{-# LANGUAGE NamedFieldPuns #-}+{-#LANGUAGE NamedFieldPuns #-}  module Data.Morpheus.Execution.Document.Compile   ( compileDocument   , gqlDocument   , gqlDocumentNamespace-  ) where+  )+where -import qualified Data.Text                                    as T (pack)+import qualified Data.Text                     as T+                                                ( pack ) import           Language.Haskell.TH import           Language.Haskell.TH.Quote  -- --  Morpheus-import           Data.Morpheus.Error.Client.Client            (renderGQLErrors)-import           Data.Morpheus.Execution.Document.Convert     (renderTHTypes)-import           Data.Morpheus.Execution.Document.Declare     (declareTypes)-import           Data.Morpheus.Parsing.Document.Parser        (parseTypes)+import           Data.Morpheus.Error.Client.Client+                                                ( renderGQLErrors+                                                , gqlWarnings+                                                )+import           Data.Morpheus.Execution.Document.Convert+                                                ( renderTHTypes )+import           Data.Morpheus.Execution.Document.Declare+                                                ( declareTypes )+import           Data.Morpheus.Parsing.Document.Parser+                                                ( parseTypes ) import           Data.Morpheus.Validation.Document.Validation+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Result(..) ) + gqlDocumentNamespace :: QuasiQuoter-gqlDocumentNamespace =-  QuasiQuoter-    { quoteExp = notHandled "Expressions"-    , quotePat = notHandled "Patterns"-    , quoteType = notHandled "Types"-    , quoteDec = compileDocument True-    }-  where-    notHandled things = error $ things ++ " are not supported by the GraphQL QuasiQuoter"+gqlDocumentNamespace = QuasiQuoter { quoteExp  = notHandled "Expressions"+                                   , quotePat  = notHandled "Patterns"+                                   , quoteType = notHandled "Types"+                                   , quoteDec  = compileDocument True+                                   }+ where+  notHandled things =+    error $ things ++ " are not supported by the GraphQL QuasiQuoter"  gqlDocument :: QuasiQuoter-gqlDocument =-  QuasiQuoter-    { quoteExp = notHandled "Expressions"-    , quotePat = notHandled "Patterns"-    , quoteType = notHandled "Types"-    , quoteDec = compileDocument False-    }-  where-    notHandled things = error $ things ++ " are not supported by the GraphQL QuasiQuoter"+gqlDocument = QuasiQuoter { quoteExp  = notHandled "Expressions"+                          , quotePat  = notHandled "Patterns"+                          , quoteType = notHandled "Types"+                          , quoteDec  = compileDocument False+                          }+ where+  notHandled things =+    error $ things ++ " are not supported by the GraphQL QuasiQuoter"  compileDocument :: Bool -> String -> Q [Dec] compileDocument namespace documentTXT =-  case parseTypes (T.pack documentTXT) >>= validatePartialDocument >>= renderTHTypes namespace of-    Left errors  -> fail (renderGQLErrors errors)-    Right schema -> declareTypes namespace schema+  case+      parseTypes (T.pack documentTXT)+      >>= validatePartialDocument+      >>= renderTHTypes namespace+    of+      Failure errors -> fail (renderGQLErrors errors)+      Success { result = schema, warnings } ->+        gqlWarnings warnings >> declareTypes namespace schema

@@ -6,140 +6,180 @@  module Data.Morpheus.Execution.Document.Convert   ( renderTHTypes-  ) where+  )+where -import           Data.Semigroup                          ((<>))-import           Data.Text                               (Text, pack, unpack)+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( Text+                                                , pack+                                                , unpack+                                                )  -- -- MORPHEUS-import           Data.Morpheus.Error.Internal            (internalError)-import           Data.Morpheus.Execution.Internal.Utils  (capital)-import           Data.Morpheus.Types.Internal.Data       (ArgsType (..), DataField (..), DataType (..),-                                                          DataTyCon (..), DataTypeKind (..), OperationType (..),-                                                          ResolverKind (..), TypeAlias (..), sysTypes)-import           Data.Morpheus.Types.Internal.DataD      (ConsD (..), GQLTypeD (..), TypeD (..))-import           Data.Morpheus.Types.Internal.Validation (Validation)+import           Data.Morpheus.Error.Internal   ( internalError )+import           Data.Morpheus.Execution.Internal.Utils+                                                ( capital )+import           Data.Morpheus.Types.Internal.AST+                                                ( ArgsType(..)+                                                , DataField(..)+                                                , DataTyCon(..)+                                                , DataType(..)+                                                , DataTypeKind(..)+                                                , OperationType(..)+                                                , ResolverKind(..)+                                                , TypeAlias(..)+                                                , DataEnumValue(..)+                                                , sysTypes+                                                , ConsD(..)+                                                , GQLTypeD(..)+                                                , TypeD(..)+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation )  renderTHTypes :: Bool -> [(Text, DataType)] -> Validation [GQLTypeD] renderTHTypes namespace lib = traverse renderTHType lib-  where-    renderTHType :: (Text, DataType) -> Validation GQLTypeD-    renderTHType (tyConName, x) = genType x-      where-        genArgsTypeName fieldName-          | namespace = sysName tyConName <> argTName-          | otherwise = argTName-          where-            argTName = capital fieldName <> "Args"-        genArgumentType :: (Text, DataField) -> Validation [TypeD]-        genArgumentType (_, DataField {fieldArgs = []}) = pure []-        genArgumentType (fieldName, DataField {fieldArgs}) =-          pure-            [ TypeD-                { tName-                , tNamespace = []-                , tCons = [ConsD {cName = sysName $ pack tName, cFields = map genField fieldArgs}]-                }-            ]-          where-            tName = genArgsTypeName $ sysName fieldName-        --------------------------------------------        genFieldTypeName = genTypeName-        -------------------------------        --genTypeName :: Text -> Text-        genTypeName "String" = "Text"-        genTypeName "Boolean" = "Bool"-        genTypeName name-          | name `elem` sysTypes = "S" <> name-        genTypeName name = name-        -----------------------------------------        sysName = unpack . genTypeName-        ----------------------------------------------------------------------------------------------        genField :: (Text, DataField) -> DataField-        genField (_, field@DataField {fieldType = alias@TypeAlias {aliasTyCon}}) =-          field {fieldType = alias {aliasTyCon = genFieldTypeName aliasTyCon}}-        ----------------------------------------------------------------------------------------------        genResField :: (Text, DataField) -> DataField-        genResField (_, field@DataField {fieldName, fieldArgs, fieldType = alias@TypeAlias {aliasTyCon}}) =-          field {fieldType = alias {aliasTyCon = ftName, aliasArgs}, fieldArgsType}-          where-            ftName = genFieldTypeName aliasTyCon-            ----------------------------------------            aliasArgs =-              case lookup aliasTyCon lib of-                Just DataObject {} -> Just "m"-                Just DataUnion {}  -> Just "m"-                _                  -> Nothing-            ------------------------------------            fieldArgsType = Just $ ArgsType {argsTypeName, resKind = getFieldType ftName}-              where-                argsTypeName-                  | null fieldArgs = "()"-                  | otherwise = pack $ genArgsTypeName $ unpack fieldName-                ---------------------------------------                getFieldType key =-                  case lookup key lib of-                    Nothing            -> ExternalResolver-                    Just DataObject {} -> TypeVarResolver-                    Just DataUnion {}  -> TypeVarResolver-                    Just _             -> PlainResolver-        ---------------------------------------------        genType (DataEnum DataTyCon {typeName, typeData}) =-          pure-            GQLTypeD-              { typeD = TypeD {tName = sysName typeName, tNamespace = [], tCons = map enumOption typeData}-              , typeKindD = KindEnum-              , typeArgD = []-              }-          where-            enumOption name = ConsD {cName = sysName name, cFields = []}-        genType (DataScalar _) = internalError "Scalar Types should defined By Native Haskell Types"-        genType (DataInputUnion _) = internalError "Input Unions not Supported"-        genType (DataInputObject DataTyCon {typeName, typeData}) =-          pure-            GQLTypeD-              { typeD =-                  TypeD-                    { tName = sysName typeName-                    , tNamespace = []-                    , tCons = [ConsD {cName = sysName typeName, cFields = map genField typeData}]-                    }-              , typeKindD = KindInputObject-              , typeArgD = []+ where+  renderTHType :: (Text, DataType) -> Validation GQLTypeD+  renderTHType (tyConName, x) = genType x+   where+    genArgsTypeName fieldName | namespace = sysName tyConName <> argTName+                              | otherwise = argTName+      where argTName = capital fieldName <> "Args"+    genArgumentType :: (Text, DataField) -> Validation [TypeD]+    genArgumentType (_        , DataField { fieldArgs = [] }) = pure []+    genArgumentType (fieldName, DataField { fieldArgs }     ) = pure+      [ TypeD+          { tName+          , tNamespace = []+          , tCons      = [ ConsD { cName   = sysName $ pack tName+                                 , cFields = map genField fieldArgs+                                 }+                         ]+          , tMeta      = Nothing+          }+      ]+      where tName = genArgsTypeName $ sysName fieldName+    -------------------------------------------+    genFieldTypeName = genTypeName+    ------------------------------+    --genTypeName :: Text -> Text+    genTypeName "String"                    = "Text"+    genTypeName "Boolean"                   = "Bool"+    genTypeName name | name `elem` sysTypes = "S" <> name+    genTypeName name                        = name+    ----------------------------------------+    sysName = unpack . genTypeName+    ---------------------------------------------------------------------------------------------+    genField :: (Text, DataField) -> DataField+    genField (_, field@DataField { fieldType = alias@TypeAlias { aliasTyCon } })+      = field { fieldType = alias { aliasTyCon = genFieldTypeName aliasTyCon }               }-        genType (DataObject DataTyCon {typeName, typeData}) = do-          typeArgD <- concat <$> traverse genArgumentType typeData-          pure-            GQLTypeD-              { typeD =-                  TypeD-                    { tName = sysName typeName-                    , tNamespace = []-                    , tCons = [ConsD {cName = sysName typeName, cFields = map genResField typeData}]-                    }-              , typeKindD =-                  if typeName == "Subscription"-                    then KindObject (Just Subscription)-                    else KindObject Nothing-              , typeArgD+    ---------------------------------------------------------------------------------------------+    genResField :: (Text, DataField) -> DataField+    genResField (_, field@DataField { fieldName, fieldArgs, fieldType = alias@TypeAlias { aliasTyCon } })+      = field { fieldType     = alias { aliasTyCon = ftName, aliasArgs }+              , fieldArgsType               }-        genType (DataUnion DataTyCon {typeName, typeData}) = do-          let tCons = map unionCon typeData-          pure-            GQLTypeD-              {typeD = TypeD {tName = unpack typeName, tNamespace = [], tCons}, typeKindD = KindUnion, typeArgD = []}-          where-            unionCon field@DataField {fieldType} =-              ConsD-                { cName-                , cFields =-                    [ field-                        { fieldName = pack $ "un" <> cName-                        , fieldType = TypeAlias {aliasTyCon = pack utName, aliasArgs = Just "m", aliasWrappers = []}+     where+      ftName    = genFieldTypeName aliasTyCon+      ---------------------------------------+      aliasArgs = case lookup aliasTyCon lib of+        Just DataObject{} -> Just "m"+        Just DataUnion{}  -> Just "m"+        _                 -> Nothing+      -----------------------------------+      fieldArgsType = Just+        $ ArgsType { argsTypeName, resKind = getFieldType ftName }+       where+        argsTypeName | null fieldArgs = "()"+                     | otherwise = pack $ genArgsTypeName $ unpack fieldName+        --------------------------------------+        getFieldType key = case lookup key lib of+          Nothing           -> ExternalResolver+          Just DataObject{} -> TypeVarResolver+          Just DataUnion{}  -> TypeVarResolver+          Just _            -> PlainResolver+    --------------------------------------------+    genType dt@(DataEnum DataTyCon { typeName, typeData, typeMeta }) = pure+      GQLTypeD+        { typeD        = TypeD { tName      = sysName typeName+                               , tNamespace = []+                               , tCons      = map enumOption typeData+                               , tMeta      = typeMeta+                               }+        , typeKindD    = KindEnum+        , typeArgD     = []+        , typeOriginal = (typeName, dt)+        }+     where+      enumOption DataEnumValue { enumName } =+        ConsD { cName = sysName enumName, cFields = [] }+    genType (DataScalar _) =+      internalError "Scalar Types should defined By Native Haskell Types"+    genType (DataInputUnion _) = internalError "Input Unions not Supported"+    genType dt@(DataInputObject DataTyCon { typeName, typeData, typeMeta }) =+      pure GQLTypeD+        { typeD        =+          TypeD+            { tName      = sysName typeName+            , tNamespace = []+            , tCons      = [ ConsD { cName   = sysName typeName+                                   , cFields = map genField typeData+                                   }+                           ]+            , tMeta      = typeMeta+            }+        , typeKindD    = KindInputObject+        , typeArgD     = []+        , typeOriginal = (typeName, dt)+        }+    genType dt@(DataObject DataTyCon { typeName, typeData, typeMeta }) = do+      typeArgD <- concat <$> traverse genArgumentType typeData+      pure GQLTypeD+        { typeD        = TypeD+                           { tName      = sysName typeName+                           , tNamespace = []+                           , tCons = [ ConsD { cName = sysName typeName+                                             , cFields = map genResField typeData+                                             }+                                     ]+                           , tMeta      = typeMeta+                           }+        , typeKindD    = if typeName == "Subscription"+                           then KindObject (Just Subscription)+                           else KindObject Nothing+        , typeArgD+        , typeOriginal = (typeName, dt)+        }+    genType dt@(DataUnion DataTyCon { typeName, typeData, typeMeta }) = do+      let tCons = map unionCon typeData+      pure GQLTypeD+        { typeD        = TypeD { tName      = unpack typeName+                               , tNamespace = []+                               , tCons+                               , tMeta      = typeMeta+                               }+        , typeKindD    = KindUnion+        , typeArgD     = []+        , typeOriginal = (typeName, dt)+        }+     where+      unionCon memberName = ConsD+        { cName+        , cFields = [ DataField+                        { fieldName     = pack $ "un" <> cName+                        , fieldType     = TypeAlias { aliasTyCon = pack utName+                                                    , aliasArgs = Just "m"+                                                    , aliasWrappers = []+                                                    }+                        , fieldMeta     = Nothing+                        , fieldArgs     = []+                        , fieldArgsType = Nothing                         }                     ]-                }-              where-                cName = sysName typeName <> utName-                utName = sysName $ aliasTyCon fieldType+        }+       where+        cName  = sysName typeName <> utName+        utName = sysName memberName

@@ -4,51 +4,67 @@  module Data.Morpheus.Execution.Document.Declare   ( declareTypes-  ) where+  )+where -import           Data.Semigroup                              ((<>))+import           Data.Semigroup                 ( (<>) ) import           Language.Haskell.TH  -- -- MORPHEUS-import           Data.Morpheus.Execution.Document.Decode     (deriveDecode)-import           Data.Morpheus.Execution.Document.Encode     (deriveEncode)-import           Data.Morpheus.Execution.Document.GQLType    (deriveGQLType)-import           Data.Morpheus.Execution.Document.Introspect (deriveObjectRep)-import           Data.Morpheus.Execution.Internal.Declare    (declareType)-import           Data.Morpheus.Types.Internal.Data           (isInput, isObject)-import           Data.Morpheus.Types.Internal.DataD          (GQLTypeD (..))+import           Data.Morpheus.Execution.Document.Decode+                                                ( deriveDecode )+import           Data.Morpheus.Execution.Document.Encode+                                                ( deriveEncode )+import           Data.Morpheus.Execution.Document.GQLType+                                                ( deriveGQLType )+import           Data.Morpheus.Execution.Document.Introspect+                                                ( deriveObjectRep+                                                , instanceIntrospect+                                                )+import           Data.Morpheus.Execution.Internal.Declare+                                                ( declareType )+import           Data.Morpheus.Types.Internal.AST+                                                ( isInput+                                                , isObject+                                                , GQLTypeD(..)+                                                )  declareTypes :: Bool -> [GQLTypeD] -> Q [Dec] declareTypes namespace = fmap concat . traverse (declareGQLType namespace)  declareGQLType :: Bool -> GQLTypeD -> Q [Dec]-declareGQLType namespace gqlType@GQLTypeD {typeD, typeKindD, typeArgD} = do-  mainType <- declareMainType-  argTypes <- declareArgTypes-  gqlInstances <- deriveGQLInstances-  typeClasses <- deriveGQLType gqlType-  pure $ mainType <> typeClasses <> argTypes <> gqlInstances-  where-    deriveGQLInstances = concat <$> sequence gqlInstances-      where-        gqlInstances-          | isObject typeKindD && isInput typeKindD = [deriveObjectRep (typeD, Just typeKindD), deriveDecode typeD]-          | isObject typeKindD = [deriveObjectRep (typeD, Just typeKindD), deriveEncode gqlType]-          | otherwise = []-    ---------------------------------------------------    declareArgTypes = do-      introspectArgs <- concat <$> traverse deriveArgsRep typeArgD-      decodeArgs <- concat <$> traverse deriveDecode typeArgD-      return $ argsTypeDecs <> decodeArgs <> introspectArgs-      where-        deriveArgsRep args = deriveObjectRep (args, Nothing)-        -----------------------------------------------------        argsTypeDecs = map (declareType namespace Nothing []) typeArgD-        ---------------------------------------------------    declareMainType = declareT-      where-        declareT = pure [declareType namespace (Just typeKindD) derivingClasses typeD]-        derivingClasses-          | isInput typeKindD = [''Show]-          | otherwise = []+declareGQLType namespace gqlType@GQLTypeD { typeD, typeKindD, typeArgD, typeOriginal }+  = do+    mainType       <- declareMainType+    argTypes       <- declareArgTypes+    gqlInstances   <- deriveGQLInstances+    typeClasses    <- deriveGQLType gqlType+    introspectEnum <- instanceIntrospect typeOriginal+    pure $ mainType <> typeClasses <> argTypes <> gqlInstances <> introspectEnum+ where+  deriveGQLInstances = concat <$> sequence gqlInstances+   where+    gqlInstances+      | isObject typeKindD && isInput typeKindD+      = [deriveObjectRep (typeD, Just typeKindD), deriveDecode typeD]+      | isObject typeKindD+      = [deriveObjectRep (typeD, Just typeKindD), deriveEncode gqlType]+      | otherwise+      = []+  --------------------------------------------------+  declareArgTypes = do+    introspectArgs <- concat <$> traverse deriveArgsRep typeArgD+    decodeArgs     <- concat <$> traverse deriveDecode typeArgD+    return $ argsTypeDecs <> decodeArgs <> introspectArgs+   where+    deriveArgsRep args = deriveObjectRep (args, Nothing)+    ----------------------------------------------------+    argsTypeDecs = map (declareType namespace Nothing []) typeArgD+      --------------------------------------------------+  declareMainType = declareT+   where+    declareT =+      pure [declareType namespace (Just typeKindD) derivingClasses typeD]+    derivingClasses | isInput typeKindD = [''Show]+                    | otherwise         = []

@@ -7,29 +7,42 @@  module Data.Morpheus.Execution.Document.Decode   ( deriveDecode-  ) where+  )+where -import           Data.Text                               (Text)+import           Data.Text                      ( Text ) import           Language.Haskell.TH  -- -- MORPHEUS-import           Data.Morpheus.Execution.Internal.Decode (decodeFieldWith, decodeObjectExpQ)-import           Data.Morpheus.Execution.Server.Decode   (Decode (..), DecodeObject (..))-import           Data.Morpheus.Types.Internal.DataD      (TypeD (..))-import           Data.Morpheus.Types.Internal.TH         (instanceHeadT)-import           Data.Morpheus.Types.Internal.Validation (Validation)-import           Data.Morpheus.Types.Internal.Value      (Object)+import           Data.Morpheus.Execution.Internal.Decode+                                                ( decodeFieldWith+                                                , decodeObjectExpQ+                                                )+import           Data.Morpheus.Execution.Server.Decode+                                                ( Decode(..)+                                                , DecodeObject(..)+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( TypeD(..)+                                                , Object+                                                )+import           Data.Morpheus.Types.Internal.TH+                                                ( instanceHeadT )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation ) + (.:) :: Decode a => Object -> Text -> Validation a object .: selectorName = decodeFieldWith decode selectorName object  deriveDecode :: TypeD -> Q [Dec]-deriveDecode TypeD {tName, tCons = [cons]} = pure <$> instanceD (cxt []) appHead methods-  where-    appHead = instanceHeadT ''DecodeObject tName []-    methods = [funD 'decodeObject [clause argsE (normalB body) []]]-      where-        argsE = map (varP . mkName) ["o"]-        body = decodeObjectExpQ [|(.:)|] cons+deriveDecode TypeD { tName, tCons = [cons] } =+  pure <$> instanceD (cxt []) appHead methods+ where+  appHead = instanceHeadT ''DecodeObject tName []+  methods = [funD 'decodeObject [clause argsE (normalB body) []]]+   where+    argsE = map (varP . mkName) ["o"]+    body  = decodeObjectExpQ [|(.:)|] cons deriveDecode _ = pure []

@@ -5,65 +5,98 @@  module Data.Morpheus.Execution.Document.Encode   ( deriveEncode-  ) where+  )+where -import           Data.Text                             (unpack)-import           Data.Typeable                         (Typeable)+import           Data.Text                      ( unpack )+import           Data.Typeable                  ( Typeable ) import           Language.Haskell.TH-import           Data.Semigroup                        ((<>))+import           Data.Semigroup                 ( (<>) )  -- -- MORPHEUS-import           Data.Morpheus.Execution.Server.Encode (Encode (..), ObjectResolvers (..))-import           Data.Morpheus.Types.GQLType           (TRUE)-import           Data.Morpheus.Types.Internal.Data     (DataField (..), QUERY, SUBSCRIPTION, isSubscription)-import           Data.Morpheus.Types.Internal.DataD    (ConsD (..), GQLTypeD (..), TypeD (..))-import           Data.Morpheus.Types.Internal.Resolver (Resolver, MapGraphQLT (..), Resolving,PureOperation)-import           Data.Morpheus.Types.Internal.TH       (applyT, destructRecord, instanceHeadMultiT, typeT)+import           Data.Morpheus.Execution.Server.Encode+                                                ( Encode(..)+                                                , ObjectResolvers(..)+                                                )+import           Data.Morpheus.Types.GQLType    ( TRUE )+import           Data.Morpheus.Types.Internal.AST+                                                ( DataField(..)+                                                , QUERY+                                                , SUBSCRIPTION+                                                , isSubscription+                                                , ConsD(..)+                                                , GQLTypeD(..)+                                                , TypeD(..)+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Resolver+                                                , MapStrategy(..)+                                                , LiftEither+                                                , ResolvingStrategy+                                                )+import           Data.Morpheus.Types.Internal.TH+                                                ( applyT+                                                , destructRecord+                                                , instanceHeadMultiT+                                                , typeT+                                                ) --- @Subscription:------     instance (Monad m, Typeable m) => ObjectResolvers 'True (<Subscription> (SubResolver m e c)) (SubResolveT m e c Value) where---          objectResolvers _ (<Subscription> x y) = [("newAddress", encode x), ("newUser", encode y)]------ @Object:------   instance (Monad m, Typeable m) => ObjectResolvers 'True (<Object> (Resolver m)) (ResolveT m Value) where---          objectResolvers _ (<Object> x y) = [("field1", encode x), ("field2", encode y)]------- +encodeVars :: [String]+encodeVars = ["e", "m"] +encodeVarsT :: [TypeQ]+encodeVarsT = map (varT . mkName) encodeVars+ deriveEncode :: GQLTypeD -> Q [Dec]-deriveEncode GQLTypeD {typeKindD, typeD = TypeD {tName, tCons = [ConsD {cFields}]}} =-  pure <$> instanceD (cxt constrains) appHead methods-  where -    subARgs = conT ''SUBSCRIPTION : map (varT . mkName) ["m","e"]-    instanceArgs-          | isSubscription typeKindD = subARgs-          | otherwise =  map (varT . mkName) ["o","m","e"]-    mainType = applyT (mkName tName) [mainTypeArg]-      where-        mainTypeArg-          | isSubscription typeKindD = applyT ''Resolver subARgs-          | otherwise = typeT ''Resolver ["fieldOKind","m","e"] -    -----------------------------------------------------------------------------------------+deriveEncode GQLTypeD { typeKindD, typeD = TypeD { tName, tCons = [ConsD { cFields }] } }+  = pure <$> instanceD (cxt constrains) appHead methods+ where+  subARgs = conT ''SUBSCRIPTION : encodeVarsT+  instanceArgs | isSubscription typeKindD = subARgs+               | otherwise = map (varT . mkName) ("o" : encodeVars)+  mainType = applyT (mkName tName) [mainTypeArg]+   where+    mainTypeArg | isSubscription typeKindD = applyT ''Resolver subARgs+                | otherwise                = typeT ''Resolver (fo_ : encodeVars)+  -----------------------------------------------------------------------------------------+  fo_ = "fieldOperationKind"+  po_ = "o"+  ---------------------+  typeables+    | isSubscription typeKindD+    = [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]]+    | otherwise+    = [ iLiftEither ''ResolvingStrategy+      , iLiftEither ''Resolver+      , typeT ''MapStrategy [fo_, po_]+      , iTypeable fo_+      , iTypeable po_+      ]+  -------------------------+  iLiftEither name = applyT ''LiftEither [varT $ mkName fo_, conT name]+  -------------------------+  iTypeable name = typeT ''Typeable [name]+  -------------------------------------------+  -- defines Constraint: (Typeable m, Monad m)+  constrains =     typeables-         | isSubscription typeKindD =  [applyT ''MapGraphQLT $ map conT [''QUERY, ''SUBSCRIPTION],applyT ''Resolving [conT ''QUERY, varT $ mkName "m", varT $ mkName "e"]]-         | otherwise = [typeT ''PureOperation ["fieldOKind"],typeT ''MapGraphQLT ["fieldOKind","o"] , typeT ''Resolving ["fieldOKind","m","e"] , typeT ''Typeable ["fieldOKind"] , typeT ''Typeable ["o"]]-    -- defines Constraint: (Typeable m, Monad m)-    constrains = typeables <>[typeT ''Monad ["m"], applyT ''Encode (mainType:instanceArgs) , typeT ''Typeable ["m"],typeT ''Typeable ["e"]]-    --------------------------------------------------------------------    -- defines: instance <constraint> =>  ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value) where-    appHead = instanceHeadMultiT ''ObjectResolvers (conT ''TRUE) (mainType: instanceArgs)-    -------------------------------------------------------------------    -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...]-    methods = [funD 'objectResolvers [clause argsE (normalB body) []]]-      where-        argsE = [varP (mkName "_"), destructRecord tName varNames]-        body = listE $ map decodeVar varNames-        decodeVar name = [|(name, encode $(varName))|]-          where-            varName = varE $ mkName name-        varNames = map (unpack . fieldName) cFields+      <> [ 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 ''ObjectResolvers (conT ''TRUE) (mainType : instanceArgs)+  ------------------------------------------------------------------+  -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...]+  methods = [funD 'objectResolvers [clause argsE (normalB body) []]]+   where+    argsE = [varP (mkName "_"), destructRecord tName varNames]+    body  = listE $ map decodeVar varNames+    decodeVar name = [|(name, encode $(varName))|]+      where varName = varE $ mkName name+    varNames = map (unpack . fieldName) cFields deriveEncode _ = pure []

@@ -6,67 +6,87 @@  module Data.Morpheus.Execution.Document.GQLType   ( deriveGQLType-  ) where+  )+where -import           Data.Text                                (pack)+import           Data.Text                      ( pack+                                                , unpack+                                                ) import           Language.Haskell.TH-+import           Data.Semigroup                 ( (<>) ) -- -- MORPHEUS-import           Data.Morpheus.Execution.Internal.Declare (tyConArgs)-import           Data.Morpheus.Kind                       (ENUM, INPUT_OBJECT, INPUT_UNION, OBJECT, SCALAR, UNION,-                                                           WRAPPER)-import           Data.Morpheus.Types.GQLType              (GQLType (..), TRUE)-import           Data.Morpheus.Types.Internal.Data        (DataTypeKind (..), isObject, isSchemaTypeName)-import           Data.Morpheus.Types.Internal.DataD       (GQLTypeD (..), TypeD (..))-import           Data.Morpheus.Types.Internal.TH          (instanceHeadT, typeT, typeInstanceDec)-import           Data.Typeable                            (Typeable)+import           Data.Morpheus.Execution.Internal.Declare+                                                ( tyConArgs )+import           Data.Morpheus.Kind             ( ENUM+                                                , INPUT_OBJECT+                                                , INPUT_UNION+                                                , OBJECT+                                                , SCALAR+                                                , UNION+                                                , WRAPPER+                                                )+import           Data.Morpheus.Types.GQLType    ( GQLType(..)+                                                , TRUE+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( DataTypeKind(..)+                                                , Meta(..)+                                                , isObject+                                                , isSchemaTypeName+                                                , GQLTypeD(..)+                                                , TypeD(..)+                                                )+import           Data.Morpheus.Types.Internal.TH+                                                ( instanceHeadT+                                                , typeT+                                                , typeInstanceDec+                                                , instanceProxyFunD+                                                )+import           Data.Typeable                  ( Typeable )  genTypeName :: String -> String-genTypeName ('S':name)-  | isSchemaTypeName (pack name) = name+genTypeName ('S' : name) | isSchemaTypeName (pack name) = name genTypeName name = name -- deriveGQLType :: GQLTypeD -> Q [Dec]-deriveGQLType GQLTypeD {typeD = TypeD {tName}, typeKindD} =-  pure <$> instanceD (cxt constrains) iHead (def__typeName : typeFamilies)-  where-    def__typeName = funD '__typeName [clause argsE (normalB body) []]-      where-        body = [|pack name|]-          where-            name = genTypeName tName-    -- defines method: __typeName _ = tName-    argsE = map (varP . mkName) ["_"]-    typeArgs = tyConArgs typeKindD-    -----------------------------------------------    iHead = instanceHeadT ''GQLType tName typeArgs-    headSig = typeT (mkName tName) typeArgs-    ------------------------------------------------    constrains = map conTypeable typeArgs-      where-        conTypeable name = typeT ''Typeable [name]-    ------------------------------------------------    typeFamilies-      | isObject typeKindD = [deriveCUSTOM, deriveKind]-      | otherwise = [deriveKind]-    ----------------------------------------------      where-        deriveCUSTOM = do-          typeN <- headSig-          pure $ typeInstanceDec ''CUSTOM typeN (ConT ''TRUE)-        ----------------------------------------------------------------        deriveKind = do-          typeN <- headSig-          pure $ typeInstanceDec ''KIND typeN (ConT $ toKIND typeKindD)-        ----------------------------------        toKIND KindScalar      = ''SCALAR-        toKIND KindEnum        = ''ENUM-        toKIND (KindObject _)  = ''OBJECT-        toKIND KindUnion       = ''UNION-        toKIND KindInputObject = ''INPUT_OBJECT-        toKIND KindList        = ''WRAPPER-        toKIND KindNonNull     = ''WRAPPER-        toKIND KindInputUnion  = ''INPUT_UNION+deriveGQLType GQLTypeD { typeD = TypeD { tName, tMeta }, typeKindD } =+  pure <$> instanceD (cxt constrains) iHead (functions <> typeFamilies)+ where+  functions = map+    instanceProxyFunD+    [ ('__typeName , [|pack (genTypeName tName)|])+    , ('description, descriptionValue)+    ]+   where+    descriptionValue = case tMeta >>= metaDescription of+      Nothing -> [| Nothing  |]+      Just x  -> [| Just (pack desc)|] where desc = unpack x+  -------------------------------------------------+  typeArgs   = tyConArgs typeKindD+  ----------------------------------------------+  iHead      = instanceHeadT ''GQLType tName typeArgs+  headSig    = typeT (mkName tName) typeArgs+  -----------------------------------------------+  constrains = map conTypeable typeArgs+    where conTypeable name = typeT ''Typeable [name]+  -----------------------------------------------+  typeFamilies | isObject typeKindD = [deriveCUSTOM, deriveKind]+               | otherwise          = [deriveKind]+   where+    deriveCUSTOM = do+      typeN <- headSig+      pure $ typeInstanceDec ''CUSTOM typeN (ConT ''TRUE)+    ---------------------------------------------------------------+    deriveKind = do+      typeN <- headSig+      pure $ typeInstanceDec ''KIND typeN (ConT $ toKIND typeKindD)+    ---------------------------------+    toKIND KindScalar      = ''SCALAR+    toKIND KindEnum        = ''ENUM+    toKIND (KindObject _)  = ''OBJECT+    toKIND KindUnion       = ''UNION+    toKIND KindInputObject = ''INPUT_OBJECT+    toKIND KindList        = ''WRAPPER+    toKIND KindNonNull     = ''WRAPPER+    toKIND KindInputUnion  = ''INPUT_UNION

@@ -4,32 +4,43 @@ {-# LANGUAGE TemplateHaskell   #-}  module Data.Morpheus.Execution.Document.Introspect-  ( deriveObjectRep+  ( deriveObjectRep , instanceIntrospect   ) where +import Data.Maybe(maybeToList) import           Data.Proxy                                (Proxy (..)) import           Data.Text                                 (unpack) import           Data.Typeable                             (Typeable)-import           Language.Haskell.TH+import           Language.Haskell.TH    -- MORPHEUS import           Data.Morpheus.Execution.Internal.Declare  (tyConArgs) import           Data.Morpheus.Execution.Server.Introspect (Introspect (..), ObjectFields (..)) import           Data.Morpheus.Types.GQLType               (GQLType (__typeName), TRUE)-import           Data.Morpheus.Types.Internal.Data         (ArgsType (..), DataField (..), DataTypeKind, TypeAlias (..))-import           Data.Morpheus.Types.Internal.DataD        (ConsD (..), TypeD (..))-import           Data.Morpheus.Types.Internal.TH           (instanceFunD, instanceHeadMultiT, typeT)+import           Data.Morpheus.Types.Internal.AST          (ConsD (..), TypeD (..), ArgsType (..),Key, DataType(..), DataField (..),insertType,DataTypeKind(..), TypeAlias (..))+import           Data.Morpheus.Types.Internal.TH           (instanceFunD, instanceProxyFunD,instanceHeadT, instanceHeadMultiT, typeT) ++instanceIntrospect :: (Key,DataType) -> Q [Dec]+-- FIXME: dirty fix for introspection+instanceIntrospect ("__DirectiveLocation",_) = pure []+instanceIntrospect ("__TypeKind",_) = pure []+instanceIntrospect (name, DataEnum enumType) =+  pure <$> instanceD (cxt []) iHead [defineIntrospect]+  where+    -----------------------------------------------+    iHead = instanceHeadT ''Introspect  (unpack name) []+    defineIntrospect = instanceProxyFunD ('introspect,body)+      where+        body =[| insertType (name, DataEnum enumType) |]+instanceIntrospect _ = pure []+ -- [((Text, DataField), TypeUpdater)] deriveObjectRep :: (TypeD, Maybe DataTypeKind) -> Q [Dec] deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, tKind) =-  pure <$> instanceWithOverlapD overlapping (cxt constrains) iHead methods+  pure <$> instanceD (cxt constrains) iHead methods   where-    overlapping = Just Overlapping-    typeArgs =-      case tKind of-        Just typeKind -> tyConArgs typeKind-        Nothing       -> []+    typeArgs = concatMap tyConArgs (maybeToList tKind)     constrains = map conTypeable typeArgs       where         conTypeable name = typeT ''Typeable [name]@@ -61,14 +72,14 @@ buildFields :: [DataField] -> ExpQ buildFields = listE . map buildField   where-    buildField DataField {fieldName, fieldArgs, fieldType = alias@TypeAlias {aliasArgs, aliasWrappers}} =+    buildField DataField {fieldName, fieldArgs, fieldType = alias@TypeAlias {aliasArgs, aliasWrappers}, fieldMeta} =       [|( fName         , DataField             { fieldName = fName             , fieldArgs = fArgs             , fieldArgsType = Nothing             , fieldType = TypeAlias {aliasTyCon = __typeName $(proxyT alias), aliasArgs = aArgs, aliasWrappers}-            , fieldHidden = False+            , fieldMeta             })|]       where         fName = unpack fieldName

@@ -10,74 +10,92 @@ module Data.Morpheus.Execution.Internal.Declare   ( declareType   , tyConArgs-  ) where+  )+where -import           Data.Maybe                             (maybe)-import           Data.Text                              (pack, unpack)-import           GHC.Generics                           (Generic)+import           Data.Maybe                     ( maybe )+import           Data.Text                      ( pack+                                                , unpack+                                                )+import           GHC.Generics                   ( Generic ) import           Language.Haskell.TH  -- MORPHEUS-import           Data.Morpheus.Execution.Internal.Utils (nameSpaceType, nameSpaceWith)-import           Data.Morpheus.Types.Internal.Data      (ArgsType (..), DataField (..), DataTypeKind (..),-                                                         DataTypeKind (..), TypeAlias (..), WrapperD (..),-                                                         isOutputObject, isSubscription)-import           Data.Morpheus.Types.Internal.DataD     (ConsD (..), TypeD (..))-import           Data.Morpheus.Types.Internal.Resolver  (UnSubResolver)+import           Data.Morpheus.Execution.Internal.Utils+                                                ( nameSpaceType+                                                , nameSpaceWith+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( ArgsType(..)+                                                , DataField(..)+                                                , DataTypeKind(..)+                                                , DataTypeKind(..)+                                                , TypeAlias(..)+                                                , TypeWrapper(..)+                                                , isOutputObject+                                                , isSubscription+                                                , ConsD(..)+                                                , TypeD(..)+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( UnSubResolver )  type Arrow = (->)  declareTypeAlias :: Bool -> TypeAlias -> Type-declareTypeAlias isSub TypeAlias {aliasTyCon, aliasWrappers, aliasArgs} = wrappedT aliasWrappers-  where-    wrappedT :: [WrapperD] -> Type-    wrappedT (ListD:xs)  = AppT (ConT ''[]) $ wrappedT xs-    wrappedT (MaybeD:xs) = AppT (ConT ''Maybe) $ wrappedT xs-    wrappedT []          = decType aliasArgs-    -------------------------------------------------------    typeName = ConT (mkName $ unpack aliasTyCon)-    ---------------------------------------------    decType _-      | isSub = AppT typeName (AppT (ConT ''UnSubResolver) (VarT $ mkName "m"))-    decType (Just par) = AppT typeName (VarT $ mkName $ unpack par)-    decType _ = typeName+declareTypeAlias isSub TypeAlias { aliasTyCon, aliasWrappers, aliasArgs } =+  wrappedT aliasWrappers+ where+  wrappedT :: [TypeWrapper] -> Type+  wrappedT (TypeList  : xs) = AppT (ConT ''[]) $ wrappedT xs+  wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs+  wrappedT []               = decType aliasArgs+  ------------------------------------------------------+  typeName = ConT (mkName $ unpack aliasTyCon)+  --------------------------------------------+  decType _ | isSub =+    AppT typeName (AppT (ConT ''UnSubResolver) (VarT $ mkName "m"))+  decType (Just par) = AppT typeName (VarT $ mkName $ unpack par)+  decType _          = typeName  tyConArgs :: DataTypeKind -> [String]-tyConArgs kindD-  | isOutputObject kindD || kindD == KindUnion = ["m"]-  | otherwise = []+tyConArgs kindD | isOutputObject kindD || kindD == KindUnion = ["m"]+                | otherwise = []  -- declareType declareType :: Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec-declareType namespace kindD derivingList TypeD {tName, tCons, tNamespace} =-  DataD [] (genName tName) tVars Nothing (map cons tCons) $ map derive (''Generic : derivingList)-  where-    genName = mkName . nameSpaceType (map pack tNamespace) . pack-    tVars = maybe [] (declareTyVar . tyConArgs) kindD-      where-        declareTyVar = map (PlainTV . mkName)-    defBang = Bang NoSourceUnpackedness NoSourceStrictness-    derive className = DerivClause Nothing [ConT className]-    cons ConsD {cName, cFields} = RecC (genName cName) (map declareField cFields)-      where-        declareField DataField {fieldName, fieldArgsType, fieldType} = (fName, defBang, fiType)-          where-            fName-              | namespace = mkName (nameSpaceWith tName (unpack fieldName))-              | otherwise = mkName (unpack fieldName)-            fiType = genFieldT fieldArgsType-              where-                monadVar = VarT $ mkName "m"-                ----------------------------                genFieldT Nothing = fType False-                genFieldT (Just ArgsType {argsTypeName}) = AppT (AppT arrowType argType) (fType True)-                  where-                    argType = ConT $ mkName (unpack argsTypeName)-                    arrowType = ConT ''Arrow-                -------------------------------------------------                fType isResolver-                  | maybe False isSubscription kindD = AppT monadVar result-                  | isResolver = AppT monadVar result-                  | otherwise = result-                -------------------------------------------------                result = declareTypeAlias (maybe False isSubscription kindD) fieldType+declareType namespace kindD derivingList TypeD { tName, tCons, tNamespace } =+  DataD [] (genName tName) tVars Nothing (map cons tCons)+    $ map derive (''Generic : derivingList)+ where+  genName = mkName . nameSpaceType (map pack tNamespace) . pack+  tVars   = maybe [] (declareTyVar . tyConArgs) kindD+    where declareTyVar = map (PlainTV . mkName)+  defBang = Bang NoSourceUnpackedness NoSourceStrictness+  derive className = DerivClause Nothing [ConT className]+  cons ConsD { cName, cFields } = RecC (genName cName)+                                       (map declareField cFields)+   where+    declareField DataField { fieldName, fieldArgsType, fieldType } =+      (fName, defBang, fiType)+     where+      fName | namespace = mkName (nameSpaceWith tName (unpack fieldName))+            | otherwise = mkName (unpack fieldName)+      fiType = genFieldT fieldArgsType+       where+        monadVar = VarT $ mkName "m"+        ---------------------------+        genFieldT Nothing                          = fType False+        genFieldT (Just ArgsType { argsTypeName }) = AppT+          (AppT arrowType argType)+          (fType True)+         where+          argType   = ConT $ mkName (unpack argsTypeName)+          arrowType = ConT ''Arrow+        ------------------------------------------------+        fType isResolver+          | maybe False isSubscription kindD = AppT monadVar result+          | isResolver                       = AppT monadVar result+          | otherwise                        = result+        ------------------------------------------------+        result = declareTypeAlias (maybe False isSubscription kindD) fieldType

@@ -10,62 +10,74 @@   , withUnion   , decodeFieldWith   , decodeObjectExpQ-  ) where+  )+where -import           Data.Semigroup                          ((<>))-import           Data.Text                               (unpack)-import           Language.Haskell.TH                     (ExpQ, conE, mkName, uInfixE, varE)+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( unpack )+import           Language.Haskell.TH            ( ExpQ+                                                , conE+                                                , mkName+                                                , uInfixE+                                                , varE+                                                )  -- MORPHEUS-import           Data.Morpheus.Error.Internal            (internalArgumentError, internalTypeMismatch)-import           Data.Morpheus.Types.Internal.Data       (DataField (..), Key)-import           Data.Morpheus.Types.Internal.DataD      (ConsD (..))-import           Data.Morpheus.Types.Internal.Validation (Validation)-import           Data.Morpheus.Types.Internal.Value      (Object, Value (..))+import           Data.Morpheus.Error.Internal   ( internalArgumentError+                                                , internalTypeMismatch+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( DataField(..)+                                                , Key+                                                , ConsD(..) +                                                , Object+                                                , Value(..))+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation ) + decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ-decodeObjectExpQ fieldDecoder ConsD {cName, cFields} = handleFields cFields-  where-    consName = conE (mkName cName)-    -----------------------------------------------------------------------------------    handleFields fNames = uInfixE consName (varE '(<$>)) (applyFields fNames)-      where-        applyFields []     = fail "No Empty fields"-        applyFields [x]    = defField x-        applyFields (x:xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs)-        -------------------------------------------------------------------------        defField DataField {fieldName} = uInfixE (varE (mkName "o")) fieldDecoder [|fName|]-          where-            fName = unpack fieldName+decodeObjectExpQ fieldDecoder ConsD { cName, cFields } = handleFields cFields+ where+  consName = conE (mkName cName)+  ----------------------------------------------------------------------------------+  handleFields fNames = uInfixE consName (varE '(<$>)) (applyFields fNames)+   where+    applyFields []       = fail "No Empty fields"+    applyFields [x     ] = defField x+    applyFields (x : xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs)+    ------------------------------------------------------------------------+    defField DataField { fieldName } = uInfixE (varE (mkName "o"))+                                               fieldDecoder+                                               [|fName|]+      where fName = unpack fieldName  withObject :: (Object -> Validation a) -> Value -> Validation a withObject f (Object object) = f object withObject _ isType          = internalTypeMismatch "Object" isType  withMaybe :: Monad m => (Value -> m a) -> Value -> m (Maybe a)-withMaybe _ Null   = pure Nothing-withMaybe decode x = Just <$> decode x+withMaybe _      Null = pure Nothing+withMaybe decode x    = Just <$> decode x  withList :: (Value -> Validation a) -> Value -> Validation [a] withList decode (List li) = mapM decode li-withList _ isType         = internalTypeMismatch "List" isType+withList _      isType    = internalTypeMismatch "List" isType  withEnum :: (Key -> Validation a) -> Value -> Validation a withEnum decode (Enum value) = decode value-withEnum _ isType            = internalTypeMismatch "Enum" isType+withEnum _      isType       = internalTypeMismatch "Enum" isType  withUnion :: (Key -> Object -> Object -> Validation a) -> Object -> Validation a-withUnion decoder unions =-  case lookup "tag" unions of-    Just (Enum key) ->-      case lookup key unions of-        Nothing    -> internalArgumentError ("type \"" <> key <> "\" was not provided on object")-        Just value -> withObject (decoder key unions) value-    Just _ -> internalArgumentError "tag must be Enum"-    Nothing -> internalArgumentError "tag not found on Input Union"+withUnion decoder unions = case lookup "tag" unions of+  Just (Enum key) -> case lookup key unions of+    Nothing -> internalArgumentError+      ("type \"" <> key <> "\" was not provided on object")+    Just value -> withObject (decoder key unions) value+  Just _  -> internalArgumentError "tag must be Enum"+  Nothing -> internalArgumentError "tag not found on Input Union"  decodeFieldWith :: (Value -> Validation a) -> Key -> Object -> Validation a-decodeFieldWith decoder name object =-  case lookup name object of-    Nothing    -> internalArgumentError ("Missing Field: \"" <> name <> "\"")-    Just value -> decoder value+decodeFieldWith decoder name object = case lookup name object of+  Nothing    -> internalArgumentError ("Missing Field: \"" <> name <> "\"")+  Just value -> decoder value

@@ -1,14 +0,0 @@-module Data.Morpheus.Execution.Internal.GraphScanner-  ( LibUpdater-  , resolveUpdates-  ) where--import           Control.Monad                           (foldM)-import           Data.Function                           ((&))-import           Data.Morpheus.Types.Internal.Validation (Validation)--type LibUpdater lib = lib -> Validation lib---- Helper Functions-resolveUpdates :: lib -> [LibUpdater lib] -> Validation lib-resolveUpdates = foldM (&)

@@ -4,11 +4,16 @@   , nameSpaceWith   , nameSpaceType   , nameSpaceTypeString-  ) where+  )+where -import           Data.Char      (toLower, toUpper)-import           Data.Semigroup ((<>))-import           Data.Text      (Text, unpack)+import           Data.Char                      ( toLower+                                                , toUpper+                                                )+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( Text+                                                , unpack+                                                )   nameSpaceTypeString :: [String] -> String -> String@@ -21,9 +26,9 @@ nameSpaceWith nSpace name = nonCapital nSpace <> capital name  nonCapital :: String -> String-nonCapital []     = []-nonCapital (x:xs) = toLower x : xs+nonCapital []       = []+nonCapital (x : xs) = toLower x : xs  capital :: String -> String-capital []     = []-capital (x:xs) = toUpper x : xs+capital []       = []+capital (x : xs) = toUpper x : xs

@@ -14,26 +14,49 @@   ( decodeArguments   , Decode(..)   , DecodeObject(..)-  ) where+  )+where -import           Data.Proxy                                      (Proxy (..))-import           Data.Semigroup                                  ((<>))-import           Data.Text                                       (pack)+import           Data.Proxy                     ( Proxy(..) )+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( pack ) import           GHC.Generics  -- MORPHEUS-import           Data.Morpheus.Error.Internal                    (internalArgumentError, internalTypeMismatch)-import           Data.Morpheus.Execution.Internal.Decode         (decodeFieldWith, withEnum, withList, withMaybe,-                                                                  withObject, withUnion)-import           Data.Morpheus.Execution.Server.Generics.EnumRep (EnumRep (..))-import           Data.Morpheus.Kind                              (ENUM, GQL_KIND, INPUT_OBJECT, INPUT_UNION, SCALAR)-import           Data.Morpheus.Types.GQLScalar                   (GQLScalar (..), toScalar)-import           Data.Morpheus.Types.GQLType                     (GQLType (KIND, __typeName))-import           Data.Morpheus.Types.Internal.AST.Selection      (Argument (..), Arguments)-import           Data.Morpheus.Types.Internal.Base               (Key)-import           Data.Morpheus.Types.Internal.Validation         (Validation)-import           Data.Morpheus.Types.Internal.Value              (Object, Value (..))+import           Data.Morpheus.Error.Internal   ( internalArgumentError+                                                , internalTypeMismatch+                                                )+import           Data.Morpheus.Execution.Internal.Decode+                                                ( decodeFieldWith+                                                , withEnum+                                                , withList+                                                , withMaybe+                                                , withObject+                                                , withUnion+                                                )+import           Data.Morpheus.Execution.Server.Generics.EnumRep+                                                ( EnumRep(..) )+import           Data.Morpheus.Kind             ( ENUM+                                                , GQL_KIND+                                                , INPUT_OBJECT+                                                , INPUT_UNION+                                                , SCALAR+                                                )+import           Data.Morpheus.Types.GQLScalar  ( GQLScalar(..)+                                                , toScalar+                                                )+import           Data.Morpheus.Types.GQLType    ( GQLType(KIND, __typeName) )+import           Data.Morpheus.Types.Internal.AST+                                                ( Key+                                                , Argument(..)+                                                , Arguments+                                                , Object+                                                , Value(..)+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation ) + -- | Decode GraphQL query arguments and input values class Decode a where   decode :: Value -> Validation a@@ -53,10 +76,9 @@  -- SCALAR instance (GQLScalar a) => DecodeKind SCALAR a where-  decodeKind _ value =-    case toScalar value >>= parseValue of-      Right scalar      -> return scalar-      Left errorMessage -> internalTypeMismatch errorMessage value+  decodeKind _ value = case toScalar value >>= parseValue of+    Right scalar       -> return scalar+    Left  errorMessage -> internalTypeMismatch errorMessage value  -- ENUM instance (Generic a, EnumRep (Rep a)) => DecodeKind ENUM a where@@ -73,8 +95,7 @@ -- GENERIC decodeArguments :: DecodeObject p => Arguments -> Validation p decodeArguments = decodeObject . fmap toObject-  where-    toObject (x, y) = (x, argumentValue y)+  where toObject (x, y) = (x, argumentValue y)  class DecodeObject a where   decodeObject :: Object -> Validation a@@ -98,11 +119,11 @@ -- Recursive Decoding: (Selector (Rec1 )) instance (Selector s, GQLType a, Decode a) => GDecode (M1 S s (K1 i a)) where   unionTags _ = [__typeName (Proxy @a)]-  decodeUnion = fmap (M1 . K1) . decode . Object+  decodeUnion    = fmap (M1 . K1) . decode . Object   __decodeObject = fmap (M1 . K1) . decodeRec-    where-      fieldName = pack $ selName (undefined :: M1 S s f a)-      decodeRec = withObject (decodeFieldWith decode fieldName)+   where+    fieldName = pack $ selName (undefined :: M1 S s f a)+    decodeRec = withObject (decodeFieldWith decode fieldName)  instance (Datatype c, GDecode f) => GDecode (M1 D c f) where   decodeUnion = fmap M1 . decodeUnion@@ -119,14 +140,15 @@  instance (GDecode a, GDecode b) => GDecode (a :+: b) where   decodeUnion = withUnion handleUnion-    where-      handleUnion name unions object-        | [name] == l1Tags = L1 <$> decodeUnion object-        | [name] == r1Tags = R1 <$> decodeUnion object-        | name `elem` l1Tags = L1 <$> decodeUnion unions-        | name `elem` r1Tags = R1 <$> decodeUnion unions-        | otherwise = internalArgumentError ("type \"" <> name <> "\" could not find in union")-        where-          l1Tags = unionTags $ Proxy @a-          r1Tags = unionTags $ Proxy @b+   where+    handleUnion name unions object+      | [name] == l1Tags = L1 <$> decodeUnion object+      | [name] == r1Tags = R1 <$> decodeUnion object+      | name `elem` l1Tags = L1 <$> decodeUnion unions+      | name `elem` r1Tags = R1 <$> decodeUnion unions+      | otherwise = internalArgumentError+        ("type \"" <> name <> "\" could not find in union")+     where+      l1Tags = unionTags $ Proxy @a+      r1Tags = unionTags $ Proxy @b   unionTags _ = unionTags (Proxy @a) ++ unionTags (Proxy @b)

@@ -19,109 +19,153 @@   , encodeSubscription   , encodeMutation   , ObjectResolvers(..)-  ) where+  )+where -import           Data.Map                                        (Map)-import qualified Data.Map                                        as M (toList)-import           Data.Maybe                                      (fromMaybe)-import           Data.Proxy                                      (Proxy (..))-import           Data.Semigroup                                  ((<>))-import           Data.Set                                        (Set)-import qualified Data.Set                                        as S (toList)-import           Data.Text                                       (pack)+import           Data.Map                       ( Map )+import qualified Data.Map                      as M+                                                ( toList )+import           Data.Maybe                     ( fromMaybe )+import           Data.Proxy                     ( Proxy(..) )+import           Data.Semigroup                 ( (<>) )+import           Data.Set                       ( Set )+import qualified Data.Set                      as S+                                                ( toList )+import           Data.Text                      ( pack ) import           GHC.Generics  -- MORPHEUS-import           Data.Morpheus.Error.Internal                    (internalUnknownTypeMessage)-import           Data.Morpheus.Execution.Server.Decode           (DecodeObject, decodeArguments)-import           Data.Morpheus.Execution.Server.Generics.EnumRep (EnumRep (..))-import           Data.Morpheus.Kind                              (ENUM, GQL_KIND, OBJECT, ResContext (..), SCALAR,-                                                                  UNION, VContext (..))-import           Data.Morpheus.Types.Custom                      (MapKind, Pair (..), mapKindFromList)-import           Data.Morpheus.Types.GQLScalar                   (GQLScalar (..))-import           Data.Morpheus.Types.GQLType                     (GQLType (CUSTOM, KIND, __typeName))-import           Data.Morpheus.Types.Internal.AST.Operation      (Operation (..), ValidOperation)-import           Data.Morpheus.Types.Internal.AST.Selection      (Selection (..), SelectionRec (..), ValidSelection)-import           Data.Morpheus.Types.Internal.Base               (Key)-import           Data.Morpheus.Types.Internal.Data               (MUTATION, OperationType, QUERY, SUBSCRIPTION)-import           Data.Morpheus.Types.Internal.Resolver           (MapGraphQLT (..), PureOperation (..), Resolver (..),-                                                                  Resolving (..), ResolvingStrategy (..), resolveObject,-                                                                  withObject)-import           Data.Morpheus.Types.Internal.Validation         (Validation)-import           Data.Morpheus.Types.Internal.Value              (GQLValue (..), Value (..))+import           Data.Morpheus.Error.Internal   ( internalUnknownTypeMessage )+import           Data.Morpheus.Execution.Server.Decode+                                                ( DecodeObject+                                                , decodeArguments+                                                )+import           Data.Morpheus.Execution.Server.Generics.EnumRep+                                                ( EnumRep(..) )+import           Data.Morpheus.Kind             ( ENUM+                                                , GQL_KIND+                                                , OBJECT+                                                , ResContext(..)+                                                , SCALAR+                                                , UNION+                                                , VContext(..)+                                                )+import           Data.Morpheus.Types.Types     ( MapKind+                                                , Pair(..)+                                                , mapKindFromList+                                                )+import           Data.Morpheus.Types.GQLScalar  ( GQLScalar(..) )+import           Data.Morpheus.Types.GQLType    ( GQLType+                                                  ( CUSTOM+                                                  , KIND+                                                  , __typeName+                                                  )+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( Operation(..)+                                                , ValidOperation+                                                , Key,+                                                  MUTATION+                                                , OperationType+                                                , QUERY+                                                , SUBSCRIPTION+                                                , Selection(..)+                                                , SelectionRec(..)+                                                , ValidSelection+                                                , GQLValue(..)+                                                , Value(..)+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( MapStrategy(..)+                                                , LiftEither(..)+                                                , Resolver(..)+                                                , resolving+                                                , toResolver+                                                , ResolvingStrategy(..)+                                                , resolveObject+                                                , withObject+                                                , Validation+                                                , failure+                                                ) -class Encode resolver o m e where-  encode :: PureOperation o => resolver -> (Key, ValidSelection) -> ResolvingStrategy o m e Value+class Encode resolver o e (m :: * -> *) where+  encode :: resolver -> (Key, ValidSelection) -> ResolvingStrategy o e m Value -instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o m e , PureOperation o) => Encode a o m e where+instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m , LiftEither o ResolvingStrategy) => Encode a o e m where   encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a)  -- MAYBE-instance (Monad m , Encode a o m e) => Encode (Maybe a) o m e where+instance (Monad m , LiftEither o ResolvingStrategy,Encode a o e m) => Encode (Maybe a) o e m where   encode = maybe (const $ pure gqlNull) encode  --  Tuple  (a,b)-instance Encode (Pair k v) o m e => Encode (k, v) o m e where+instance Encode (Pair k v) o e m => Encode (k, v) o e m where   encode (key, value) = encode (Pair key value)  --  Set-instance Encode [a] o m e => Encode (Set a) o m e where+instance Encode [a] o e m => Encode (Set a) o e m where   encode = encode . S.toList  --  Map-instance (Eq k, Monad m, Encode (MapKind k v (Resolver o m e)) o m e) => Encode (Map k v)  o m e  where-  encode value = encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver o m e))+instance (Eq k, Monad m,LiftEither o Resolver, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v)  o e m where+  encode value =+    encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver o e m))  -- LIST []-instance (Monad m, Encode a o m e) => Encode [a] o m e where+instance (Monad m, Encode a o e m, LiftEither o ResolvingStrategy) => Encode [a] o e m where   encode list query = gqlList <$> traverse (`encode` query) list - --  GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance (DecodeObject a, Resolving fO m e ,Monad m,PureOperation fO, MapGraphQLT fO o, Encode b fO m e ) => Encode (a -> Resolver fO m e b) o m e where-  encode resolver selection@(_, Selection { selectionArguments }) = mapGraphQLT $ resolving encode (getArgs args resolver)  selection-     where-      args :: Validation a-      args =  decodeArguments selectionArguments+instance (DecodeObject a, Monad m,LiftEither fo Resolver, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where+  encode resolver selection@(_, Selection { selectionArguments }) =+    mapStrategy $ resolving encode (toResolver args resolver) selection+   where+    args :: Validation a+    args = decodeArguments selectionArguments  -- ENCODE GQL KIND-class EncodeKind (kind :: GQL_KIND) a o m e  where-  encodeKind :: PureOperation o =>  VContext kind a -> (Key, ValidSelection) -> ResolvingStrategy o m e Value+class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where+  encodeKind :: LiftEither o ResolvingStrategy =>  VContext kind a -> (Key, ValidSelection) -> ResolvingStrategy o e m Value  -- SCALAR-instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o m e where+instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where   encodeKind = pure . pure . gqlScalar . serialize . unVContext  -- ENUM-instance (Generic a, EnumRep (Rep a), Monad m) => EncodeKind ENUM a o m e where+instance (Generic a, EnumRep (Rep a), Monad m) => EncodeKind ENUM a o e m where   encodeKind = pure . pure . gqlString . encodeRep . from . unVContext  --  OBJECT-instance (Monad m, EncodeCon o m e a, Monad m, GResolver OBJECT (Rep a) o m e) => EncodeKind OBJECT a o m e where-  encodeKind (VContext value)  = withObject encodeK-    where-      encodeK selection = resolveObject selection (__typenameResolver : objectResolvers (Proxy :: Proxy (CUSTOM a)) value)-      __typenameResolver = ("__typename", const $ pure $ gqlString $ __typeName (Proxy @a))+instance (Monad m, EncodeCon o e m a, Monad m, GResolver OBJECT (Rep a) o e m) => EncodeKind OBJECT a o e m where+  encodeKind (VContext value) = withObject encodeK+   where+    encodeK selection = resolveObject+      selection+      (__typenameResolver : objectResolvers (Proxy :: Proxy (CUSTOM a)) value)+    __typenameResolver =+      ("__typename", const $ pure $ gqlString $ __typeName (Proxy @a))  -- exploreKindChannels -- UNION-instance (Monad m, GQL_RES a, GResolver UNION (Rep a) o m e) => EncodeKind UNION a o m e where-  encodeKind (VContext value) (key, sel@Selection {selectionRec = UnionSelection selections}) =-    resolver (key, sel {selectionRec = SelectionSet lookupSelection})-      -- SPEC: if there is no any fragment that supports current object Type GQL returns {}-    where-      lookupSelection = fromMaybe [] $ lookup typeName selections-      (typeName, resolver) = unionResolver value-  encodeKind _ _ = Fail $ internalUnknownTypeMessage "union Resolver only should recieve UnionSelection"+instance (Monad m, GQL_RES a, GResolver UNION (Rep a) o e m) => EncodeKind UNION a o e m where+  encodeKind (VContext value) (key, sel@Selection { selectionRec = UnionSelection selections })+    = resolver (key, sel { selectionRec = SelectionSet lookupSelection })+   where+    lookupSelection      = fromMaybe [] $ lookup typeName selections+    (typeName, resolver) = unionResolver value+  encodeKind _ _ = failure $ internalUnknownTypeMessage+    "union Resolver only should recieve UnionSelection"  -- Types & Constrains ------------------------------------------------------- type GQL_RES a = (Generic a, GQLType a) -type EncodeOperator o m e a  = a -> ValidOperation -> ResolvingStrategy o m e Value+type EncodeOperator o e m a+  = a -> ValidOperation -> ResolvingStrategy o e m Value -type EncodeCon o m e a = (GQL_RES a,  ObjectResolvers (CUSTOM a) a o m e)+type EncodeCon o e m a = (GQL_RES a, ObjectResolvers (CUSTOM a) a o e m) -type FieldRes  o m e   = (Key, (Key, ValidSelection) -> ResolvingStrategy o m e Value)+type FieldRes o e m+  = (Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value)  type family GRes (kind :: GQL_KIND) value :: * @@ -130,64 +174,82 @@ type instance GRes UNION v = (Key, (Key, ValidSelection) -> v)  --- GENERICS -------------------------------------------------class ObjectResolvers (custom :: Bool) a (o :: OperationType) (m :: * -> *) e where-  objectResolvers :: PureOperation o =>  Proxy custom -> a -> [(Key, (Key, ValidSelection) -> ResolvingStrategy o m e Value)]+class ObjectResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where+  objectResolvers :: Proxy custom -> a -> [(Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value)] -instance (Generic a, GResolver OBJECT (Rep a) o m e ) => ObjectResolvers 'False a o m e where-  objectResolvers _ = getResolvers (ResContext :: ResContext OBJECT o m e value) . from+instance (Generic a, GResolver OBJECT (Rep a) o e m ) => ObjectResolvers 'False a o e m where+  objectResolvers _ =+    getResolvers (ResContext :: ResContext OBJECT o e m value) . from -unionResolver :: (Generic a, PureOperation o, GResolver UNION (Rep a) o m e) => a -> (Key, (Key, ValidSelection) -> ResolvingStrategy o m e Value)-unionResolver = getResolvers (ResContext :: ResContext UNION o m e value) . from+unionResolver+  :: (Generic a, GResolver UNION (Rep a) o e m)+  => a+  -> (Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value)+unionResolver =+  getResolvers (ResContext :: ResContext UNION o e m value) . from  -- | Derives resolvers for OBJECT and UNION-class GResolver (kind :: GQL_KIND) f o m e where-  getResolvers :: PureOperation o => ResContext kind o m e value -> f a -> GRes kind (ResolvingStrategy o m e Value)+class GResolver (kind :: GQL_KIND) f o e (m :: * -> *) where+  getResolvers :: ResContext kind o e m value -> f a -> GRes kind (ResolvingStrategy o e m Value) -instance GResolver kind f o m e => GResolver kind (M1 D c f) o m e where+instance GResolver kind f o e m => GResolver kind (M1 D c f) o e m where   getResolvers context (M1 src) = getResolvers context src -instance GResolver kind f o m e => GResolver kind (M1 C c f) o m e where+instance GResolver kind f o e m => GResolver kind (M1 C c f) o e m where   getResolvers context (M1 src) = getResolvers context src  -- OBJECT-instance GResolver OBJECT U1 o m e where+instance GResolver OBJECT U1 o e m where   getResolvers _ _ = [] -instance (Selector s, GQLType a, Encode a o m e) => GResolver OBJECT (M1 S s (K1 s2 a)) o m e where+instance (Selector s, GQLType a, Encode a o e m) => GResolver OBJECT (M1 S s (K1 s2 a)) o e m where   getResolvers _ m@(M1 (K1 src)) = [(pack (selName m), encode src)] -instance (GResolver OBJECT f o m e, GResolver OBJECT g o m e) => GResolver OBJECT (f :*: g) o m e where-  getResolvers context (a :*: b)  = getResolvers context a  ++ getResolvers context b+instance (GResolver OBJECT f o e m, GResolver OBJECT g o e m) => GResolver OBJECT (f :*: g) o e m where+  getResolvers context (a :*: b) =+    getResolvers context a ++ getResolvers context b  -- UNION-instance (Selector s, GQLType a, Encode a o m e ) => GResolver UNION (M1 S s (K1 s2 a)) o m e where+instance (Selector s, GQLType a, Encode a o e m ) => GResolver UNION (M1 S s (K1 s2 a)) o e m where   getResolvers _ (M1 (K1 src)) = (__typeName (Proxy @a), encode src) -instance (GResolver UNION a o m e, GResolver UNION b o m e) => GResolver UNION (a :+: b) o m e where+instance (GResolver UNION a o e m, GResolver UNION b o e m) => GResolver UNION (a :+: b) o e m where   getResolvers context (L1 x) = getResolvers context x   getResolvers context (R1 x) = getResolvers context x  ----- HELPERS -----------------------------encodeQuery ::-     forall m event query (schema :: (* -> *) -> *). (Monad m, EncodeCon QUERY m event (schema (Resolver QUERY m event)), EncodeCon QUERY m event query, Resolving QUERY m event)-  => schema (Resolver QUERY m event)-  -> EncodeOperator QUERY m event query-encodeQuery schema = encodeOperationWith (objectResolvers (Proxy :: Proxy (CUSTOM (schema (Resolver QUERY m event)))) schema)+encodeQuery+  :: forall m event query (schema :: (* -> *) -> *)+   . ( Monad m+     , EncodeCon QUERY event m (schema (Resolver QUERY event m))+     , EncodeCon QUERY event m query+     )+  => schema (Resolver QUERY event m)+  -> EncodeOperator QUERY event m query+encodeQuery schema = encodeOperationWith+  (objectResolvers (Proxy :: Proxy (CUSTOM (schema (Resolver QUERY event m))))+                   schema+  ) -encodeMutation ::-     forall m event mut. (Monad m, EncodeCon MUTATION m event mut, Resolving MUTATION m event)-  => EncodeOperator MUTATION m event mut+encodeMutation+  :: forall event m mut+   . (Monad m, EncodeCon MUTATION event m mut)+  => EncodeOperator MUTATION event m mut encodeMutation = encodeOperationWith [] -encodeSubscription ::-     forall m event mut. (Monad m, EncodeCon SUBSCRIPTION m event mut, Resolving SUBSCRIPTION m event)-  => EncodeOperator SUBSCRIPTION m event mut+encodeSubscription+  :: forall m event mut+   . (Monad m, EncodeCon SUBSCRIPTION event m mut)+  => EncodeOperator SUBSCRIPTION event m mut encodeSubscription = encodeOperationWith [] -encodeOperationWith ::-     forall o m e a . (Monad m, EncodeCon o m e a, Resolving o m e, PureOperation o)-  => [FieldRes o m e]-  -> EncodeOperator o m e a-encodeOperationWith externalRes rootResolver Operation {operationSelection} = resolveObject operationSelection resolvers-    where-       resolvers = externalRes <> objectResolvers (Proxy :: Proxy (CUSTOM a)) rootResolver+encodeOperationWith+  :: forall o e m a+   . (Monad m, EncodeCon o e m a, LiftEither o ResolvingStrategy)+  => [FieldRes o e m]+  -> EncodeOperator o e m a+encodeOperationWith externalRes rootResolver Operation { operationSelection } =+  resolveObject operationSelection resolvers+ where+  resolvers =+    externalRes <> objectResolvers (Proxy :: Proxy (CUSTOM a)) rootResolver

@@ -6,16 +6,20 @@  module Data.Morpheus.Execution.Server.Generics.EnumRep   ( EnumRep(..)-  ) where+  )+where -import           Data.Proxy                              (Proxy (..))-import           Data.Semigroup                          ((<>))-import           Data.Text                               (Text, pack)+import           Data.Proxy                     ( Proxy(..) )+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( Text+                                                , pack+                                                ) import           GHC.Generics  -- MORPHEUS-import           Data.Morpheus.Error.Internal            (internalError)-import           Data.Morpheus.Types.Internal.Validation (Validation)+import           Data.Morpheus.Error.Internal   ( internalError )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation )  class EnumRep f where   encodeRep :: f a -> Text@@ -38,6 +42,6 @@   decodeEnum name     | name `elem` enumTags (Proxy @a) = L1 <$> decodeEnum name     | name `elem` enumTags (Proxy @b) = R1 <$> decodeEnum name-    | otherwise =-      internalError ("Constructor \"" <> name <> "\" could not find in Union")+    | otherwise = internalError+      ("Constructor \"" <> name <> "\" could not find in Union")   enumTags _ = enumTags (Proxy @a) ++ enumTags (Proxy @b)

@@ -5,22 +5,44 @@  module Data.Morpheus.Execution.Server.Interpreter   ( Interpreter(..)-  ) where+  )+where -import           Data.Aeson                                          (encode)-import           Data.ByteString                                     (ByteString)-import qualified Data.ByteString.Lazy.Char8                          as LB (ByteString, fromStrict, toStrict)-import           Data.Text                                           (Text)-import qualified Data.Text.Lazy                                      as LT (Text, fromStrict, toStrict)-import           Data.Text.Lazy.Encoding                             (decodeUtf8, encodeUtf8)+import           Data.Aeson                     ( encode )+import           Data.ByteString                ( ByteString )+import qualified Data.ByteString.Lazy.Char8    as LB+                                                ( ByteString+                                                , fromStrict+                                                , toStrict+                                                )+import           Data.Text                      ( Text )+import qualified Data.Text.Lazy                as LT+                                                ( Text+                                                , fromStrict+                                                , toStrict+                                                )+import           Data.Text.Lazy.Encoding        ( decodeUtf8+                                                , encodeUtf8+                                                )  -- MORPHEUS-import           Data.Morpheus.Execution.Server.Resolve              (RootResCon, byteStringIO, statefulResolver,-                                                                      statelessResolver, streamResolver)-import           Data.Morpheus.Execution.Subscription.ClientRegister (GQLState)-import           Data.Morpheus.Types.Internal.Resolver               (GQLRootResolver (..))-import           Data.Morpheus.Types.Internal.Stream                 (ResponseStream)-import           Data.Morpheus.Types.IO                              (GQLRequest, GQLResponse)+import           Data.Morpheus.Execution.Server.Resolve+                                                ( RootResCon+                                                , byteStringIO+                                                , statefulResolver+                                                , statelessResolver+                                                , streamResolver+                                                , coreResolver+                                                )+import           Data.Morpheus.Execution.Subscription.ClientRegister+                                                ( GQLState )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( GQLRootResolver(..)+                                                , ResponseStream+                                                )+import           Data.Morpheus.Types.IO         ( GQLRequest+                                                , GQLResponse+                                                )  -- | main query processor and resolver --  possible versions of interpreter@@ -50,7 +72,7 @@ -} type StateLess m a = a -> m a -instance Interpreter (GQLRequest -> m GQLResponse) m e  where+instance Interpreter (GQLRequest -> m GQLResponse) m e   where   interpreter = statelessResolver  instance Interpreter (StateLess m LB.ByteString) m e  where@@ -60,11 +82,11 @@   interpreter root request =     decodeUtf8 <$> interpreter root (encodeUtf8 request) -instance Interpreter (StateLess m ByteString) m e where+instance Interpreter (StateLess m ByteString) m e  where   interpreter root request =     LB.toStrict <$> interpreter root (LB.fromStrict request) -instance Interpreter (StateLess m Text) m e where+instance Interpreter (StateLess m Text) m e  where   interpreter root request =     LT.toStrict <$> interpreter root (LT.fromStrict request) @@ -72,17 +94,16 @@    HTTP Interpreter with state and side effects, every mutation will    trigger subscriptions in  shared `GQLState` -}-type WSPub m e  a = GQLState m e -> a -> m a+type WSPub m e a = GQLState m e -> a -> m a -instance Interpreter (WSPub IO e LB.ByteString) IO e  where-  interpreter root state =-    statefulResolver state (byteStringIO (streamResolver root))+instance Interpreter (WSPub IO e LB.ByteString) IO e where+  interpreter root state = statefulResolver state (coreResolver root) -instance Interpreter (WSPub IO e  LT.Text) IO e  where+instance Interpreter (WSPub IO e  LT.Text) IO e where   interpreter root state request =     decodeUtf8 <$> interpreter root state (encodeUtf8 request) -instance Interpreter (WSPub IO e  ByteString) IO e  where+instance Interpreter (WSPub IO e  ByteString) IO e where   interpreter root state request =     LB.toStrict <$> interpreter root state (LB.fromStrict request) @@ -94,22 +115,22 @@    WebSocket Interpreter without state and side effects, mutations and subscription will return Actions    that will be executed in WebSocket server -}-type WSSub m e a = a -> ResponseStream m e a+type WSSub m e a = a -> ResponseStream e m a -instance Interpreter (GQLRequest -> ResponseStream m e  LB.ByteString) m e where+instance Interpreter (GQLRequest -> ResponseStream e m LB.ByteString) m e where   interpreter root request = encode <$> streamResolver root request -instance Interpreter (WSSub m e  LB.ByteString) m e  where+instance Interpreter (WSSub m e  LB.ByteString) m e where   interpreter root = byteStringIO (streamResolver root) -instance Interpreter (WSSub m e  LT.Text) m e  where+instance Interpreter (WSSub m e  LT.Text)  m e where   interpreter root request =     decodeUtf8 <$> interpreter root (encodeUtf8 request) -instance Interpreter (WSSub m e ByteString) m e  where+instance Interpreter (WSSub m e ByteString) m e where   interpreter root request =     LB.toStrict <$> interpreter root (LB.fromStrict request) -instance Interpreter (WSSub m e Text) m e where+instance Interpreter (WSSub m e Text)  m e where   interpreter root request =     LT.toStrict <$> interpreter root (LT.fromStrict request)

@@ -21,28 +21,54 @@   , IntroCon   , updateLib   , buildType-  ) where+  )+where -import           Data.Map                                        (Map)-import           Data.Proxy                                      (Proxy (..))-import           Data.Semigroup                                  ((<>))-import           Data.Set                                        (Set)-import           Data.Text                                       (Text, pack)+import           Data.Map                       ( Map )+import           Data.Proxy                     ( Proxy(..) )+import           Data.Set                       ( Set )+import           Data.Text                      ( Text+                                                , pack+                                                ) import           GHC.Generics  -- MORPHEUS-import           Data.Morpheus.Error.Schema                      (nameCollisionError)-import           Data.Morpheus.Execution.Internal.GraphScanner   (LibUpdater, resolveUpdates)-import           Data.Morpheus.Execution.Server.Generics.EnumRep (EnumRep (..))-import           Data.Morpheus.Kind                              (Context (..), ENUM, GQL_KIND, INPUT_OBJECT,-                                                                  INPUT_UNION, OBJECT, SCALAR, UNION)-import           Data.Morpheus.Types.Custom                      (MapKind, Pair)-import           Data.Morpheus.Types.GQLScalar                   (GQLScalar (..))-import           Data.Morpheus.Types.GQLType                     (GQLType (..))-import           Data.Morpheus.Types.Internal.Data               (DataArguments, DataField (..), DataType (..),-                                                                  DataTyCon (..), DataTypeLib, TypeAlias (..),-                                                                  defineType, isTypeDefined, toListField,-                                                                  toNullableField)+import           Data.Morpheus.Error.Schema     ( nameCollisionError )+import           Data.Morpheus.Execution.Server.Generics.EnumRep+                                                ( EnumRep(..) )+import           Data.Morpheus.Kind             ( Context(..)+                                                , ENUM+                                                , GQL_KIND+                                                , INPUT_OBJECT+                                                , INPUT_UNION+                                                , OBJECT+                                                , SCALAR+                                                , UNION+                                                )+import           Data.Morpheus.Types.Types     ( MapKind+                                                , Pair+                                                )+import           Data.Morpheus.Types.GQLScalar  ( GQLScalar(..) )+import           Data.Morpheus.Types.GQLType    ( GQLType(..) )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Failure(..)+                                                , resolveUpdates+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( DataArguments+                                                , Meta(..)+                                                , DataField(..)+                                                , DataTyCon(..)+                                                , DataType(..)+                                                , Key+                                                , createAlias+                                                , defineType+                                                , isTypeDefined+                                                , toListField+                                                , toNullableField+                                                , createEnumValue+                                                , TypeUpdater+                                                )   type IntroCon a = (GQLType a, ObjectFields (CUSTOM a) a)@@ -86,11 +112,14 @@  -- Resolver : a -> Resolver b instance (ObjectFields 'False a, Introspect b) => Introspect (a -> m b) where-  field _ name = (field (Proxy @b) name) {fieldArgs = fst $ objectFields (Proxy :: Proxy 'False) (Proxy @a)}-  introspect _ typeLib = resolveUpdates typeLib (introspect (Proxy @b) : argTypes)-    where-      argTypes :: [TypeUpdater]-      argTypes = snd $ objectFields (Proxy :: Proxy 'False) (Proxy @a)+  field _ name = (field (Proxy @b) name)+    { fieldArgs = fst $ objectFields (Proxy :: Proxy 'False) (Proxy @a)+    }+  introspect _ typeLib = resolveUpdates typeLib+                                        (introspect (Proxy @b) : argTypes)+   where+    argTypes :: [TypeUpdater]+    argTypes = snd $ objectFields (Proxy :: Proxy 'False) (Proxy @a)  -- | Introspect With specific Kind: 'kind': object, scalar, enum ... class IntrospectKind (kind :: GQL_KIND) a where@@ -99,72 +128,56 @@ -- SCALAR instance (GQLType a, GQLScalar a) => IntrospectKind SCALAR a where   introspectKind _ = updateLib scalarType [] (Proxy @a)-    where-      scalarType = DataScalar . buildType (scalarValidator (Proxy @a))+    where scalarType = DataScalar . buildType (scalarValidator (Proxy @a))  -- ENUM instance (GQL_TYPE a, EnumRep (Rep a)) => IntrospectKind ENUM a where   introspectKind _ = updateLib enumType [] (Proxy @a)-    where-      enumType = DataEnum . buildType (enumTags (Proxy @(Rep a)))+   where+    enumType =+      DataEnum . buildType (map createEnumValue $ enumTags (Proxy @(Rep a)))  -- INPUT_OBJECT instance (GQL_TYPE a, ObjectFields (CUSTOM a) a) => IntrospectKind INPUT_OBJECT a where-  introspectKind _ = updateLib (DataInputObject . buildType fields) types (Proxy @a)-    where-      (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a)+  introspectKind _ = updateLib (DataInputObject . buildType fields)+                               types+                               (Proxy @a)+    where (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a)  -- OBJECTS instance (GQL_TYPE a, ObjectFields (CUSTOM a) a) => IntrospectKind OBJECT a where-  introspectKind _ = updateLib (DataObject . buildType (__typename : fields)) types (Proxy @a)-    where-      __typename =-        ( "__typename"-        , DataField-            { fieldName = "__typename"-            , fieldArgs = []-            , fieldArgsType = Nothing-            , fieldType = buildAlias "String"-            , fieldHidden = True-            })-      (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a)+  introspectKind _ = updateLib (DataObject . buildType (__typename : fields))+                               types+                               (Proxy @a)+   where+    __typename =+      ( "__typename"+      , DataField { fieldName     = "__typename"+                  , fieldArgs     = []+                  , fieldArgsType = Nothing+                  , fieldType     = createAlias "String"+                  , fieldMeta     = Nothing+                  }+      )+    (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a)  -- UNION instance (GQL_TYPE a, GQLRep UNION (Rep a)) => IntrospectKind UNION a where-  introspectKind _ = updateLib (DataUnion . buildType fields) stack (Proxy @a)-    where-      (fields, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a))+  introspectKind _ = updateLib (DataUnion . buildType memberTypes)+                               stack+                               (Proxy @a)+   where+    (memberTypes, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a))  -- INPUT_UNION instance (GQL_TYPE a, GQLRep UNION (Rep a)) => IntrospectKind INPUT_UNION a where-  introspectKind _ = updateLib (DataInputUnion . buildType (fieldTag : fields)) (tagsEnumType : stack) (Proxy @a)-    where-      (inputUnions, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a))-      fields = map toNullableField inputUnions-      -- for every input Union 'User' adds enum type of possible TypeNames 'UserTags'-      tagsEnumType :: TypeUpdater-      tagsEnumType x = pure $ defineType (typeName, DataEnum tagsEnum) x-        where-          tagsEnum =-            DataTyCon-              { typeName-                -- has same fingerprint as object because it depends on it-              , typeFingerprint = __typeFingerprint (Proxy @a)-              , typeDescription = Nothing-              , typeData = map fieldName inputUnions-              }-      typeName = __typeName (Proxy @a) <> "Tags"-      fieldTag =-        DataField-          { fieldName = "tag"-          , fieldArgs = []-          , fieldArgsType = Nothing-          , fieldType = buildAlias typeName-          , fieldHidden = False-          }+  introspectKind _ = updateLib (DataInputUnion . buildType memberTypes)+                               stack+                               (Proxy @a)+   where+    (memberTypes, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a))  -- Types-type TypeUpdater = LibUpdater DataTypeLib  type GQL_TYPE a = (Generic a, GQLType a) @@ -179,7 +192,7 @@  type instance GQLRepResult OBJECT = (Text, DataField) -type instance GQLRepResult UNION = DataField+type instance GQLRepResult UNION = Key  --  GENERIC UNION class GQLRep (kind :: GQL_KIND) f where@@ -193,45 +206,55 @@  -- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION' instance (GQLRep UNION a, GQLRep UNION b) => GQLRep UNION (a :+: b) where-  gqlRep _ = gqlRep (Context :: Context UNION a) ++ gqlRep (Context :: Context UNION b)+  gqlRep _ =+    gqlRep (Context :: Context UNION a) ++ gqlRep (Context :: Context UNION b)  instance (GQL_TYPE a, Introspect a) => GQLRep UNION (M1 S s (Rec0 a)) where-  gqlRep _ = [(buildField (Proxy @a) [] (__typeName (Proxy @a)), introspect (Proxy @a))]+  gqlRep _ = [(__typeName (Proxy @a), introspect (Proxy @a))]  -- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT' instance (GQLRep OBJECT a, GQLRep OBJECT b) => GQLRep OBJECT (a :*: b) where-  gqlRep _ = gqlRep (Context :: Context OBJECT a) ++ gqlRep (Context :: Context OBJECT b)+  gqlRep _ =+    gqlRep (Context :: Context OBJECT a) ++ gqlRep (Context :: Context OBJECT b)  instance (Selector s, Introspect a) => GQLRep OBJECT (M1 S s (Rec0 a)) where   gqlRep _ = [((name, field (Proxy @a) name), introspect (Proxy @a))]-    where-      name = pack $ selName (undefined :: M1 S s (Rec0 ()) ())+    where name = pack $ selName (undefined :: M1 S s (Rec0 ()) ())  instance GQLRep OBJECT U1 where   gqlRep _ = [] -buildAlias :: Text -> TypeAlias-buildAlias aliasTyCon = TypeAlias {aliasTyCon, aliasWrappers = [], aliasArgs = Nothing}  buildField :: GQLType a => Proxy a -> DataArguments -> Text -> DataField-buildField proxy fieldArgs fieldName =-  DataField-    {fieldName, fieldArgs, fieldArgsType = Nothing, fieldType = buildAlias $ __typeName proxy, fieldHidden = False}+buildField proxy fieldArgs fieldName = DataField+  { fieldName+  , fieldArgs+  , fieldArgsType = Nothing+  , fieldType     = createAlias $ __typeName proxy+  , fieldMeta     = Nothing+  }  buildType :: GQLType a => t -> Proxy a -> DataTyCon t-buildType typeData proxy =-  DataTyCon-    { typeName = __typeName proxy-    , typeFingerprint = __typeFingerprint proxy-    , typeDescription = description proxy-    , typeData-    }+buildType typeData proxy = DataTyCon+  { typeName        = __typeName proxy+  , typeFingerprint = __typeFingerprint proxy+  , typeMeta        = Just Meta { metaDescription = description proxy+                                , metaDirectives  = []+                                }+  , typeData+  } -updateLib :: GQLType a => (Proxy a -> DataType) -> [TypeUpdater] -> Proxy a -> TypeUpdater+updateLib+  :: GQLType a+  => (Proxy a -> DataType)+  -> [TypeUpdater]+  -> Proxy a+  -> TypeUpdater updateLib typeBuilder stack proxy lib' =   case isTypeDefined (__typeName proxy) lib' of-    Nothing -> resolveUpdates (defineType (__typeName proxy, typeBuilder proxy) lib') stack-    Just fingerprint'-      | fingerprint' == __typeFingerprint proxy -> return lib'+    Nothing -> resolveUpdates+      (defineType (__typeName proxy, typeBuilder proxy) lib')+      stack+    Just fingerprint' | fingerprint' == __typeFingerprint proxy -> return lib'     -- throw error if 2 different types has same name-    Just _ -> Left $ nameCollisionError (__typeName proxy)+    Just _ -> failure $ nameCollisionError (__typeName proxy)

@@ -14,138 +14,214 @@   , statefulResolver   , RootResCon   , fullSchema-  ) where+  , coreResolver+  )+where -import           Control.Monad.Except                                (liftEither)-import           Control.Monad.Trans.Except                          (runExceptT)-import           Data.Aeson                                          (encode)-import           Data.Aeson.Internal                                 (formatError, ifromJSON)-import           Data.Aeson.Parser                                   (eitherDecodeWith, jsonNoDup)-import qualified Data.ByteString.Lazy.Char8                          as L-import           Data.Functor.Identity                               (Identity (..))-import           Data.Proxy                                          (Proxy (..))+import           Data.Aeson                     ( encode )+import           Data.Aeson.Internal            ( formatError+                                                , ifromJSON+                                                )+import           Data.Aeson.Parser              ( eitherDecodeWith+                                                , jsonNoDup+                                                )+import qualified Data.ByteString.Lazy.Char8    as L+import           Data.Functor.Identity          ( Identity(..) )+import           Data.Proxy                     ( Proxy(..) )  -- MORPHEUS-import           Data.Morpheus.Error.Utils                           (badRequestError)-import           Data.Morpheus.Execution.Internal.GraphScanner       (resolveUpdates)-import           Data.Morpheus.Execution.Server.Encode               (EncodeCon, encodeMutation, encodeQuery,-                                                                      encodeSubscription)-import           Data.Morpheus.Execution.Server.Introspect           (IntroCon, ObjectFields (..))-import           Data.Morpheus.Execution.Subscription.ClientRegister (GQLState, publishUpdates)-import           Data.Morpheus.Parsing.Request.Parser                (parseGQL)+import           Data.Morpheus.Error.Utils      ( badRequestError )+import           Data.Morpheus.Execution.Server.Encode+                                                ( EncodeCon+                                                , encodeMutation+                                                , encodeQuery+                                                , encodeSubscription+                                                )+import           Data.Morpheus.Execution.Server.Introspect+                                                ( IntroCon+                                                , ObjectFields(..)+                                                )+import           Data.Morpheus.Execution.Subscription.ClientRegister+                                                ( GQLState+                                                , publishUpdates+                                                )+import           Data.Morpheus.Parsing.Request.Parser+                                                ( parseGQL ) --import           Data.Morpheus.Schema.Schema                         (Root)-import           Data.Morpheus.Schema.SchemaAPI                      (defaultTypes, hiddenRootFields, schemaAPI)-import           Data.Morpheus.Types.GQLType                         (GQLType (CUSTOM))-import           Data.Morpheus.Types.Internal.AST.Operation          (Operation (..), ValidOperation)-import           Data.Morpheus.Types.Internal.Data                   (DataFingerprint (..), DataTyCon (..),-                                                                      DataTypeLib (..), MUTATION, OperationType (..),-                                                                      QUERY, SUBSCRIPTION, initTypeLib)-import           Data.Morpheus.Types.Internal.Resolver               (GQLRootResolver (..), Resolver (..), ResponseT,-                                                                      toResponseRes)-import           Data.Morpheus.Types.Internal.Stream                 (GQLChannel (..), ResponseEvent (..),-                                                                      ResponseStream, closeStream)-import           Data.Morpheus.Types.Internal.Validation             (Validation)-import           Data.Morpheus.Types.IO                              (GQLRequest (..), GQLResponse (..), renderResponse)-import           Data.Morpheus.Validation.Internal.Utils             (VALIDATION_MODE (..))-import           Data.Morpheus.Validation.Query.Validation           (validateRequest)-import           Data.Typeable                                       (Typeable)+import           Data.Morpheus.Schema.SchemaAPI ( defaultTypes+                                                , hiddenRootFields+                                                , schemaAPI+                                                )+import           Data.Morpheus.Types.GQLType    ( GQLType(CUSTOM) )+import           Data.Morpheus.Types.Internal.AST+                                                ( Operation(..)+                                                , ValidOperation+                                                , DataFingerprint(..)+                                                , DataTyCon(..)+                                                , DataTypeLib(..)+                                                , MUTATION+                                                , OperationType(..)+                                                , QUERY+                                                , SUBSCRIPTION+                                                , initTypeLib+                                                , Value+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( GQLRootResolver(..)+                                                , Resolver(..)+                                                , toResponseRes+                                                , GQLChannel(..)+                                                , ResponseEvent(..)+                                                , ResponseStream+                                                , Validation+                                                , cleanEvents+                                                , ResultT(..)+                                                , unpackEvents+                                                , Failure(..)+                                                , resolveUpdates+                                                )+import           Data.Morpheus.Types.IO         ( GQLRequest(..)+                                                , GQLResponse(..)+                                                , renderResponse+                                                )+import           Data.Morpheus.Validation.Internal.Utils+                                                ( VALIDATION_MODE(..) )+import           Data.Morpheus.Validation.Query.Validation+                                                ( validateRequest )+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 m event))-                                 , IntroCon (mutation (Resolver MUTATION m event))-                                 , IntroCon (subscription (Resolver SUBSCRIPTION m event)))+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 RootResCon m event query mutation subscription-   = ( EventCon event-     , Typeable m-     , IntrospectConstraint m event query mutation subscription-    -- , OBJ_RES m (Root (Resolver m)) Value-     -- Resolving-     , EncodeCon QUERY m event (query (Resolver QUERY m event))-     , EncodeCon MUTATION m event (mutation (Resolver MUTATION m event))-     , EncodeCon SUBSCRIPTION m event (subscription (Resolver SUBSCRIPTION m event)))+  = ( 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))+    ) -decodeNoDup :: L.ByteString -> Either String GQLRequest-decodeNoDup str =-  case eitherDecodeWith jsonNoDup ifromJSON str of-    Left (path, x) -> Left $ formatError path x-    Right value    -> Right value+decodeNoDup :: Failure String m => L.ByteString -> m GQLRequest+decodeNoDup str = case eitherDecodeWith jsonNoDup ifromJSON str of+  Left  (path, x) -> failure $ formatError path x+  Right value     -> pure value -byteStringIO :: Monad m => (GQLRequest -> m GQLResponse) -> L.ByteString -> m L.ByteString-byteStringIO resolver request =-  case decodeNoDup request of-    Left aesonError' -> return $ badRequestError aesonError'-    Right req        -> encode <$> resolver req -statelessResolver ::-     (Monad m, RootResCon m event query mut sub)-  => GQLRootResolver m event  query mut sub+byteStringIO+  :: Monad m => (GQLRequest -> m GQLResponse) -> L.ByteString -> m L.ByteString+byteStringIO resolver request = case decodeNoDup request of+  Left  aesonError' -> return $ badRequestError aesonError'+  Right req         -> encode <$> resolver req++statelessResolver+  :: (Monad m, RootResCon m event query mut sub)+  => GQLRootResolver m event query mut sub   -> GQLRequest   -> m GQLResponse-statelessResolver root = fmap snd . closeStream . streamResolver root+statelessResolver root req =+  renderResponse <$> runResultT (coreResolver root req) -streamResolver ::-     (Monad m, RootResCon m event  query mut sub)+streamResolver+  :: forall event m query mut sub+   . (Monad m, RootResCon m event query mut sub)   => GQLRootResolver m event query mut sub   -> GQLRequest-  -> ResponseStream m event GQLResponse-streamResolver root@GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver} request =-  renderResponse <$> runExceptT (validRequest >>= execOperator)-  -------------------------------------------------------------  where-    ----------------------------------------------------------    validRequest :: Monad m => ResponseT m event (DataTypeLib, ValidOperation)-    validRequest =-      liftEither $ do-        schema <- fullSchema $ Identity root-        query <- parseGQL request >>= validateRequest schema FULL_VALIDATION-        Right (schema, query)-    -----------------------------------------------------------    execOperator (schema, operation@Operation {operationType = Query}) =-        toResponseRes (encodeQuery (schemaAPI schema) queryResolver operation)-    execOperator (_, operation@Operation {operationType = Mutation}) = toResponseRes (encodeMutation mutationResolver operation)-    execOperator (_, operation@Operation {operationType = Subscription}) = response-        where-         response = toResponseRes (encodeSubscription subscriptionResolver operation)+  -> ResponseStream event m GQLResponse+streamResolver root req =+  ResultT $ pure . renderResponse <$> runResultT (coreResolver root req) -statefulResolver ::-     EventCon s-  => GQLState IO s-  -> (L.ByteString -> ResponseStream IO s  L.ByteString)+coreResolver+  :: forall event m query mut sub+   . (Monad m, RootResCon m event query mut sub)+  => GQLRootResolver m event query mut sub+  -> GQLRequest+  -> ResponseStream event m Value+coreResolver root@GQLRootResolver { queryResolver, mutationResolver, subscriptionResolver } request+  = validRequest >>= execOperator+ where+  validRequest+    :: Monad m => ResponseStream event m (DataTypeLib, ValidOperation)+  validRequest = cleanEvents $ ResultT $ pure $ do+    schema <- fullSchema $ Identity root+    query  <- parseGQL request >>= validateRequest schema FULL_VALIDATION+    pure (schema, query)+  ----------------------------------------------------------+  execOperator (schema, operation@Operation { operationType = Query }) =+    toResponseRes (encodeQuery (schemaAPI schema) queryResolver operation)+  execOperator (_, operation@Operation { operationType = Mutation }) =+    toResponseRes (encodeMutation mutationResolver operation)+  execOperator (_, operation@Operation { operationType = Subscription }) =+    response+   where+    response =+      toResponseRes (encodeSubscription subscriptionResolver operation)++statefulResolver+  :: EventCon event+  => GQLState IO event+  -> (GQLRequest -> ResponseStream event IO Value)   -> L.ByteString   -> IO L.ByteString-statefulResolver state streamApi request = do-  (actions, value) <- closeStream (streamApi request)-  mapM_ execute actions-  pure value-  where-    execute (Publish updates) = publishUpdates state updates-    execute Subscribe {}      = pure ()+statefulResolver state streamApi requestText = do+  res <- runResultT (decodeNoDup requestText >>= streamApi)+  mapM_ execute (unpackEvents res)+  pure $ encode $ renderResponse res+ where+  execute (Publish updates) = publishUpdates state updates+  execute Subscribe{}       = pure () -fullSchema ::-     forall proxy m event query mutation subscription. (IntrospectConstraint m event query mutation subscription)++fullSchema+  :: forall proxy m event query mutation subscription+   . (IntrospectConstraint m event query mutation subscription)   => proxy (GQLRootResolver m event query mutation subscription)   -> Validation DataTypeLib fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema-  where-    querySchema =-      resolveUpdates (initTypeLib (operatorType (hiddenRootFields ++ fields) "Query")) (defaultTypes : types)-      where-        (fields, types) = objectFields (Proxy @(CUSTOM (query (Resolver QUERY m event)))) (Proxy @(query (Resolver QUERY m event)))-    -------------------------------    mutationSchema lib = resolveUpdates (lib {mutation = maybeOperator fields "Mutation"}) types-      where-        (fields, types) = objectFields (Proxy @(CUSTOM (mutation (Resolver MUTATION m event)))) (Proxy @(mutation (Resolver MUTATION m event)))-    -------------------------------    subscriptionSchema lib = resolveUpdates (lib {subscription = maybeOperator fields "Subscription"}) types-      where-        (fields, types) = objectFields (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION m event)))) (Proxy @(subscription (Resolver SUBSCRIPTION m event)))-     -- maybeOperator :: [a] -> Text -> Maybe (Text, DataTyCon[a])-    maybeOperator []     = const Nothing-    maybeOperator fields = Just . operatorType fields-    -- operatorType :: [a] -> Text -> (Text, DataTyCon[a])-    operatorType typeData typeName =-      ( typeName-      , DataTyCon {typeData, typeName, typeFingerprint = SystemFingerprint typeName, typeDescription = Nothing})+ where+  querySchema = resolveUpdates+    (initTypeLib (operatorType (hiddenRootFields ++ fields) "Query"))+    (defaultTypes : types)+   where+    (fields, types) = objectFields+      (Proxy @(CUSTOM (query (Resolver QUERY event m))))+      (Proxy @(query (Resolver QUERY event m)))+  ------------------------------+  mutationSchema lib = resolveUpdates+    (lib { mutation = maybeOperator fields "Mutation" })+    types+   where+    (fields, types) = objectFields+      (Proxy @(CUSTOM (mutation (Resolver MUTATION event m))))+      (Proxy @(mutation (Resolver MUTATION event m)))+  ------------------------------+  subscriptionSchema lib = resolveUpdates+    (lib { subscription = maybeOperator fields "Subscription" })+    types+   where+    (fields, types) = objectFields+      (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION event m))))+      (Proxy @(subscription (Resolver SUBSCRIPTION event m)))+   -- maybeOperator :: [a] -> Text -> Maybe (Text, DataTyCon[a])+  maybeOperator []     = const Nothing+  maybeOperator fields = Just . operatorType fields+  -- operatorType :: [a] -> Text -> (Text, DataTyCon[a])+  operatorType typeData typeName =+    ( typeName+    , DataTyCon { typeData+                , typeName+                , typeFingerprint = SystemFingerprint typeName+                , typeMeta        = Nothing+                }+    )

@@ -10,25 +10,41 @@   , publishUpdates   , addClientSubscription   , removeClientSubscription-  ) where+  )+where -import           Control.Concurrent                          (MVar, modifyMVar, modifyMVar_, newMVar, readMVar)-import           Data.Foldable                               (traverse_)-import           Data.List                                   (intersect)-import           Data.Text                                   (Text)-import           Data.UUID.V4                                (nextRandom)-import           Network.WebSockets                          (Connection, sendTextData)- +import           Control.Concurrent             ( MVar+                                                , modifyMVar+                                                , modifyMVar_+                                                , newMVar+                                                , readMVar+                                                )+import           Data.Foldable                  ( traverse_ )+import           Data.List                      ( intersect )+import           Data.Text                      ( Text )+import           Data.UUID.V4                   ( nextRandom )+import           Network.WebSockets             ( Connection+                                                , sendTextData+                                                ) -- MORPHEUS-import           Data.Morpheus.Execution.Subscription.Apollo (toApolloResponse)-import           Data.Morpheus.Types.Internal.Stream         (Event (..),GQLChannel(..),  SubEvent)-import           Data.Morpheus.Types.Internal.WebSocket      (ClientID, ClientSession (..), GQLClient (..))+import           Data.Morpheus.Execution.Subscription.Apollo+                                                ( toApolloResponse )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Event(..)+                                                , GQLChannel(..)+                                                , SubEvent+                                                )+import           Data.Morpheus.Types.Internal.WebSocket+                                                ( ClientID+                                                , ClientSession(..)+                                                , GQLClient(..)+                                                ) -type ClientRegister m e  = [(ClientID, GQLClient m e)]+type ClientRegister m e = [(ClientID, GQLClient m e)]  -- | shared GraphQL state between __websocket__ and __http__ server, -- stores information about subscriptions-type GQLState m e  = MVar (ClientRegister m e ) -- SharedState+type GQLState m e = MVar (ClientRegister m e) -- SharedState  -- | initializes empty GraphQL state initGQLState :: IO (GQLState m e)@@ -39,71 +55,70 @@   client' <- newClient   modifyMVar_ varState' (addClient client')   return (snd client')-  where-    newClient = do-      clientID <- nextRandom-      return-        (clientID, GQLClient {clientID, clientConnection, clientSessions = []})-    addClient client' state' = return (client' : state')+ where+  newClient = do+    clientID <- nextRandom+    return+      (clientID, GQLClient { clientID, clientConnection, clientSessions = [] })+  addClient client' state' = return (client' : state') -disconnectClient ::-     GQLClient m e  -> GQLState m e -> IO (ClientRegister m e)+disconnectClient :: GQLClient m e -> GQLState m e -> IO (ClientRegister m e) disconnectClient client state = modifyMVar state removeUser-  where-    removeUser state' =-      let s' = removeClient state'-       in return (s', s')-    removeClient :: ClientRegister m e  -> ClientRegister m e-    removeClient = filter ((/= clientID client) . fst)+ where+  removeUser state' = let s' = removeClient state' in return (s', s')+  removeClient :: ClientRegister m e -> ClientRegister m e+  removeClient = filter ((/= clientID client) . fst) -updateClientByID ::-     ClientID+updateClientByID+  :: ClientID   -> (GQLClient m e -> GQLClient m e)-  -> MVar (ClientRegister m e )+  -> MVar (ClientRegister m e)   -> IO ()-updateClientByID id' updateFunc state =-  modifyMVar_ state (return . map updateClient)-  where-    updateClient (key', client')-      | key' == id' = (key', updateFunc client')-    updateClient state' = state'+updateClientByID id' updateFunc state = modifyMVar_+  state+  (return . map updateClient)+ where+  updateClient (key, client') | key == id' = (key, updateFunc client')+  updateClient state'                      = state' -publishUpdates :: (Eq (StreamChannel e), GQLChannel e) => GQLState IO e -> e -> IO ()+publishUpdates+  :: (Eq (StreamChannel e), GQLChannel e) => GQLState IO e -> e -> IO () publishUpdates state event = do   state' <- readMVar state   traverse_ sendMessage state'-  where-    sendMessage (_, GQLClient {clientSessions = []}) = return ()-    sendMessage (_, GQLClient {clientSessions, clientConnection}) =-      mapM_ __send (filterByChannels clientSessions)-      where-        __send ClientSession { sessionId-                             , sessionSubscription = Event {content = subscriptionRes}-                             } =-          subscriptionRes event >>=-          sendTextData clientConnection . toApolloResponse sessionId-        filterByChannels =-          filter-            (not . null .-             intersect (streamChannels event) . channels . sessionSubscription)+ where+  sendMessage (_, GQLClient { clientSessions = [] }             ) = return ()+  sendMessage (_, GQLClient { clientSessions, clientConnection }) = mapM_+    __send+    (filterByChannels clientSessions)+   where+    __send ClientSession { sessionId, sessionSubscription = Event { content = subscriptionRes } }+      = subscriptionRes event+        >>= sendTextData clientConnection+        .   toApolloResponse sessionId+    ---------------------------+    filterByChannels = filter+      ( not+      . null+      . intersect (streamChannels event)+      . channels+      . sessionSubscription+      ) -removeClientSubscription :: ClientID -> Text -> GQLState m e  -> IO ()+removeClientSubscription :: ClientID -> Text -> GQLState m e -> IO () removeClientSubscription id' sid' = updateClientByID id' stopSubscription-  where-    stopSubscription client' =-      client'-        { clientSessions =-            filter ((sid' /=) . sessionId) (clientSessions client')-        }+ where+  stopSubscription client' = client'+    { clientSessions = filter ((sid' /=) . sessionId) (clientSessions client')+    } -addClientSubscription ::-     ClientID -> SubEvent m e  -> Text -> GQLState m e  -> IO ()-addClientSubscription id' sessionSubscription sessionId =-  updateClientByID id' startSubscription-  where-    startSubscription client' =-      client'-        { clientSessions =-            ClientSession {sessionId, sessionSubscription} :-            clientSessions client'-        }+addClientSubscription+  :: ClientID -> SubEvent m e -> Text -> GQLState m e -> IO ()+addClientSubscription id' sessionSubscription sessionId = updateClientByID+  id'+  startSubscription+ where+  startSubscription client' = client'+    { clientSessions = ClientSession { sessionId, sessionSubscription }+                         : clientSessions client'+    }

@@ -16,9 +16,11 @@   , Context(..)   , VContext(..)   , ResContext(..)-  ) where+  )+where -import           Data.Morpheus.Types.Internal.Data (OperationType (..))+import           Data.Morpheus.Types.Internal.AST+                                                ( OperationType(..) )  data GQL_KIND   = SCALAR@@ -30,7 +32,7 @@   | WRAPPER  -data ResContext (kind :: GQL_KIND) (operation:: OperationType) (m :: * -> * ) event value = ResContext+data ResContext (kind :: GQL_KIND) (operation:: OperationType) event (m :: * -> * )  value = ResContext  --type ObjectConstraint a = -- | context , like Proxy with multiple parameters

@@ -1,28 +1,37 @@-{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Parsing.Document.Parser   ( parseTypes-  ) where+  )+where -import           Data.Text                                 (Text)-import           Text.Megaparsec                           (eof, label, manyTill, runParser)+import           Data.Text                      ( Text )+import           Text.Megaparsec                ( eof+                                                , label+                                                , manyTill+                                                , runParser+                                                )  -- MORPHEUS-import           Data.Morpheus.Parsing.Document.TypeSystem (parseDataType)-import           Data.Morpheus.Parsing.Internal.Internal   (processErrorBundle)-import           Data.Morpheus.Parsing.Internal.Terms      (spaceAndComments)-import           Data.Morpheus.Types.Internal.Data         (RawDataType)-import           Data.Morpheus.Types.Internal.Validation   (Validation)+import           Data.Morpheus.Parsing.Document.TypeSystem+                                                ( parseDataType )+import           Data.Morpheus.Parsing.Internal.Internal+                                                ( processErrorBundle )+import           Data.Morpheus.Parsing.Internal.Terms+                                                ( spaceAndComments )+import           Data.Morpheus.Types.Internal.AST+                                                ( RawDataType )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation+                                                , Failure(..)+                                                )  parseTypes :: Text -> Validation [(Text, RawDataType)]-parseTypes doc =-  case parseDoc of-    Right root      -> Right root-    Left parseError -> Left $ processErrorBundle parseError-  where-    parseDoc = runParser request "<input>" doc-    request =-      label "DocumentTypes" $ do-        spaceAndComments-        manyTill parseDataType eof+parseTypes doc = case parseDoc of+  Right root       -> pure root+  Left  parseError -> failure (processErrorBundle parseError)+ where+  parseDoc = runParser request "<input>" doc+  request  = label "DocumentTypes" $ do+    spaceAndComments+    manyTill parseDataType eof

@@ -3,20 +3,44 @@  module Data.Morpheus.Parsing.Document.TypeSystem   ( parseDataType-  ) where+  )+where -import           Data.Text                               (Text)-import           Text.Megaparsec                         (label, sepBy1, (<|>))+import           Data.Text                      ( Text )+import           Text.Megaparsec                ( label+                                                , sepBy1+                                                , (<|>)+                                                )  -- MORPHEUS-import           Data.Morpheus.Parsing.Internal.Create   (createField)-import           Data.Morpheus.Parsing.Internal.Internal (Parser)-import           Data.Morpheus.Parsing.Internal.Pattern  (fieldsDefinition, inputValueDefinition, optionalDirectives,-                                                          typDeclaration)-import           Data.Morpheus.Parsing.Internal.Terms    (keyword, operator, optDescription, parseName, pipeLiteral,-                                                          sepByAnd, setOf)-import           Data.Morpheus.Types.Internal.Data       (DataField, DataFingerprint (..), DataType (..),-                                                          DataTyCon (..), DataValidator (..), Key, RawDataType (..))+import           Data.Morpheus.Parsing.Internal.Internal+                                                ( Parser )+import           Data.Morpheus.Parsing.Internal.Pattern+                                                ( fieldsDefinition+                                                , inputValueDefinition+                                                , optionalDirectives+                                                , typDeclaration+                                                , enumValueDefinition+                                                )+import           Data.Morpheus.Parsing.Internal.Terms+                                                ( keyword+                                                , operator+                                                , optDescription+                                                , parseName+                                                , pipeLiteral+                                                , sepByAnd+                                                , setOf+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( DataField+                                                , DataFingerprint(..)+                                                , DataTyCon(..)+                                                , DataType(..)+                                                , DataValidator(..)+                                                , Key+                                                , RawDataType(..)+                                                , Meta(..)+                                                )   -- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars@@ -25,20 +49,18 @@ --    Description(opt) scalar Name Directives(Const)(opt) -- scalarTypeDefinition :: Maybe Text -> Parser (Text, DataType)-scalarTypeDefinition typeDescription =-  label "ScalarTypeDefinition" $ do-    typeName <- typDeclaration "scalar"-    -- TODO: handle directives-    _ <- optionalDirectives-    pure (-          typeName,-          DataScalar DataTyCon {-            typeName,-            typeDescription,-            typeFingerprint = SystemFingerprint typeName,-            typeData = DataValidator pure-          }-        )+scalarTypeDefinition metaDescription = label "ScalarTypeDefinition" $ do+  typeName       <- typDeclaration "scalar"+  metaDirectives <- optionalDirectives+  pure+    ( typeName+    , DataScalar DataTyCon+      { typeName+      , typeMeta        = Just Meta { metaDescription, metaDirectives }+      , typeFingerprint = SystemFingerprint typeName+      , typeData        = DataValidator pure+      }+    )  -- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects --@@ -56,27 +78,27 @@ --    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) -- objectTypeDefinition :: Maybe Text -> Parser (Text, RawDataType)-objectTypeDefinition typeDescription =-  label "ObjectTypeDefinition" $ do-    name <- typDeclaration "type"-    interfaces <- optionalImplementsInterfaces-    -- TODO: handle directives-    _directives <- optionalDirectives-    fields <- fieldsDefinition-    ---------------------------    pure (name,-         Implements interfaces $ DataTyCon {-           typeName = name,-           typeDescription,-           typeFingerprint = SystemFingerprint name,-           typeData = fields-         }-      )+objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do+  name           <- typDeclaration "type"+  interfaces     <- optionalImplementsInterfaces+  metaDirectives <- optionalDirectives+  fields         <- fieldsDefinition+  --------------------------+  pure+    ( name+    , Implements interfaces $ DataTyCon+      { typeName        = name+      , typeMeta        = Just Meta { metaDescription, metaDirectives }+      , typeFingerprint = SystemFingerprint name+      , typeData        = fields+      }+    )  optionalImplementsInterfaces :: Parser [Text] optionalImplementsInterfaces = implements <|> pure []-  where-    implements = label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd parseName+ where+  implements =+    label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd parseName  -- Interfaces: https://graphql.github.io/graphql-spec/June2018/#sec-Interfaces --@@ -84,21 +106,19 @@ --    Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) -- interfaceTypeDefinition :: Maybe Text -> Parser (Text, RawDataType)-interfaceTypeDefinition typeDescription =-  label "InterfaceTypeDefinition" $ do-    typeName <- typDeclaration "interface"-    -- TODO: handle directives-    _directives <- optionalDirectives-    fields <- fieldsDefinition-    pure (-        typeName,-        Interface DataTyCon {-           typeName,-           typeDescription,-           typeFingerprint = SystemFingerprint typeName,-           typeData = fields-           }-        )+interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do+  typeName       <- typDeclaration "interface"+  metaDirectives <- optionalDirectives+  fields         <- fieldsDefinition+  pure+    ( typeName+    , Interface DataTyCon+      { typeName+      , typeMeta        = Just Meta { metaDescription, metaDirectives }+      , typeFingerprint = SystemFingerprint typeName+      , typeData        = fields+      }+    )   -- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions@@ -110,25 +130,21 @@ --    = |(opt) NamedType --      UnionMemberTypes | NamedType ---unionTypeDefinition :: Maybe Text ->  Parser (Text, DataType)-unionTypeDefinition typeDescription =-  label "UnionTypeDefinition" $ do-    typeName <- typDeclaration "union"-    -- TODO: handle directives-    _directives <- optionalDirectives-    memberTypes <- unionMemberTypes-    pure (-        typeName,-        DataUnion DataTyCon {-             typeName,-             typeDescription,-             typeFingerprint = SystemFingerprint typeName,-             typeData = map unionField memberTypes-           }-        )-  where-    unionField fieldType = createField [] "" ([], fieldType)-    unionMemberTypes = operator '=' *> parseName `sepBy1` pipeLiteral+unionTypeDefinition :: Maybe Text -> Parser (Text, DataType)+unionTypeDefinition metaDescription = label "UnionTypeDefinition" $ do+  typeName       <- typDeclaration "union"+  metaDirectives <- optionalDirectives+  memberTypes    <- unionMemberTypes+  pure+    ( typeName+    , DataUnion DataTyCon+      { typeName+      , typeMeta        = Just Meta { metaDescription, metaDirectives }+      , typeFingerprint = SystemFingerprint typeName+      , typeData        = memberTypes+      }+    )+  where unionMemberTypes = operator '=' *> parseName `sepBy1` pipeLiteral  -- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums --@@ -142,30 +158,21 @@ --    Description(opt) EnumValue Directives(Const)(opt) -- enumTypeDefinition :: Maybe Text -> Parser (Text, DataType)-enumTypeDefinition typeDescription =-  label "EnumTypeDefinition" $ do-    typeName <- typDeclaration "enum"-    -- TODO: handle directives-    _directives <- optionalDirectives-    enumValuesDefinition <- setOf enumValueDefinition-    pure (-           typeName,-           DataEnum DataTyCon {-             typeName,-             typeDescription,-             typeFingerprint = SystemFingerprint typeName,-             typeData = enumValuesDefinition-           }-        )-    where-        enumValueDefinition = label "EnumValueDefinition" $ do-            -- TODO: handle Description-            _fieldDescription <- optDescription-            enumValueName <- parseName-            -- TODO: handle directives-            _directive <- optionalDirectives-            return enumValueName+enumTypeDefinition metaDescription = label "EnumTypeDefinition" $ do+  typeName              <- typDeclaration "enum"+  metaDirectives        <- optionalDirectives+  enumValuesDefinitions <- setOf enumValueDefinition+  pure+    ( typeName+    , DataEnum DataTyCon+      { typeName+      , typeMeta        = Just Meta { metaDescription, metaDirectives }+      , typeFingerprint = SystemFingerprint typeName+      , typeData        = enumValuesDefinitions+      }+    ) + -- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects -- --   InputObjectTypeDefinition@@ -175,43 +182,44 @@ --     { InputValueDefinition(list) } -- inputObjectTypeDefinition :: Maybe Text -> Parser (Text, DataType)-inputObjectTypeDefinition typeDescription =+inputObjectTypeDefinition metaDescription =   label "InputObjectTypeDefinition" $ do-    typeName <- typDeclaration "input"-    -- TODO: handle directives-    _directives <- optionalDirectives-    fields <- inputFieldsDefinition+    typeName       <- typDeclaration "input"+    metaDirectives <- optionalDirectives+    fields         <- inputFieldsDefinition     pure-       (-         typeName,-         DataInputObject DataTyCon {-           typeName,-           typeDescription,-           typeFingerprint = SystemFingerprint typeName,-           typeData = fields-         }-       )-    where-      inputFieldsDefinition :: Parser [(Key, DataField)]-      inputFieldsDefinition = label "InputFieldsDefinition" $ setOf inputValueDefinition+      ( typeName+      , DataInputObject DataTyCon+        { typeName+        , typeMeta        = Just Meta { metaDescription, metaDirectives }+        , typeFingerprint = SystemFingerprint typeName+        , typeData        = fields+        }+      )+ where+  inputFieldsDefinition :: Parser [(Key, DataField)]+  inputFieldsDefinition =+    label "InputFieldsDefinition" $ setOf inputValueDefinition   parseFinalDataType :: Maybe Text -> Parser (Text, DataType)-parseFinalDataType description = label "TypeDefinition" $-        inputObjectTypeDefinition description+parseFinalDataType description =+  label "TypeDefinition"+    $   inputObjectTypeDefinition description     <|> unionTypeDefinition description     <|> enumTypeDefinition description     <|> scalarTypeDefinition description  parseDataType :: Parser (Text, RawDataType) parseDataType = label "TypeDefinition" $ do-    description <- optDescription-    types description-    where-      types description = interfaceTypeDefinition description <|>-              objectTypeDefinition description <|>-              finalDataT-              where-                finalDataT = do-                  (name, datatype) <- parseFinalDataType description-                  pure (name, FinalDataType datatype)+  description <- optDescription+  types description+ where+  types description =+    interfaceTypeDefinition description+      <|> objectTypeDefinition description+      <|> finalDataT+   where+    finalDataT = do+      (name, datatype) <- parseFinalDataType description+      pure (name, FinalDataType datatype)

@@ -1,67 +0,0 @@-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parsing.Internal.Create-  ( createField-  , createArgument-  , createType-  , createScalarType-  , createEnumType-  , createUnionType-  , createDataTypeLib-  ) where--import           Data.Text                               (Text)---- MORPHEUS-import           Data.Morpheus.Error.Internal            (internalError)-import           Data.Morpheus.Types.Internal.Data       (DataArguments, DataField (..), DataFingerprint (..),-                                                          DataTyCon (..), DataType (..), DataTypeLib (..),-                                                          DataValidator (..), TypeAlias (..), WrapperD, defineType,-                                                          initTypeLib)-import           Data.Morpheus.Types.Internal.Validation (Validation)---createField :: DataArguments -> Text -> ([WrapperD], Text) -> DataField-createField fieldArgs fieldName (aliasWrappers, aliasTyCon) =-  DataField-    { fieldArgs-    , fieldArgsType = Nothing-    , fieldName-    , fieldType = TypeAlias {aliasTyCon, aliasWrappers, aliasArgs = Nothing}-    , fieldHidden = False-    }--createArgument :: Text -> ([WrapperD], Text) -> (Text, DataField)-createArgument fieldName x = (fieldName, createField [] fieldName x)--createType :: Text -> a -> DataTyCon a-createType typeName typeData =-  DataTyCon {typeName, typeDescription = Nothing, typeFingerprint = SystemFingerprint "", typeData}--createScalarType :: Text -> (Text, DataType)-createScalarType typeName = (typeName, DataScalar $ createType typeName (DataValidator pure))--createEnumType :: Text -> [Text] -> (Text, DataType)-createEnumType typeName typeData = (typeName, DataEnum $ createType typeName typeData)--createUnionType :: Text -> [Text] -> (Text, DataType)-createUnionType typeName typeData = (typeName, DataUnion $ createType typeName $ map unionField typeData)-  where-    unionField fieldType = createField [] "" ([], fieldType)--createDataTypeLib :: [(Text, DataType)] -> Validation DataTypeLib-createDataTypeLib types =-  case takeByKey "Query" types of-    (Just query, lib1) ->-      case takeByKey "Mutation" lib1 of-        (mutation, lib2) ->-          case takeByKey "Subscription" lib2 of-            (subscription, lib3) -> pure ((foldr defineType (initTypeLib query) lib3) {mutation, subscription})-    _ -> internalError "Query Not Defined"-  -----------------------------------------------------------------------------  where-    takeByKey key lib =-      case lookup key lib of-        Just (DataObject value) -> (Just (key, value), filter ((/= key) . fst) lib)-        _                       -> (Nothing, lib)

@@ -5,31 +5,52 @@   , Position   , processErrorBundle   , getLocation-  ) where+  )+where -import qualified Data.List.NonEmpty                      as NonEmpty-import           Data.Morpheus.Error.Utils               (toLocation)-import           Data.Morpheus.Types.Internal.Base       (Location)-import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)-import           Data.Text                               (Text, pack)-import           Data.Void                               (Void)-import           Text.Megaparsec                         (ParseError, ParseErrorBundle (ParseErrorBundle), Parsec,-                                                          SourcePos, attachSourcePos, bundleErrors, bundlePosState,-                                                          errorOffset, getSourcePos, parseErrorPretty)+import qualified Data.List.NonEmpty            as NonEmpty+import           Data.Morpheus.Error.Utils      ( toLocation )+import           Data.Morpheus.Types.Internal.AST+                                                ( Position )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( GQLError(..)+                                                , GQLErrors+                                                )+import           Data.Text                      ( Text+                                                , pack+                                                )+import           Data.Void                      ( Void )+import           Text.Megaparsec                ( ParseError+                                                , ParseErrorBundle+                                                  ( ParseErrorBundle+                                                  )+                                                , Parsec+                                                , SourcePos+                                                , attachSourcePos+                                                , bundleErrors+                                                , bundlePosState+                                                , errorOffset+                                                , getSourcePos+                                                , parseErrorPretty+                                                ) -type Position = Location -getLocation :: Parser Location+getLocation :: Parser Position getLocation = fmap toLocation getSourcePos  type Parser = Parsec Void Text  processErrorBundle :: ParseErrorBundle Text Void -> GQLErrors processErrorBundle = fmap parseErrorToGQLError . bundleToErrors-  where-    parseErrorToGQLError :: (ParseError Text Void, SourcePos) -> GQLError-    parseErrorToGQLError (err, position) =-      GQLError {desc = pack (parseErrorPretty err), positions = [toLocation position]}-    bundleToErrors :: ParseErrorBundle Text Void -> [(ParseError Text Void, SourcePos)]-    bundleToErrors ParseErrorBundle {bundleErrors, bundlePosState} =-      NonEmpty.toList $ fst $ attachSourcePos errorOffset bundleErrors bundlePosState+ where+  parseErrorToGQLError :: (ParseError Text Void, SourcePos) -> GQLError+  parseErrorToGQLError (err, position) = GQLError+    { message   = pack (parseErrorPretty err)+    , locations = [toLocation position]+    }+  bundleToErrors+    :: ParseErrorBundle Text Void -> [(ParseError Text Void, SourcePos)]+  bundleToErrors ParseErrorBundle { bundleErrors, bundlePosState } =+    NonEmpty.toList $ fst $ attachSourcePos errorOffset+                                            bundleErrors+                                            bundlePosState

@@ -1,38 +1,89 @@+{-# LANGUAGE NamedFieldPuns #-}+ module Data.Morpheus.Parsing.Internal.Pattern-  ( inputValueDefinition-  , fieldsDefinition-  , typDeclaration-  , optionalDirectives-  ) where+    ( inputValueDefinition+    , fieldsDefinition+    , typDeclaration+    , optionalDirectives+    , enumValueDefinition+    )+where  -import           Text.Megaparsec                         (label, many)+import           Text.Megaparsec                ( label+                                                , many+                                                )  -- MORPHEUS-import           Data.Morpheus.Parsing.Internal.Create   (createField)-import           Data.Morpheus.Parsing.Internal.Internal (Parser)-import           Data.Morpheus.Parsing.Internal.Terms    (keyword, optDescription, litAssignment, operator, parseAssignment,-                                                          parseMaybeTuple, parseName, parseType, setOf)-import           Data.Morpheus.Parsing.Internal.Value    (parseDefaultValue, parseValue)-import           Data.Morpheus.Types.Internal.Data       (DataField, Key, Name)+import           Data.Morpheus.Parsing.Internal.Internal+                                                ( Parser )+import           Data.Morpheus.Parsing.Internal.Terms+                                                ( keyword+                                                , litAssignment+                                                , operator+                                                , optDescription+                                                , parseAssignment+                                                , parseMaybeTuple+                                                , parseName+                                                , parseType+                                                , setOf+                                                )+import           Data.Morpheus.Parsing.Internal.Value+                                                ( parseDefaultValue+                                                , parseValue+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( DataField(..)+                                                , Directive(..)+                                                , Key+                                                , Meta(..)+                                                , DataEnumValue(..)+                                                , Name+                                                , TypeAlias(..)+                                                )  +--  EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition+--+--  EnumValueDefinition+--    Description(opt) EnumValue Directives(Const)(opt)+--+enumValueDefinition :: Parser DataEnumValue+enumValueDefinition = label "EnumValueDefinition" $ do+    metaDescription <- optDescription+    enumName        <- parseName+    metaDirectives  <- optionalDirectives+    return $ DataEnumValue+        { enumName+        , enumMeta = Just Meta { metaDescription, metaDirectives }+        }+ -- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition -- -- InputValueDefinition --   Description(opt) Name : Type DefaultValue(opt) Directives (Const)(opt) ---inputValueDefinition ::  Parser (Key, DataField)+inputValueDefinition :: Parser (Key, DataField) inputValueDefinition = label "InputValueDefinition" $ do-    -- TODO: handle Description(opt)-    _description <- optDescription-    name <- parseName+    metaDescription <- optDescription+    fieldName       <- parseName     litAssignment -- ':'-    type_ <- parseType-    -- TODO: handle default value-    _ <- parseDefaultValue-    _ <- optionalDirectives-    pure (name, createField [] name type_)+    (aliasWrappers, aliasTyCon) <- parseType+    _                           <- parseDefaultValue+    metaDirectives              <- optionalDirectives+    pure+        ( fieldName+        , DataField+            { fieldArgs     = []+            , fieldArgsType = Nothing+            , fieldName+            , fieldType     = TypeAlias { aliasTyCon+                                        , aliasWrappers+                                        , aliasArgs     = Nothing+                                        }+            , fieldMeta     = Just Meta { metaDescription, metaDirectives }+            }+        )  -- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments --@@ -40,7 +91,8 @@ --   ( InputValueDefinition(list) ) -- argumentsDefinition :: Parser [(Key, DataField)]-argumentsDefinition = label "ArgumentsDefinition" $  parseMaybeTuple inputValueDefinition+argumentsDefinition =+    label "ArgumentsDefinition" $ parseMaybeTuple inputValueDefinition   --  FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition@@ -55,17 +107,27 @@ --  FieldDefinition --    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) ---fieldDefinition ::  Parser (Key, DataField)-fieldDefinition  = label "FieldDefinition" $ do-    -- TODO: handle Description(opt)-    _description <- optDescription-    name <- parseName-    args <- argumentsDefinition+fieldDefinition :: Parser (Key, DataField)+fieldDefinition = label "FieldDefinition" $ do+    metaDescription <- optDescription+    fieldName       <- parseName+    fieldArgs       <- argumentsDefinition     litAssignment -- ':'-    type_ <- parseType-    -- TODO: handle directives-    _ <- optionalDirectives-    pure (name, createField args name type_)+    (aliasWrappers, aliasTyCon) <- parseType+    metaDirectives              <- optionalDirectives+    pure+        ( fieldName+        , DataField+            { fieldName+            , fieldArgs+            , fieldArgsType = Nothing+            , fieldType     = TypeAlias { aliasTyCon+                                        , aliasWrappers+                                        , aliasArgs     = Nothing+                                        }+            , fieldMeta     = Just Meta { metaDescription, metaDirectives }+            }+        )  -- Directives : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives --@@ -74,19 +136,18 @@ -- Directives[Const] -- Directive[Const](list) ---optionalDirectives :: Parser [()]+optionalDirectives :: Parser [Directive] optionalDirectives = label "Directives" $ many directive  -- Directive[Const] -- -- @ Name Arguments[Const](opt)--- TODO:  returns real DataType-directive :: Parser ()+directive :: Parser Directive directive = label "Directive" $ do     operator '@'-    _name <- parseName-    _args <- parseMaybeTuple (parseAssignment parseName parseValue)-    pure ()+    directiveName <- parseName+    directiveArgs <- parseMaybeTuple (parseAssignment parseName parseValue)+    pure Directive { directiveName, directiveArgs }   -- typDeclaration : Not in spec ,start part of type definitions@@ -96,5 +157,5 @@ -- typDeclaration :: Name -> Parser Name typDeclaration kind = do-  keyword kind-  parseName+    keyword kind+    parseName

@@ -1,4 +1,3 @@-{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections     #-} @@ -27,19 +26,52 @@   , keyword   , operator   , optDescription-  ) where+  )+where -import           Data.Functor                            (($>))-import           Data.Text                               (Text, pack)-import           Text.Megaparsec                         (between, label,try, many, manyTill, optional, sepBy, sepEndBy,-                                                          skipMany, skipManyTill, try, (<?>), (<|>))-import           Text.Megaparsec.Char                    (char, digitChar, letterChar, newline, printChar, space,-                                                          space1, string)+import           Data.Functor                   ( ($>) )+import           Data.Text                      ( Text+                                                , pack+                                                , strip+                                                )+import           Text.Megaparsec                ( between+                                                , label+                                                , try+                                                , many+                                                , manyTill+                                                , optional+                                                , sepBy+                                                , sepEndBy+                                                , skipMany+                                                , skipManyTill+                                                , try+                                                , (<?>)+                                                , (<|>)+                                                )+import           Text.Megaparsec.Char           ( char+                                                , digitChar+                                                , letterChar+                                                , newline+                                                , printChar+                                                , space+                                                , space1+                                                , string+                                                )  -- MORPHEUS-import           Data.Morpheus.Parsing.Internal.Internal (Parser, Position, getLocation)-import           Data.Morpheus.Types.Internal.Data       (DataTypeWrapper (..), Key, Description , Name, WrapperD (..), toHSWrappers)-import           Data.Morpheus.Types.Internal.Value      (convertToHaskellName)+import           Data.Morpheus.Parsing.Internal.Internal+                                                ( Parser+                                                , Position+                                                , getLocation+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( DataTypeWrapper(..)+                                                , Key+                                                , Description+                                                , Name+                                                , TypeWrapper(..)+                                                , toHSWrappers+                                                , convertToHaskellName )   -- Name : https://graphql.github.io/graphql-spec/June2018/#sec-Names@@ -57,7 +89,8 @@  -- LITERALS setLiteral :: Parser [a] -> Parser [a]-setLiteral = between (char '{' *> spaceAndComments) (char '}' *> spaceAndComments)+setLiteral =+  between (char '{' *> spaceAndComments) (char '}' *> spaceAndComments)  pipeLiteral :: Parser () pipeLiteral = char '|' *> spaceAndComments@@ -71,19 +104,17 @@ -- PRIMITIVE ------------------------------------ token :: Parser Text-token =-  label "token" $ do-    firstChar <- letterChar <|> char '_'-    restToken <- many $ letterChar <|> char '_' <|> digitChar-    spaceAndComments-    return $ convertToHaskellName $ pack $ firstChar : restToken+token = label "token" $ do+  firstChar <- letterChar <|> char '_'+  restToken <- many $ letterChar <|> char '_' <|> digitChar+  spaceAndComments+  return $ convertToHaskellName $ pack $ firstChar : restToken  qualifier :: Parser (Text, Position)-qualifier =-  label "qualifier" $ do-    position <- getLocation-    value <- token-    return (value, position)+qualifier = label "qualifier" $ do+  position <- getLocation+  value    <- token+  return (value, position)   -- Variable : https://graphql.github.io/graphql-spec/June2018/#Variable@@ -91,12 +122,11 @@ -- Variable :  $Name -- variable :: Parser (Text, Position)-variable =-  label "variable" $ do-    position' <- getLocation-    _ <- char '$'-    varName' <- token-    return (varName', position')+variable = label "variable" $ do+  position' <- getLocation+  _         <- char '$'+  varName'  <- token+  return (varName', position')  spaceAndComments1 :: Parser () spaceAndComments1 = space1 *> spaceAndComments@@ -111,15 +141,18 @@ optDescription = optional parseDescription  parseDescription :: Parser Text-parseDescription = pack <$> (blockDescription <|> singleLine) <* spaceAndComments-    where-      blockDescription = blockQuotes *> manyTill (printChar <|> newline)   blockQuotes <* spaceAndComments-        where-         blockQuotes = string "\"\"\""-      -----------------------------      singleLine = stringQuote *> manyTill printChar  stringQuote <* spaceAndComments-        where-            stringQuote = char '"'+parseDescription =+  strip . pack <$> (blockDescription <|> singleLine) <* spaceAndComments+ where+  blockDescription =+    blockQuotes+      *> manyTill (printChar <|> newline) blockQuotes+      <* spaceAndComments+    where blockQuotes = string "\"\"\""+  ----------------------------+  singleLine =+    stringQuote *> manyTill printChar stringQuote <* spaceAndComments+    where stringQuote = char '"'  -- Ignored Tokens : https://graphql.github.io/graphql-spec/June2018/#sec-Source-Text.Ignored-Tokens --  Ignored:@@ -133,9 +166,9 @@ spaceAndComments = ignoredTokens  ignoredTokens :: Parser ()-ignoredTokens = label "IgnoredTokens" $ space *> skipMany inlineComment *> space-  where-    inlineComment = char '#' *> skipManyTill printChar newline *> space+ignoredTokens =+  label "IgnoredTokens" $ space *> skipMany inlineComment *> space+  where inlineComment = char '#' *> skipManyTill printChar newline *> space     ------------------------------------------------------------------------  -- COMPLEX@@ -156,20 +189,18 @@ parseMaybeTuple parser = parseTuple parser <|> pure []  parseTuple :: Parser a -> Parser [a]-parseTuple parser =-  label "Tuple" $-  between-    (char '(' *> spaceAndComments)-    (char ')' *> spaceAndComments)-    (parser `sepBy` (many (char ',') *> spaceAndComments) <?> "empty Tuple value!")+parseTuple parser = label "Tuple" $ between+  (char '(' *> spaceAndComments)+  (char ')' *> spaceAndComments)+  (parser `sepBy` (many (char ',') *> spaceAndComments) <?> "empty Tuple value!"+  )  parseAssignment :: (Show a, Show b) => Parser a -> Parser b -> Parser (a, b)-parseAssignment nameParser valueParser =-  label "assignment" $ do-    name' <- nameParser-    litAssignment-    value' <- valueParser-    pure (name', value')+parseAssignment nameParser valueParser = label "assignment" $ do+  name' <- nameParser+  litAssignment+  value' <- valueParser+  pure (name', value')  -- Type Conditions: https://graphql.github.io/graphql-spec/June2018/#sec-Type-Conditions --@@ -185,36 +216,36 @@ spreadLiteral :: Parser Position spreadLiteral = do   index <- getLocation-  _ <- string "..."+  _     <- string "..."   space   return index  parseWrappedType :: Parser ([DataTypeWrapper], Text) parseWrappedType = (unwrapped <|> wrapped) <* spaceAndComments-  where-    unwrapped :: Parser ([DataTypeWrapper], Text)-    unwrapped = ([], ) <$> token <* spaceAndComments-    -----------------------------------------------    wrapped :: Parser ([DataTypeWrapper], Text)-    wrapped =-      between-        (char '[' *> spaceAndComments)-        (char ']' *> spaceAndComments)-        (do (wrappers, name) <- unwrapped <|> wrapped-            nonNull' <- parseNonNull-            return ((ListType : nonNull') ++ wrappers, name))+ where+  unwrapped :: Parser ([DataTypeWrapper], Text)+  unwrapped = ([], ) <$> token <* spaceAndComments+  ----------------------------------------------+  wrapped :: Parser ([DataTypeWrapper], Text)+  wrapped = between+    (char '[' *> spaceAndComments)+    (char ']' *> spaceAndComments)+    (do+      (wrappers, name) <- unwrapped <|> wrapped+      nonNull'         <- parseNonNull+      return ((ListType : nonNull') ++ wrappers, name)+    )  -- Field Alias : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Alias -- Alias --  Name: parseAlias :: Parser (Maybe Key) parseAlias = try (optional alias) <|> pure Nothing-    where-        alias = label "alias" $ token <* char ':' <* spaceAndComments+  where alias = label "alias" $ token <* char ':' <* spaceAndComments  -parseType :: Parser ([WrapperD],Key)+parseType :: Parser ([TypeWrapper], Key) parseType = do-    (wrappers, fieldType) <- parseWrappedType-    nonNull <- parseNonNull-    pure (toHSWrappers $ nonNull ++ wrappers, fieldType)+  (wrappers, fieldType) <- parseWrappedType+  nonNull               <- parseNonNull+  pure (toHSWrappers $ nonNull ++ wrappers, fieldType)

@@ -5,49 +5,68 @@   ( parseValue   , enumValue   , parseDefaultValue-  ) where+  )+where -import           Data.Functor                            (($>))-import           Data.Text                               (pack)-import           Text.Megaparsec                         (anySingleBut, between, choice, label, many, optional, sepBy,-                                                          (<|>))-import           Text.Megaparsec.Char                    (char, string)-import           Text.Megaparsec.Char.Lexer              (scientific)+import           Data.Functor                   ( ($>) )+import           Data.Text                      ( pack )+import           Text.Megaparsec                ( anySingleBut+                                                , between+                                                , choice+                                                , label+                                                , many+                                                , optional+                                                , sepBy+                                                , (<|>)+                                                )+import           Text.Megaparsec.Char           ( char+                                                , string+                                                )+import           Text.Megaparsec.Char.Lexer     ( scientific )  -- -- MORPHEUS-import           Data.Morpheus.Parsing.Internal.Internal (Parser)-import           Data.Morpheus.Parsing.Internal.Terms    (litEquals, parseAssignment, setOf, spaceAndComments, token)-import           Data.Morpheus.Types.Internal.Value      (ScalarValue (..), Value (..), decodeScientific)+import           Data.Morpheus.Parsing.Internal.Internal+                                                ( Parser )+import           Data.Morpheus.Parsing.Internal.Terms+                                                ( litEquals+                                                , parseAssignment+                                                , setOf+                                                , spaceAndComments+                                                , token+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( ScalarValue(..)+                                                , Value(..)+                                                , decodeScientific+                                                )  parseDefaultValue :: Parser (Maybe Value)-parseDefaultValue =-  optional $ do-    litEquals-    parseValue+parseDefaultValue = optional $ do+  litEquals+  parseValue  parseValue :: Parser Value-parseValue =-  label "value" $ do-    value <- -        valueNull -        <|> booleanValue -        <|> valueNumber -        <|> enumValue -        <|> stringValue -        <|> objectValue -        <|> listValue-    spaceAndComments-    return value+parseValue = label "value" $ do+  value <-+    valueNull+    <|> booleanValue+    <|> valueNumber+    <|> enumValue+    <|> stringValue+    <|> objectValue+    <|> listValue+  spaceAndComments+  return value  valueNull :: Parser Value valueNull = string "null" $> Null  booleanValue :: Parser Value booleanValue = boolTrue <|> boolFalse-  where-    boolTrue = string "true" $> Scalar (Boolean True)-    boolFalse = string "false" $> Scalar (Boolean False)+ where+  boolTrue  = string "true" $> Scalar (Boolean True)+  boolFalse = string "false" $> Scalar (Boolean False)  valueNumber :: Parser Value valueNumber = Scalar . decodeScientific <$> scientific@@ -59,30 +78,26 @@   return enum  escaped :: Parser Char-escaped =-  label "escaped" $ do-    x <- anySingleBut '\"'-    if x == '\\'-      then choice (zipWith escapeChar codes replacements)-      else pure x-  where-    replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']-    codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']-    escapeChar code replacement = char code >> return replacement+escaped = label "escaped" $ do+  x <- anySingleBut '\"'+  if x == '\\' then choice (zipWith escapeChar codes replacements) else pure x+ where+  replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']+  codes        = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']+  escapeChar code replacement = char code >> return replacement  stringValue :: Parser Value-stringValue = label "stringValue" $ Scalar . String . pack <$> between (char '"') (char '"') (many escaped)+stringValue = label "stringValue" $ Scalar . String . pack <$> between+  (char '"')+  (char '"')+  (many escaped)  listValue :: Parser Value-listValue =-  label "listValue" $-  List <$>-  between-    (char '[' *> spaceAndComments)-    (char ']' *> spaceAndComments)-    (parseValue `sepBy` (char ',' *> spaceAndComments))+listValue = label "listValue" $ List <$> between+  (char '[' *> spaceAndComments)+  (char ']' *> spaceAndComments)+  (parseValue `sepBy` (char ',' *> spaceAndComments))  objectValue :: Parser Value objectValue = label "objectValue" $ Object <$> setOf entry-  where-    entry = parseAssignment token parseValue+  where entry = parseAssignment token parseValue

@@ -6,73 +6,100 @@  module Data.Morpheus.Parsing.JSONSchema.Parse   ( decodeIntrospection-  ) where+  )+where  import           Data.Aeson-import           Data.ByteString.Lazy                    (ByteString)-import           Data.Morpheus.Error.Internal            (internalError)-import           Data.Morpheus.Parsing.Internal.Create   (createArgument, createDataTypeLib, createEnumType,-                                                          createField, createScalarType, createType, createUnionType)-import           Data.Morpheus.Parsing.JSONSchema.Types  (EnumValue (..), Field (..), InputValue (..),-                                                          Introspection (..), Schema (..), Type (..))-import           Data.Morpheus.Schema.TypeKind           (TypeKind (..))-import           Data.Morpheus.Types.Internal.Data       (DataField, DataType (..), DataTypeLib,-                                                          DataTypeWrapper (..), Key, WrapperD, toHSWrappers)-import           Data.Morpheus.Types.Internal.Validation (Validation)-import           Data.Morpheus.Types.IO                  (JSONResponse (..))-import           Data.Semigroup                          ((<>))-import           Data.Text                               (Text, pack)+import           Data.ByteString.Lazy           ( ByteString )+import           Data.Morpheus.Error.Internal   ( internalError )+import           Data.Morpheus.Parsing.JSONSchema.Types+                                                ( EnumValue(..)+                                                , Field(..)+                                                , InputValue(..)+                                                , Introspection(..)+                                                , Schema(..)+                                                , Type(..)+                                                )+import           Data.Morpheus.Schema.TypeKind  ( TypeKind(..) )+import           Data.Morpheus.Types.Internal.AST+                                                ( DataField+                                                , DataType(..)+                                                , DataTypeLib+                                                , DataTypeWrapper(..)+                                                , Key+                                                , TypeWrapper+                                                , createArgument+                                                , createDataTypeLib+                                                , createEnumType+                                                , createField+                                                , createScalarType+                                                , createType+                                                , createUnionType+                                                , toHSWrappers+                                                )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation )+import           Data.Morpheus.Types.IO         ( JSONResponse(..) )+import           Data.Semigroup                 ( (<>) )+import           Data.Text                      ( Text+                                                , pack+                                                )  decodeIntrospection :: ByteString -> Validation DataTypeLib-decodeIntrospection jsonDoc =-  case jsonSchema of-    Left errors -> internalError $ pack errors-    Right JSONResponse {responseData = Just Introspection {__schema = Schema {types}}} ->-      traverse parse types >>= createDataTypeLib-    Right res -> internalError (pack $ show res)-  where-    jsonSchema :: Either String (JSONResponse Introspection)-    jsonSchema = eitherDecode jsonDoc+decodeIntrospection jsonDoc = case jsonSchema of+  Left errors -> internalError $ pack errors+  Right JSONResponse { responseData = Just Introspection { __schema = Schema { types } } }+    -> traverse parse types >>= createDataTypeLib . concat+  Right res -> internalError (pack $ show res)+ where+  jsonSchema :: Either String (JSONResponse Introspection)+  jsonSchema = eitherDecode jsonDoc  class ParseJSONSchema a b where-  parse :: a -> Validation (Key, b)+  parse :: a -> Validation b -instance ParseJSONSchema Type DataType where-  parse Type {name = Just typeName, kind = SCALAR} = pure $ createScalarType typeName-  parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} =-    pure $ createEnumType typeName (map enumName enums)-  parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} =-    case traverse name unions of+instance ParseJSONSchema Type [(Key,DataType)] where+  parse Type { name = Just typeName, kind = SCALAR } =+    pure [createScalarType typeName]+  parse Type { name = Just typeName, kind = ENUM, enumValues = Just enums } =+    pure [createEnumType typeName (map enumName enums)]+  parse Type { name = Just typeName, kind = UNION, possibleTypes = Just unions }+    = case traverse name unions of       Nothing  -> internalError "ERROR: GQL ERROR"-      Just uni -> pure $ createUnionType typeName uni-  parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} = do-    fields <- traverse parse iFields-    pure (typeName, DataInputObject $ createType typeName fields)-  parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} = do-    fields <- traverse parse oFields-    pure (typeName, DataObject $ createType typeName fields)-  parse x = internalError $ "Unsuported type" <> pack (show x)+      Just uni -> pure [createUnionType typeName uni]+  parse Type { name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields }+    = do+      fields <- traverse parse iFields+      pure [(typeName, DataInputObject $ createType typeName fields)]+  parse Type { name = Just typeName, kind = OBJECT, fields = Just oFields } =+    do+      fields <- traverse parse oFields+      pure [(typeName, DataObject $ createType typeName fields)]+  parse _ = pure [] -instance ParseJSONSchema Field DataField where-  parse Field {fieldName, fieldArgs, fieldType} = do+instance ParseJSONSchema Field (Key,DataField) where+  parse Field { fieldName, fieldArgs, fieldType } = do     fType <- fieldTypeFromJSON fieldType-    args <- traverse genArg fieldArgs+    args  <- traverse genArg fieldArgs     pure (fieldName, createField args fieldName fType)-    where-      genArg InputValue {inputName = argName, inputType = argType} =-        createArgument argName <$> fieldTypeFromJSON argType+   where+    genArg InputValue { inputName = argName, inputType = argType } =+      createArgument argName <$> fieldTypeFromJSON argType -instance ParseJSONSchema InputValue DataField where-  parse InputValue {inputName, inputType} = do+instance ParseJSONSchema InputValue (Key,DataField) where+  parse InputValue { inputName, inputType } = do     fieldType <- fieldTypeFromJSON inputType     pure (inputName, createField [] inputName fieldType) -fieldTypeFromJSON :: Type -> Validation ([WrapperD], Text)+fieldTypeFromJSON :: Type -> Validation ([TypeWrapper], Text) fieldTypeFromJSON = fmap toHs . fieldTypeRec []-  where-    toHs (w, t) = (toHSWrappers w, t)-    fieldTypeRec :: [DataTypeWrapper] -> Type -> Validation ([DataTypeWrapper], Text)-    fieldTypeRec acc Type {kind = LIST, ofType = Just ofType} = fieldTypeRec (ListType : acc) ofType-    fieldTypeRec acc Type {kind = NON_NULL, ofType = Just ofType} = fieldTypeRec (NonNullType : acc) ofType-    fieldTypeRec acc Type {name = Just name} = pure (acc, name)-    fieldTypeRec _ x = internalError $ "Unsuported Field" <> pack (show x)+ where+  toHs (w, t) = (toHSWrappers w, t)+  fieldTypeRec+    :: [DataTypeWrapper] -> Type -> Validation ([DataTypeWrapper], Text)+  fieldTypeRec acc Type { kind = LIST, ofType = Just ofType } =+    fieldTypeRec (ListType : acc) ofType+  fieldTypeRec acc Type { kind = NON_NULL, ofType = Just ofType } =+    fieldTypeRec (NonNullType : acc) ofType+  fieldTypeRec acc Type { name = Just name } = pure (acc, name)+  fieldTypeRec _ x = internalError $ "Unsuported Field" <> pack (show x)

@@ -2,17 +2,35 @@  module Data.Morpheus.Parsing.Request.Arguments   ( maybeArguments-  ) where+  )+where -import           Text.Megaparsec                               (label, (<|>))+import           Text.Megaparsec                ( label+                                                , (<|>)+                                                )  -- MORPHEUS-import           Data.Morpheus.Parsing.Internal.Internal       (Parser, getLocation)-import           Data.Morpheus.Parsing.Internal.Terms          (parseAssignment, parseMaybeTuple, token, variable)-import           Data.Morpheus.Parsing.Internal.Value          (enumValue, parseValue)-import           Data.Morpheus.Types.Internal.AST.RawSelection (Argument (..), RawArgument (..), RawArguments)-import           Data.Morpheus.Types.Internal.AST.Selection    (ArgumentOrigin (..))-import           Data.Morpheus.Types.Internal.Base             (Reference (..))+import           Data.Morpheus.Parsing.Internal.Internal+                                                ( Parser+                                                , getLocation+                                                )+import           Data.Morpheus.Parsing.Internal.Terms+                                                ( parseAssignment+                                                , parseMaybeTuple+                                                , token+                                                , variable+                                                )+import           Data.Morpheus.Parsing.Internal.Value+                                                ( enumValue+                                                , parseValue+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( ValueOrigin(..)+                                                , Argument(..)+                                                , RawArgument(..)+                                                , RawArguments+                                                , Ref(..)+                                                )   -- Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Arguments@@ -24,19 +42,19 @@ --  Name : Value[Const] -- TODO: move variable to Value valueArgument :: Parser RawArgument-valueArgument =-  label "valueArgument" $ do-    argumentPosition <- getLocation-    argumentValue <- parseValue <|> enumValue-    pure $ RawArgument $ Argument {argumentValue, argumentOrigin = INLINE, argumentPosition}+valueArgument = label "valueArgument" $ do+  argumentPosition <- getLocation+  argumentValue    <- parseValue <|> enumValue+  pure $ RawArgument $ Argument { argumentValue+                                , argumentOrigin   = INLINE+                                , argumentPosition+                                }  variableArgument :: Parser RawArgument-variableArgument =-  label "variableArgument" $ do-    (referenceName, referencePosition) <- variable-    pure $ VariableReference $ Reference {referenceName, referencePosition}+variableArgument = label "variableArgument" $ do+  (refName, refPosition) <- variable+  pure $ VariableRef $ Ref { refName, refPosition }  maybeArguments :: Parser RawArguments maybeArguments = label "maybeArguments" $ parseMaybeTuple argument-  where-    argument = parseAssignment token (valueArgument <|> variableArgument)+  where argument = parseAssignment token (valueArgument <|> variableArgument)

@@ -2,24 +2,47 @@ {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Parsing.Request.Operation-  (parseOperation-  ) where+  ( parseOperation+  )+where -import           Data.Functor                               (($>))-import           Data.Text                                  (Text)-import           Text.Megaparsec                            (label, optional, (<?>), (<|>))-import           Text.Megaparsec.Char                       (string)+import           Data.Functor                   ( ($>) )+import           Data.Text                      ( Text )+import           Text.Megaparsec                ( label+                                                , optional+                                                , (<?>)+                                                , (<|>)+                                                )+import           Text.Megaparsec.Char           ( string )  -- -- MORPHEUS-import           Data.Morpheus.Parsing.Internal.Internal    (Parser, getLocation)-import           Data.Morpheus.Parsing.Internal.Pattern     (optionalDirectives)-import           Data.Morpheus.Parsing.Internal.Terms       (operator, parseMaybeTuple, parseName, parseType,-                                                             spaceAndComments1, variable)-import           Data.Morpheus.Parsing.Internal.Value       (parseDefaultValue)-import           Data.Morpheus.Parsing.Request.Selection    (parseSelectionSet)-import           Data.Morpheus.Types.Internal.AST.Operation (DefaultValue, Operation (..), RawOperation, Variable (..))-import           Data.Morpheus.Types.Internal.Data          (OperationType (..), isNullable)+import           Data.Morpheus.Parsing.Internal.Internal+                                                ( Parser+                                                , getLocation+                                                )+import           Data.Morpheus.Parsing.Internal.Pattern+                                                ( optionalDirectives )+import           Data.Morpheus.Parsing.Internal.Terms+                                                ( operator+                                                , parseMaybeTuple+                                                , parseName+                                                , parseType+                                                , spaceAndComments1+                                                , variable+                                                )+import           Data.Morpheus.Parsing.Internal.Value+                                                ( parseDefaultValue )+import           Data.Morpheus.Parsing.Request.Selection+                                                ( parseSelectionSet )+import           Data.Morpheus.Types.Internal.AST+                                                ( DefaultValue+                                                , Operation(..)+                                                , RawOperation+                                                , Variable(..)+                                                , OperationType(..)+                                                , isNullable+                                                )   -- Variables :  https://graphql.github.io/graphql-spec/June2018/#VariableDefinition@@ -28,21 +51,20 @@ --    Variable : Type DefaultValue(opt) -- variableDefinition :: Parser (Text, Variable DefaultValue)-variableDefinition =-  label "VariableDefinition" $ do-    (name, variablePosition) <- variable-    operator ':'-    (variableTypeWrappers, variableType) <- parseType-    defaultValue <- parseDefaultValue-    pure-      ( name-      , Variable-          { variableType-          , isVariableRequired = not (isNullable variableTypeWrappers)-          , variableTypeWrappers-          , variablePosition-          , variableValue = defaultValue-          })+variableDefinition = label "VariableDefinition" $ do+  (name, variablePosition) <- variable+  operator ':'+  (variableTypeWrappers, variableType) <- parseType+  defaultValue                         <- parseDefaultValue+  pure+    ( name+    , Variable { variableType+               , isVariableRequired   = not (isNullable variableTypeWrappers)+               , variableTypeWrappers+               , variablePosition+               , variableValue        = defaultValue+               }+    )  -- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations --@@ -52,38 +74,45 @@ --   OperationType: one of --     query, mutation,    subscription parseOperationDefinition :: Parser RawOperation-parseOperationDefinition =-  label "OperationDefinition" $ do-    operationPosition <- getLocation-    operationType <- parseOperationType-    operationName <- optional parseName-    operationArgs <- parseMaybeTuple variableDefinition-    -- TODO: handle directives-    _directives <- optionalDirectives-    operationSelection <- parseSelectionSet-    pure (Operation {operationName, operationType, operationArgs, operationSelection, operationPosition})+parseOperationDefinition = label "OperationDefinition" $ do+  operationPosition  <- getLocation+  operationType      <- parseOperationType+  operationName      <- optional parseName+  operationArgs      <- parseMaybeTuple variableDefinition+  -- TODO: handle directives+  _directives        <- optionalDirectives+  operationSelection <- parseSelectionSet+  pure+    (Operation { operationName+               , operationType+               , operationArgs+               , operationSelection+               , operationPosition+               }+    )  parseOperationType :: Parser OperationType-parseOperationType =-  label "OperationType" $ do-    kind <- (string "query" $> Query) <|> (string "mutation" $> Mutation) <|> (string "subscription" $> Subscription)-    spaceAndComments1-    return kind+parseOperationType = label "OperationType" $ do+  kind <-+    (string "query" $> Query)+    <|> (string "mutation" $> Mutation)+    <|> (string "subscription" $> Subscription)+  spaceAndComments1+  return kind  parseAnonymousQuery :: Parser RawOperation-parseAnonymousQuery =-  label "AnonymousQuery" $ do-    operationPosition <- getLocation-    operationSelection <- parseSelectionSet-    pure-      (Operation-         { operationName = Nothing-         , operationType = Query-         , operationArgs = []-         , operationSelection-         , operationPosition-         }) <?>-      "can't parse AnonymousQuery"+parseAnonymousQuery = label "AnonymousQuery" $ do+  operationPosition  <- getLocation+  operationSelection <- parseSelectionSet+  pure+      (Operation { operationName      = Nothing+                 , operationType      = Query+                 , operationArgs      = []+                 , operationSelection+                 , operationPosition+                 }+      )+    <?> "can't parse AnonymousQuery"  parseOperation :: Parser RawOperation parseOperation = parseAnonymousQuery <|> parseOperationDefinition

@@ -3,44 +3,61 @@  module Data.Morpheus.Parsing.Request.Parser   ( parseGQL-  ) where+  )+where -import qualified Data.Aeson                              as Aeson (Value (..))-import           Data.HashMap.Lazy                       (toList)-import           Data.Text                               (Text)-import           Data.Void                               (Void)-import           Text.Megaparsec                         (ParseErrorBundle, eof, label, manyTill, runParser)+import qualified Data.Aeson                    as Aeson+                                                ( Value(..) )+import           Data.HashMap.Lazy              ( toList )+import           Data.Text                      ( Text )+import           Data.Void                      ( Void )+import           Text.Megaparsec                ( ParseErrorBundle+                                                , eof+                                                , label+                                                , manyTill+                                                , runParser+                                                )  -- -- MORPHEUS-import           Data.Morpheus.Parsing.Internal.Internal (Parser, processErrorBundle)-import           Data.Morpheus.Parsing.Internal.Terms    (spaceAndComments)-import           Data.Morpheus.Parsing.Request.Operation (parseOperation)-import           Data.Morpheus.Parsing.Request.Selection (parseFragmentDefinition)-import           Data.Morpheus.Types.Internal.Validation (Validation)-import           Data.Morpheus.Types.Internal.Value      (Value (..), replaceValue)-import           Data.Morpheus.Types.IO                  (GQLRequest (..))-import           Data.Morpheus.Types.Types               (GQLQueryRoot (..))+import           Data.Morpheus.Parsing.Internal.Internal+                                                ( Parser+                                                , processErrorBundle+                                                )+import           Data.Morpheus.Parsing.Internal.Terms+                                                ( spaceAndComments )+import           Data.Morpheus.Parsing.Request.Operation+                                                ( parseOperation )+import           Data.Morpheus.Parsing.Request.Selection+                                                ( parseFragmentDefinition )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Validation+                                                , Failure(..)+                                                )+import           Data.Morpheus.Types.Internal.AST+                                                ( Value(..)+                                                , replaceValue+                                                , GQLQuery(..)+                                                )+import           Data.Morpheus.Types.IO         ( GQLRequest(..) ) -parseGQLSyntax :: Text -> Either (ParseErrorBundle Text Void) GQLQueryRoot++parseGQLSyntax :: Text -> Either (ParseErrorBundle Text Void) GQLQuery parseGQLSyntax = runParser request "<input>"-  where-    request :: Parser GQLQueryRoot-    request =-      label "GQLQueryRoot" $ do-        spaceAndComments-        operation <- parseOperation-        fragments <- manyTill parseFragmentDefinition eof-        pure GQLQueryRoot {operation, fragments, inputVariables = []}+ where+  request :: Parser GQLQuery+  request = label "GQLQuery" $ do+    spaceAndComments+    operation <- parseOperation+    fragments <- manyTill parseFragmentDefinition eof+    pure GQLQuery { operation, fragments, inputVariables = [] } -parseGQL :: GQLRequest -> Validation GQLQueryRoot-parseGQL GQLRequest {query, variables} =-  case parseGQLSyntax query of-    Right root      -> Right $ root {inputVariables = toVariableMap variables}-    Left parseError -> Left $ processErrorBundle parseError-  where-    toVariableMap :: Maybe Aeson.Value -> [(Text, Value)]-    toVariableMap (Just (Aeson.Object x)) = map toMorpheusValue (toList x)-      where-        toMorpheusValue (key, value) = (key, replaceValue value)-    toVariableMap _ = []+parseGQL :: GQLRequest -> Validation GQLQuery+parseGQL GQLRequest { query, variables } = case parseGQLSyntax query of+  Right root       -> pure $ root { inputVariables = toVariableMap variables }+  Left  parseError -> failure $ processErrorBundle parseError+ where+  toVariableMap :: Maybe Aeson.Value -> [(Text, Value)]+  toVariableMap (Just (Aeson.Object x)) = map toMorpheusValue (toList x)+    where toMorpheusValue (key, value) = (key, replaceValue value)+  toVariableMap _ = []

@@ -4,21 +4,42 @@ module Data.Morpheus.Parsing.Request.Selection   ( parseSelectionSet   , parseFragmentDefinition-  ) where+  )+where -import           Data.Text                                     (Text)-import           Text.Megaparsec                               (label, try, (<|>))+import           Data.Text                      ( Text )+import           Text.Megaparsec                ( label+                                                , try+                                                , (<|>)+                                                )  -- -- MORPHEUS-import           Data.Morpheus.Parsing.Internal.Internal       (Parser, getLocation)-import           Data.Morpheus.Parsing.Internal.Pattern        (optionalDirectives)-import           Data.Morpheus.Parsing.Internal.Terms          (keyword, parseAlias, parseName, parseTypeCondition,-                                                                setOf, spreadLiteral, token)-import           Data.Morpheus.Parsing.Request.Arguments       (maybeArguments)-import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), RawArguments, RawSelection (..),-                                                                RawSelectionSet, Reference (..))-import           Data.Morpheus.Types.Internal.AST.Selection    (Selection (..))+import           Data.Morpheus.Parsing.Internal.Internal+                                                ( Parser+                                                , getLocation+                                                )+import           Data.Morpheus.Parsing.Internal.Pattern+                                                ( optionalDirectives )+import           Data.Morpheus.Parsing.Internal.Terms+                                                ( keyword+                                                , parseAlias+                                                , parseName+                                                , parseTypeCondition+                                                , setOf+                                                , spreadLiteral+                                                , token+                                                )+import           Data.Morpheus.Parsing.Request.Arguments+                                                ( maybeArguments )+import           Data.Morpheus.Types.Internal.AST+                                                ( Selection(..)+                                                , Fragment(..)+                                                , RawArguments+                                                , RawSelection(..)+                                                , RawSelectionSet+                                                , Ref(..)+                                                )   -- Selection Sets : https://graphql.github.io/graphql-spec/June2018/#sec-Selection-Sets@@ -33,11 +54,12 @@ -- parseSelectionSet :: Parser RawSelectionSet parseSelectionSet = label "SelectionSet" $ setOf parseSelection-  where-    parseSelection = label "Selection" $-            try inlineFragment-        <|> try spread-        <|> parseSelectionField+ where+  parseSelection =+    label "Selection"+      $   try inlineFragment+      <|> try spread+      <|> parseSelectionField  -- Fields: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fields --@@ -45,27 +67,37 @@ -- Alias(opt) Name Arguments(opt) Directives(opt) SelectionSet(opt) -- parseSelectionField :: Parser (Text, RawSelection)-parseSelectionField =-  label "SelectionField" $ do-    position <- getLocation-    aliasName  <- parseAlias-    name <- parseName-    arguments <- maybeArguments-    -- TODO: handle Directives-    _directives <- optionalDirectives-    value <- selSet aliasName arguments <|> buildField aliasName arguments position-    return (name, value)-  where+parseSelectionField = label "SelectionField" $ do+  position    <- getLocation+  aliasName   <- parseAlias+  name        <- parseName+  arguments   <- maybeArguments+  -- TODO: handle Directives+  _directives <- optionalDirectives+  value       <-+    selSet aliasName arguments <|> buildField aliasName arguments position+  return (name, value)+ where     -----------------------------------------    buildField selectionAlias selectionArguments selectionPosition =-       pure (RawSelectionField $ Selection { selectionAlias , selectionArguments,  selectionRec = (), selectionPosition})-    ------------------------------------------    selSet :: Maybe Text -> RawArguments -> Parser RawSelection-    selSet selectionAlias selectionArguments =-      label "body" $ do-        selectionPosition <- getLocation-        selectionRec <- parseSelectionSet-        return (RawSelectionSet $ Selection {selectionAlias , selectionArguments, selectionRec, selectionPosition})+  buildField selectionAlias selectionArguments selectionPosition = pure+    (RawSelectionField $ Selection { selectionAlias+                                   , selectionArguments+                                   , selectionRec       = ()+                                   , selectionPosition+                                   }+    )+  -----------------------------------------+  selSet :: Maybe Text -> RawArguments -> Parser RawSelection+  selSet selectionAlias selectionArguments = label "body" $ do+    selectionPosition <- getLocation+    selectionRec      <- parseSelectionSet+    return+      (RawSelectionSet $ Selection { selectionAlias+                                   , selectionArguments+                                   , selectionRec+                                   , selectionPosition+                                   }+      )   --@@ -78,13 +110,12 @@ --    ...FragmentName Directives(opt) -- spread :: Parser (Text, RawSelection)-spread =-  label "FragmentSpread" $ do-    referencePosition <- spreadLiteral-    referenceName <- token-    -- TODO: handle Directives-    _directives <- optionalDirectives-    return (referenceName, Spread $ Reference {referenceName, referencePosition})+spread = label "FragmentSpread" $ do+  refPosition <- spreadLiteral+  refName     <- token+  -- TODO: handle Directives+  _directives <- optionalDirectives+  return (refName, Spread $ Ref { refName, refPosition })  -- FragmentDefinition : https://graphql.github.io/graphql-spec/June2018/#FragmentDefinition --@@ -92,16 +123,15 @@ --   fragment FragmentName TypeCondition Directives(opt) SelectionSet -- parseFragmentDefinition :: Parser (Text, Fragment)-parseFragmentDefinition =-  label "FragmentDefinition" $ do-    keyword "fragment"-    fragmentPosition <- getLocation-    name <- parseName-    fragmentType <- parseTypeCondition-    -- TODO: handle Directives-    _directives <- optionalDirectives-    fragmentSelection <- parseSelectionSet-    pure (name, Fragment {fragmentType, fragmentSelection, fragmentPosition})+parseFragmentDefinition = label "FragmentDefinition" $ do+  keyword "fragment"+  fragmentPosition  <- getLocation+  name              <- parseName+  fragmentType      <- parseTypeCondition+  -- TODO: handle Directives+  _directives       <- optionalDirectives+  fragmentSelection <- parseSelectionSet+  pure (name, Fragment { fragmentType, fragmentSelection, fragmentPosition })  -- Inline Fragments : https://graphql.github.io/graphql-spec/June2018/#sec-Inline-Fragments --@@ -109,12 +139,15 @@ --  ... TypeCondition(opt) Directives(opt) SelectionSet -- inlineFragment :: Parser (Text, RawSelection)-inlineFragment =-  label "InlineFragment" $ do-    fragmentPosition <- spreadLiteral-    -- TODO: optional-    fragmentType <- parseTypeCondition-    -- TODO: handle Directives-    _directives <- optionalDirectives-    fragmentSelection <- parseSelectionSet-    pure ("INLINE_FRAGMENT", InlineFragment $ Fragment {fragmentType, fragmentSelection, fragmentPosition})+inlineFragment = label "InlineFragment" $ do+  fragmentPosition  <- spreadLiteral+  -- TODO: optional+  fragmentType      <- parseTypeCondition+  -- TODO: handle Directives+  _directives       <- optionalDirectives+  fragmentSelection <- parseSelectionSet+  pure+    ( "INLINE_FRAGMENT"+    , InlineFragment+      $ Fragment { fragmentType, fragmentSelection, fragmentPosition }+    )

@@ -1,87 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Rendering.Haskell.Render-  ( renderHaskellDocument-  ) where--import           Data.ByteString.Lazy.Char8             (ByteString)-import           Data.Semigroup                         ((<>))-import           Data.Text                              (Text, intercalate, pack)-import qualified Data.Text                              as T (concat)-import qualified Data.Text.Lazy                         as LT (fromStrict)-import           Data.Text.Lazy.Encoding                (encodeUtf8)---- MORPHEUS-import           Data.Morpheus.Rendering.Haskell.Terms  (Context (..), renderExtension)-import           Data.Morpheus.Rendering.Haskell.Types  (renderType)-import           Data.Morpheus.Rendering.Haskell.Values (Scope (..), renderResolver, renderRootResolver)-import           Data.Morpheus.Types.Internal.Data      (DataTypeLib (..), allDataTypes)--renderHaskellDocument :: String -> DataTypeLib -> ByteString-renderHaskellDocument modName lib =-  encodeText $-  renderLanguageExtensions context <> renderExports context <>-  renderImports context <>-  onSub renderApiEvents "" <>-  renderRootResolver context lib <>-  types-  where-    encodeText = encodeUtf8 . LT.fromStrict-    onSub onS els =-      case subscription lib of-        Nothing -> els-        _       -> onS-    renderApiEvents =-      "data Channel = Channel -- ChannelA | ChannelB" <> "\n\n" <>-      "data Content = Content -- ContentA Int | ContentB String" <>-      "\n\n"-    types = intercalate "\n\n" $ map renderFullType (allDataTypes lib)-      where-        renderFullType x = renderType cont x <> "\n\n" <> renderResolver cont x-          where-            cont = context {scope = getScope $ fst x}-            getScope "Mutation"     = Mutation-            getScope "Subscription" = Subscription-            getScope _              = Query-    context =-      Context-        { moduleName = pack modName-        , imports =-            [ ("GHC.Generics", ["Generic"])-            , ( "Data.Morpheus.Kind"-              , ["SCALAR", "ENUM", "INPUT_OBJECT", "OBJECT", "UNION"])-            , ( "Data.Morpheus.Types"-              , [ "GQLRootResolver(..)"-                , "toMutResolver"-                , "IORes"-                , "IOMutRes"-                , "IOSubRes"-                , "Event(..)"-                , "SubRootRes"-                , "GQLType(..)"-                , "GQLScalar(..)"-                , "ScalarValue(..)"-                ])-            , ("Data.Text", ["Text"])-            ]-        , extensions = ["OverloadedStrings", "DeriveGeneric", "TypeFamilies"]-        , scope = Query-        , pubSub = onSub ("Channel", "Content") ("()", "()")-        }--renderLanguageExtensions :: Context -> Text-renderLanguageExtensions Context {extensions} =-  T.concat (map renderExtension extensions) <> "\n"--renderExports :: Context -> Text-renderExports Context {moduleName} =-  "-- generated by 'Morpheus' CLI\n" <> "module " <> moduleName <>-  " (rootResolver) where\n\n"--renderImports :: Context -> Text-renderImports Context {imports} = T.concat (map renderImport imports) <> "\n"-  where-    renderImport (src, list) =-      "import  " <> src <> "  (" <> intercalate ", " list <> ")\n"

@@ -1,85 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Rendering.Haskell.Terms-  ( indent-  , renderReturn-  , renderData-  , renderCon-  , renderMaybe-  , renderList-  , renderTuple-  , renderAssignment-  , renderExtension-  , renderWrapped-  , renderSet-  , renderUnionCon-  , renderEqual-  , Scope(..)-  , Context(..)-  ) where--import           Data.Semigroup                    ((<>))-import           Data.Text                         (Text, intercalate, toUpper)---- MORPHEUS-import           Data.Morpheus.Types.Internal.Data (WrapperD (..))--indent :: Text-indent = "  "--renderEqual :: Text -> Text -> Text-renderEqual key value = key <> " = " <> value--renderReturn :: Text-renderReturn = "return "--renderData :: Text -> Text-renderData name = "data " <> name <> " = "--renderCon :: Text -> Text-renderCon name = name <> " "--renderMaybe :: Text -> Text-renderMaybe typeName = "Maybe " <> typeName--renderList :: Text -> Text-renderList typeName = "[" <> typeName <> "]"--renderTuple :: Text -> Text-renderTuple typeName = "(" <> typeName <> ")"--renderSet :: [Text] -> Text-renderSet fields = bracket "{ " <> intercalate ("\n  ," <> indent) fields <> bracket "}\n"-  where-    bracket x = "\n    " <> x--renderAssignment :: Text -> Text -> Text-renderAssignment key value = key <> " :: " <> value--renderExtension :: Text -> Text-renderExtension name = "{-# LANGUAGE " <> name <> " #-}\n"--renderWrapped :: [WrapperD] -> Text -> Text-renderWrapped (ListD:xs)  = renderList . renderWrapped xs-renderWrapped (MaybeD:xs) = renderMaybe . renderWrapped xs-renderWrapped []          = strToText--strToText :: Text -> Text-strToText "String" = "Text"-strToText x        = x--renderUnionCon :: Text -> Text -> Text-renderUnionCon typeName conName = renderCon (typeName <> "_" <> toUpper conName)--data Scope-  = Mutation-  | Subscription-  | Query--data Context = Context-  { moduleName :: Text-  , imports    :: [(Text, [Text])]-  , extensions :: [Text]-  , scope      :: Scope-  , pubSub     :: (Text, Text)-  }