packages feed

morpheus-graphql 0.2.2 → 0.3.0

raw patch · 88 files changed

+3003/−2804 lines, 88 files

Files

README.md view
@@ -1,4 +1,4 @@-# Morpheus GraphQL [![Hackage](https://img.shields.io/hackage/v/morpheus-graphql.svg)](https://hackage.haskell.org/package/morpheus-graphql) [![Build Status](https://api.travis-ci.com/morpheusgraphql/morpheus-graphql.svg?branch=master)](https://travis-ci.com/morpheusgraphql/morpheus-graphql)+# Morpheus GraphQL [![Hackage](https://img.shields.io/hackage/v/morpheus-graphql.svg)](https://hackage.haskell.org/package/morpheus-graphql) [![CircleCI](https://circleci.com/gh/morpheusgraphql/morpheus-graphql.svg?style=svg)](https://circleci.com/gh/morpheusgraphql/morpheus-graphql)  Build GraphQL APIs with your favourite functional language! @@ -14,7 +14,7 @@  To get started with Morpheus, you first need to add it to your project's dependencies, as follows (assuming you're using hpack): -package.yml+_package.yml_  ```yaml dependencies:@@ -23,53 +23,77 @@  Additionally, you should tell stack which version to pick: -stack.yml+_stack.yml_  ```yaml-resolver: lts-12.0 # or greater+resolver: lts-13.24+ extra-deps:   - megaparsec-7.0.5   - aeson-1.4.4.0   - time-compat-1.9.2.2-  - morpheus-graphql-0.2.2 ```  As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack update`  ### Building your first GrqphQL API -### with GraphQL syntax and Haskell QuasiQuotes+### with GraphQL syntax +_schema.gql_++```gql+type Query {+  deity(name: String!): Deity!+}++type Deity {+  name: String!+  power: String+}+```++_API.hs_+ ```haskell+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-} -[gqlDocument|-  type Query {-    deity (uid: Text!): Deity!-  }+module API (api) where -  type Deity {-    name  : Text!-    power : Text-  }-|]+import qualified Data.ByteString.Lazy.Char8 as B -rootResolver :: GQLRootResolver IO () () Query () ()+import           Data.Morpheus              (interpreter)+import           Data.Morpheus.Document     (importGQLDocumentWithNamespace)+import           Data.Morpheus.Types        (GQLRootResolver (..), IORes)+import           Data.Text                  (Text)++importGQLDocumentWithNamespace "schema.gql"++rootResolver :: GQLRootResolver IO () () (Query IORes) () () rootResolver =-  GQLRootResolver {queryResolver = return Query {deity}, mutationResolver = pure (), subscriptionResolver = pure ()}+  GQLRootResolver+    {queryResolver = return Query {queryDeity}, mutationResolver = pure (), subscriptionResolver = pure ()}   where-    deity DeityArgs {uid} = pure Deity {name, power}+    queryDeity QueryDeityArgs {queryDeityArgsName} = pure Deity {deityName, deityPower}       where-        name _ = pure "Morpheus"-        power _ = pure (Just "Shapeshifting")+        deityName _ = pure "Morpheus"+        deityPower _ = pure (Just "Shapeshifting") -gqlApi :: ByteString -> IO ByteString-gqlApi = interpreter rootResolver+api :: ByteString -> IO ByteString+api = interpreter rootResolver ```  Template Haskell Generates types: `Query` , `Deity`, `DeityArgs`, that can be used by `rootResolver` -generated types are not compatible with `Mutation`, `Subscription`,-they can be used only in `Query`, but this issue will be fixed in next release+`importGQLDocumentWithNamespace` will generate Types with namespaced fields. if you don't need napespacing use `importGQLDocument`  ### with Native Haskell Types @@ -79,7 +103,7 @@ ```haskell data Query = Query   { deity :: DeityArgs -> IORes Deity-  } deriving (Generic)+  } deriving (Generic, GQLType)  data Deity = Deity   { fullName :: Text         -- Non-Nullable Field@@ -260,7 +284,7 @@ ```haskell newtype Mutation = Mutation   { createDeity :: Form -> IOMutRes Deity-  } deriving (Generic)+  } deriving (Generic, GQLType)  createDeityMutation :: Form -> IOMutRes Deity createDeityMutation = ...@@ -298,15 +322,15 @@  newtype Query = Query   { deity :: () -> IORes Deity-  } deriving (Generic)+  } deriving (Generic, GQLType)  newtype Mutation = Mutation   { createDeity :: () -> IOMutRes Channel Content Deity-  } deriving (Generic)+  } deriving (Generic, GQLType)  newtype Subscription = Subscription   { newDeity :: () -> IOSubRes Channel Content Deity-  } deriving (Generic)+  } deriving (Generic, GQLType)  rootResolver :: GQLRootResolver IO Channel Content Query Mutation Subscription rootResolver =@@ -318,11 +342,11 @@   where     fetchDeity = resolver $ dbDeity "" Nothing     createDeity _args = toMutResolver [Event {channels = [ChannelA], content = ContentA 1}] fetchDeity-    newDeity _args = Event {channels = [ChannelA], content}+    newDeity _args = SubResolver {subChannels = [ChannelA], subResolver}       where-        content (Event [ChannelA] (ContentA _value)) = resolver $ dbDeity "" Nothing -- resolve New State-        content (Event [ChannelA] (ContentB value))  = resolver $ dbDeity value Nothing -- resolve New State-        content _                                    = fetchDeity -- Resolve Old State+        subResolver (Event [ChannelA] (ContentA _value)) = resolver $ dbDeity "" Nothing -- resolve New State+        subResolver (Event [ChannelA] (ContentB value))  = resolver $ dbDeity value Nothing -- resolve New State+        subResolver _                                    = fetchDeity -- Resolve Old State ```  ## Morpheus `GraphQL Client` with Template haskell QuasiQuotes@@ -397,7 +421,6 @@  - Medium future:   - Stabilize API-  - Specification-isomorphic introspection   - Specification-isomorphic error handling - Long term:   - Support all possible GQL features
changelog.md view
@@ -1,33 +1,117 @@+## [0.3.0] - 04.10.2019++### Added++- user can import GraphQL Document and generate types with it.++  ```haskell+    importGQLDocument "API.gql"+  ```++  this will generate types defined in `API.gql`++### Fixed++- `String` defined in GQLDcoument will be converted to `Text` by template haskell++- `importGQLDocument` and `gqlDocument` supports Mutation, Subscription and Resolvers with custom Monad++  for example. if we have:++  ```gql+  type Deity {+    name: String!+    power: Power!+  }+  ```++  where `Power` is another object defined by gql schema.+  template haskell will represent this type as:++  ```haskell+     data Deity m = Deity {+       name :: () -> m String+       power :: () -> m (Power m)+     }+  ```++  where `m` is resolver Monad.++- `importGQLDocumentWithNamespace` generates namespaced haskell records. so that you have no more problem with name collision.+  from this gql type:++  ```gql+  type Deity {+    name: (id:Int)String!+    power: Power!+  }+  ```++  will be generated.++  ```haskell+  $(importGQLDocumentWithNamespace "examples/Sophisticated/api.gql")++  data Deity m = Deity {+    DeityName :: DeityNameArgs -> m String+    DeityPower :: () -> m (Power m)+  }++  data DeityNameArgs = DeityNameArgs {+    deityNameId :: Int+  }+  ```++### Changed++- `GQLType` is mandatory for every GQL Type (including Query, Mutation and Subscription)+- subscription Resolver changed++  from:++  ```haskell+    Subscription {newDeity = \args -> Event {channels = [ChannelA], content = newDeityResolver } }+  ```++  to:++  ```haskell+    Subscription {newDeity = \args -> SubResolver {subChannels = [ChannelA], subResolver = newDeityResolver } }+  ```+ ## [0.2.2] - 30.08.2019  ### Fixed+ - Parser Supports GraphQL multiline comments - Morpheus GraphQL Client: Support GraphQL Alias - Support of GraphQL Interfaces on GraphQL Document:-    ```gql-    # simple.gql-    interface Node {-      nodeId: ID!-    } -    type SimpleType implements Node {-      nodeId: ID!-      name: String!-    }-    ```+  ```gql+  # simple.gql+  interface Node {+    nodeId: ID!+  } -    morpheus compiler will read interfaces and validate implements.-    template haskell will generate haskell types only for types not for interfaces.+  type SimpleType implements Node {+    nodeId: ID!+    name: String!+  }+  ``` -    haskell type from `simple.gql`:-    ```haskell-     data SimpleType = SimpleType {-        nodeId :: ID!-        name   :: Text!-      }  deriving (Generic)-    ```+  morpheus compiler will read interfaces and validate implements.+  template haskell will generate haskell types only for types not for interfaces. -    at the time compiler does not validates field Arguments by interface+  haskell type from `simple.gql`:++  ```haskell+   data SimpleType = SimpleType {+      nodeId :: ID!+      name   :: Text!+    }  deriving (Generic)+  ```++  at the time compiler does not validates field Arguments by interface  ## [0.2.1] - 23.08.2019
+ examples/Client/Client.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}++module Client.Client+  ( fetchHero+  , fetUser+  ) where++import           Data.ByteString.Lazy.Char8 (ByteString)+import           Data.Morpheus.Client       (Fetch (..), defineByDocumentFile, defineByIntrospectionFile, gql)+import           Data.Morpheus.Types        (ScalarValue (..))++defineByIntrospectionFile+  "./assets/introspection.json"+  [gql|+    # Query Hero with Compile time Validation+    query GetUser ($userCoordinates: Coordinates!)+      {+        myUser: user {+           boo3: name+           email+           address (coordinates: $userCoordinates ){+            city+           }+        }+      }+  |]++defineByDocumentFile+  "./assets/simple.gql"+  [gql|+    # Query Hero with Compile time Validation+    query GetHero ($god: Realm, $charID: String!)+      {+        deity (mythology:$god) {+          power+          fullName+        }+        character(characterID: $charID ) {+          ...on Creature {+            creatureName+          }+          ...on Human {+            lifetime+            profession+          }+        }+      }+  |]++ioRes :: ByteString -> IO ByteString+ioRes req = do+  print req+  return+    "{\"data\":{\"deity\":{ \"fullName\": \"name\" }, \"character\":{ \"__typename\":\"Human\", \"lifetime\": \"Lifetime\", \"profession\": \"Artist\" }  }}"++fetchHero :: IO (Either String GetHero)+fetchHero = fetch ioRes GetHeroArgs {god = Just Realm {owner = "Zeus", surface = Just 10}, charID = "Hercules"}++fetUser :: (ByteString -> IO ByteString) -> IO (Either String GetUser)+fetUser api = fetch api userArgs+  where+    userArgs :: Args GetUser+    userArgs = GetUserArgs {userCoordinates = Coordinates {longitude = [], latitude = String "1"}}
− examples/Deprecated/API.hs 
@@ -1,241 +0,0 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds         #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE TypeInType        #-}-{-# LANGUAGE TypeOperators     #-}--module Deprecated.API-  ( gqlRoot-  , Channel-  , Content-  ) where--import           Data.Map            (Map)-import qualified Data.Map            as M (fromList)-import           Data.Set            (Set)-import qualified Data.Set            as S (fromList)-import           Data.Text           (Text, pack)-import           Data.Typeable       (Typeable)-import           GHC.Generics        (Generic)---- MORPHEUS-import           Data.Morpheus.Kind  (ENUM, INPUT_OBJECT, INPUT_UNION, OBJECT, SCALAR, UNION)-import           Data.Morpheus.Types (Event (..), GQLRootResolver (..), GQLScalar (..), GQLType (..), ID, IOMutRes,-                                      IORes, IOSubRes, Resolver, ScalarValue (..), mutResolver, resolver)--newtype Cat = Cat-  { catName :: Text-  } deriving (Show, Generic)--instance GQLType Cat where-  type KIND Cat = INPUT_OBJECT--newtype Dog = Dog-  { dogName :: Text-  } deriving (Show, Generic)--instance GQLType Dog where-  type KIND Dog = INPUT_OBJECT--newtype Bird = Bird-  { birdName :: Text-  } deriving (Show, Generic)--instance GQLType Bird where-  type KIND Bird = INPUT_OBJECT--data Animal-  = CAT Cat-  | DOG Dog-  | BIRD Bird-  deriving (Show, Generic)--instance GQLType Animal where-  type KIND Animal = INPUT_UNION--newtype UniqueID = UniqueID-  { uid :: Text-  } deriving (Show, Generic)--instance GQLType UniqueID where-  type KIND UniqueID = INPUT_OBJECT--data MyUnion res-  = USER (User res)-  | ADDRESS Address-  deriving (Generic)--instance Typeable a => GQLType (MyUnion a) where-  type KIND (MyUnion a) = UNION--data CityID-  = Paris-  | BLN-  | HH-  deriving (Generic)--instance GQLType CityID where-  type KIND CityID = ENUM--data Euro =-  Euro Int-       Int-  deriving (Generic)--instance GQLType Euro where-  type KIND Euro = SCALAR--instance GQLScalar Euro where-  parseValue _ = pure (Euro 1 0)-  serialize (Euro x y) = Int (x * 100 + y)--data Coordinates = Coordinates-  { latitude  :: Euro-  , longitude :: [Maybe [[UniqueID]]]-  } deriving (Generic)--instance GQLType Coordinates where-  type KIND Coordinates = INPUT_OBJECT-  description _ = "just random latitude and longitude"--data Address = Address-  { city        :: Text-  , street      :: Text-  , houseNumber :: Int-  } deriving (Generic)--instance GQLType Address where-  type KIND Address = OBJECT--data AddressArgs = AddressArgs-  { coordinates :: Coordinates-  , comment     :: Maybe Text-  } deriving (Generic)--data OfficeArgs = OfficeArgs-  { zipCode :: Maybe [[Maybe [ID]]]-  , cityID  :: CityID-  } deriving (Generic)--data User m = User-  { name    :: Text-  , email   :: Text-  , address :: AddressArgs -> m Address-  , office  :: OfficeArgs -> m Address-  , myUnion :: () -> m (MyUnion m)-  , home    :: CityID-  } deriving (Generic)--instance Typeable a => GQLType (User a) where-  type KIND (User a) = OBJECT-  description _ = "Custom Description for Client Defined User Type"--instance Typeable a => GQLType (A a) where-  type KIND (A a) = OBJECT--newtype A a = A-  { wrappedA :: a-  } deriving (Generic)--fetchAddress :: Monad m => Euro -> m (Either String Address)-fetchAddress _ = return $ Right $ Address " " "" 0--fetchUser :: Monad m => m (Either String (User (Resolver m)))-fetchUser =-  return $-  Right $-  User-    { name = "George"-    , email = "George@email.com"-    , address = const resolveAddress-    , office = resolveOffice-    , home = HH-    , myUnion = const $ return $ USER unionUser-    }-  where-    unionAddress = Address {city = "Hamburg", street = "Street", houseNumber = 20}-  -- Office-    resolveOffice OfficeArgs {cityID = Paris} = resolver $ fetchAddress (Euro 1 1)-    resolveOffice OfficeArgs {cityID = BLN}   = resolver $ fetchAddress (Euro 1 2)-    resolveOffice OfficeArgs {cityID = HH}    = resolver $ fetchAddress (Euro 1 3)-    resolveAddress = resolver $ fetchAddress (Euro 1 0)-    unionUser =-      User-        { name = "David"-        , email = "David@email.com"-        , address = const resolveAddress-        , office = resolveOffice-        , home = BLN-        , myUnion = const $ return $ ADDRESS unionAddress-        }--newtype AnimalArgs = AnimalArgs-  { animal :: Animal-  } deriving (Show, Generic)--setAnimalResolver :: AnimalArgs -> IORes Text-setAnimalResolver AnimalArgs {animal} = return $ pack $ show animal--data Query = Query-  { user       :: () -> IORes (User IORes)-  , wrappedA1  :: A (Int, Text)-  , setAnimal  :: AnimalArgs -> IORes Text-  , wrappedA2  :: A Text-  , integerSet :: Set Int-  , textIntMap :: Map Text Int-  } deriving (Generic)--data Channel-  = UPDATE_USER-  | UPDATE_ADDRESS-  deriving (Show, Eq, Ord)--data Content = Update-  { contentID      :: Int-  , contentMessage :: Text-  }--type MutRes = IOMutRes Channel Content--type SubRes a = IOSubRes Channel Content a--data Mutation = Mutation-  { createUser    :: () -> MutRes (User MutRes)-  , createAddress :: () -> MutRes Address-  } deriving (Generic)--data Subscription = Subscription-  { newAddress :: () -> SubRes Address-  , newUser    :: () -> SubRes (User IORes)-  } deriving (Generic)--gqlRoot :: GQLRootResolver IO Channel Content Query Mutation Subscription-gqlRoot =-  GQLRootResolver-    { queryResolver =-        return-          Query-            { user = const $ resolver fetchUser-            , wrappedA1 = A (0, "")-            , setAnimal = setAnimalResolver-            , wrappedA2 = A ""-            , integerSet = S.fromList [1, 2]-            , textIntMap = M.fromList [("robin", 1), ("carl", 2)]-            }-    , mutationResolver = return Mutation {createAddress, createUser}-    , subscriptionResolver = return Subscription {newAddress, newUser}-    }-  where-    newUser _ = Event [UPDATE_USER] $ \(Event _ Update {}) -> resolver fetchUser-    newAddress _ = Event [UPDATE_ADDRESS] $ \(Event _ Update {contentID}) -> resolver $ fetchAddress (Euro contentID 0)-    createUser _ =-      mutResolver [Event [UPDATE_USER] (Update {contentID = 12, contentMessage = "some message for user"})] fetchUser-    createAddress :: () -> MutRes Address-    createAddress _ =-      mutResolver-        [Event [UPDATE_ADDRESS] (Update {contentID = 10, contentMessage = "message for address"})]-        (fetchAddress (Euro 1 0))
− examples/Deprecated/Model.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators         #-}--module Deprecated.Model-  ( jsonAddress-  , jsonUser-  , JSONUser(..)-  , JSONAddress(..)-  ) where--import           Data.Aeson   (FromJSON)-import           Data.Text    (Text)-import           Files        (getJson)-import           GHC.Generics (Generic)--data JSONUser = JSONUser-  { name  :: Text-  , email :: Text-  } deriving (Show, Generic, FromJSON)--data JSONAddress = JSONAddress-  { city        :: Text-  , street      :: Text-  , houseNumber :: Int-  } deriving (Generic, Show, FromJSON)--jsonUser :: IO (Either String JSONUser)-jsonUser = getJson "deprecated/user"--jsonAddress :: IO (Either String JSONAddress)-jsonAddress = getJson "deprecated/address"
examples/Main.hs view
@@ -1,93 +1,34 @@-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE DerivingStrategies    #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE QuasiQuotes           #-}-{-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE TypeFamilies          #-}  module Main   ( main   ) where +import           Client.Client                  (fetUser, fetchHero) import           Control.Monad.IO.Class         (liftIO)-import           Data.ByteString.Lazy           (ByteString) import           Data.Functor.Identity          (Identity (..)) import           Data.Morpheus                  (Interpreter (..))-import           Data.Morpheus.Client           (Fetch (..), defineByDocumentFile, defineByIntrospectionFile, gql) import           Data.Morpheus.Document         (toGraphQLDocument) import           Data.Morpheus.Server           (GQLState, gqlSocketApp, initGQLState)-import           Data.Morpheus.Types            (ScalarValue (..))-import           Deprecated.API                 (Channel, Content, gqlRoot) import           Mythology.API                  (mythologyApi) import qualified Network.Wai                    as Wai import qualified Network.Wai.Handler.Warp       as Warp import qualified Network.Wai.Handler.WebSockets as WaiWs import           Network.WebSockets             (defaultConnectionOptions)-import           TH.API                         (thApi)+import           Sophisticated.API              (Channel, Content, gqlRoot)+import           TH.Simple                      (thSimpleApi) import           Web.Scotty                     (body, file, get, post, raw, scottyApp) -ioRes :: ByteString -> IO ByteString-ioRes req = do-  print req-  return-    "{\"data\":{\"deity\":{ \"fullName\": \"name\" }, \"character\":{ \"__typename\":\"Human\", \"lifetime\": \"Lifetime\", \"profession\": \"Artist\" }  }}"--defineByIntrospectionFile-  "./assets/introspection.json"-  [gql|-    # Query Hero with Compile time Validation-    query GetUser ($userCoordinates: Coordinates!)-      {-        myUser: user {-           boo3: name-           email-           address (coordinates: $userCoordinates ){-            city-           }-        }-      }-  |]--defineByDocumentFile-  "./assets/simple.gql"-  [gql|-    # Query Hero with Compile time Validation-    query GetHero ($god: Realm, $charID: String!)-      {-        deity (mythology:$god) {-          power-          fullName-        }-        character(characterID: $charID ) {-          ...on Creature {-            creatureName-          }-          ...on Human {-            lifetime-            profession-          }-        }-      }-  |]--fetchHero :: IO (Either String GetHero)-fetchHero = fetch ioRes GetHeroArgs {god = Just Realm {owner = "Zeus", surface = Just 10}, charID = "Hercules"}--fetUser :: GQLState IO Channel Content -> IO (Either String GetUser)-fetUser state = fetch (interpreter gqlRoot state) userArgs-  where-    userArgs :: Args GetUser-    userArgs = GetUserArgs {userCoordinates = Coordinates {longitude = [], latitude = String "1"}}- main :: IO () main = do-  fetchHero >>= print   state <- initGQLState   httpApp <- httpServer state-  fetUser state >>= print+  fetchHero >>= print+  fetUser (interpreter gqlRoot state) >>= print   Warp.runSettings settings $ WaiWs.websocketsOr defaultConnectionOptions (wsApp state) httpApp   where     settings = Warp.setPort 3000 Warp.defaultSettings@@ -100,5 +41,5 @@         get "/schema.gql" $ raw $ toGraphQLDocument $ Identity gqlRoot         post "/mythology" $ raw =<< (liftIO . mythologyApi =<< body)         get "/mythology" $ file "examples/index.html"-        post "/th" $ raw =<< (liftIO . thApi =<< body)+        post "/th" $ raw =<< (liftIO . thSimpleApi =<< body)         get "/th" $ file "examples/index.html"
examples/Mythology/API.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}  module Mythology.API   ( mythologyApi@@ -7,14 +8,14 @@ import qualified Data.ByteString.Lazy.Char8 as B  import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Types        (GQLRootResolver (..), IORes, resolver)+import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType, IORes, resolver) import           Data.Text                  (Text) import           GHC.Generics               (Generic) import           Mythology.Character.Deity  (Deity (..), dbDeity)  newtype Query = Query   { deity :: DeityArgs -> IORes Deity-  } deriving (Generic)+  } deriving (Generic, GQLType)  data DeityArgs = DeityArgs   { name      :: Text -- Required Argument
examples/Mythology/Character/Deity.hs view
@@ -22,7 +22,7 @@  instance GQLType Deity where   type KIND Deity = OBJECT-  description _ = "Custom Description for Client Defined User Type"+  description _ = Just "Custom Description for Client Defined User Type"  dbDeity :: Text -> Maybe Text -> IO (Either String Deity) dbDeity _ _ = return $ Right $ Deity {fullName = "Morpheus", power = Just "Shapeshifting", realm = Dream}
+ examples/Sophisticated/API.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}++module Sophisticated.API+  ( gqlRoot+  , Channel+  , Content+  ) where++import           Data.Map               (Map)+import qualified Data.Map               as M (fromList)+import           Data.Set               (Set)+import qualified Data.Set               as S (fromList)+import           Data.Text              (Text, pack)+import           Data.Typeable          (Typeable)+import           GHC.Generics           (Generic)++-- MORPHEUS+import           Data.Morpheus.Document (importGQLDocumentWithNamespace)+import           Data.Morpheus.Kind     (INPUT_UNION, OBJECT, SCALAR)+import           Data.Morpheus.Types    (Event (..), GQLRootResolver (..), GQLScalar (..), GQLType (..), ID, IOMutRes,+                                         IORes, IOSubRes, Resolver, ScalarValue (..), SubResolver (..), constRes,+                                         mutResolver, resolver)++$(importGQLDocumentWithNamespace "examples/Sophisticated/api.gql")++type AIntText = A (Int, Text)++type AText = A Text++type SetInt = Set Int++type MapTextInt = Map Text Int++data Animal+  = CAT Cat+  | DOG Dog+  | BIRD Bird+  deriving (Show, Generic)++instance GQLType Animal where+  type KIND Animal = INPUT_UNION++data Euro =+  Euro Int+       Int+  deriving (Show, Generic)++instance GQLType Euro where+  type KIND Euro = SCALAR++instance GQLScalar Euro where+  parseValue _ = pure (Euro 1 0)+  serialize (Euro x y) = Int (x * 100 + y)++instance Typeable a => GQLType (A a) where+  type KIND (A a) = OBJECT++newtype A a = A+  { wrappedA :: a+  } deriving (Generic)++data Channel+  = UPDATE_USER+  | UPDATE_ADDRESS+  deriving (Show, Eq, Ord)++data Content = Update+  { contentID      :: Int+  , contentMessage :: Text+  }++type MutRes = IOMutRes Channel Content++type SubRes = IOSubRes Channel Content++gqlRoot :: GQLRootResolver IO Channel Content (Query IORes) (Mutation MutRes) (Subscription SubRes)+gqlRoot = GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver}+  where+    queryResolver =+      return+        Query+          { queryUser = const $ resolver fetchUser+          , queryAnimal = \QueryAnimalArgs {queryAnimalArgsAnimal} -> return (pack $ show queryAnimalArgsAnimal)+          , querySet = constRes $ S.fromList [1, 2]+          , queryMap = constRes $ M.fromList [("robin", 1), ("carl", 2)]+          , queryWrapped1 = constRes $ A (0, "")+          , queryWrapped2 = constRes $ A ""+          }+    -------------------------------------------------------------+    mutationResolver = return Mutation {mutationCreateAddress, mutationCreateUser}+      where+        mutationCreateUser _ =+          mutResolver+            [Event [UPDATE_USER] (Update {contentID = 12, contentMessage = "some message for user"})]+            fetchUser+        --mutationCreateAddress :: () -> MutRes (Address MutRes)+        mutationCreateAddress _ =+          mutResolver+            [Event [UPDATE_ADDRESS] (Update {contentID = 10, contentMessage = "message for address"})]+            (fetchAddress (Euro 1 0))+    ----------------------------------------------------------------+    subscriptionResolver = return Subscription {subscriptionNewAddress, subscriptionNewUser}+      where+        subscriptionNewUser () = SubResolver {subChannels = [UPDATE_USER], subResolver}+          where+            subResolver (Event _ Update {}) = resolver fetchUser+        subscriptionNewAddress () = SubResolver {subChannels = [UPDATE_ADDRESS], subResolver}+          where+            subResolver (Event _ Update {contentID}) = resolver $ fetchAddress (Euro contentID 0)++fetchAddress :: Monad m => Euro -> m (Either String (Address (Resolver m)))+fetchAddress _ =+  return $ Right Address {addressCity = constRes "", addressStreet = constRes "", addressHouseNumber = constRes 0}++fetchUser :: Monad m => m (Either String (User (Resolver m)))+fetchUser =+  return $+  Right $+  User+    { userName = constRes "George"+    , userEmail = constRes "George@email.com"+    , userAddress = const resolveAddress+    , userOffice = resolveOffice+    , userHome = constRes HH+    , userEntity = constRes $ MyUnionUser unionUser+    }+  where+    unionAddress =+      Address {addressCity = constRes "Hamburg", addressStreet = constRes "Street", addressHouseNumber = constRes 20}+  -- Office+    resolveOffice _officeArgs = resolver $ fetchAddress (Euro 1 1)+    resolveAddress = resolver $ fetchAddress (Euro 1 0)+    unionUser =+      User+        { userName = constRes "David"+        , userEmail = constRes "David@email.com"+        , userAddress = const resolveAddress+        , userOffice = resolveOffice+        , userHome = constRes BLN+        , userEntity = const $ return $ MyUnionAddress unionAddress+        }
+ examples/Sophisticated/Model.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators         #-}++module Sophisticated.Model+  ( jsonAddress+  , jsonUser+  , JSONUser(..)+  , JSONAddress(..)+  ) where++import           Data.Aeson   (FromJSON)+import           Data.Text    (Text)+import           Files        (getJson)+import           GHC.Generics (Generic)++data JSONUser = JSONUser+  { name  :: Text+  , email :: Text+  } deriving (Show, Generic, FromJSON)++data JSONAddress = JSONAddress+  { city        :: Text+  , street      :: Text+  , houseNumber :: Int+  } deriving (Generic, Show, FromJSON)++jsonUser :: IO (Either String JSONUser)+jsonUser = getJson "deprecated/user"++jsonAddress :: IO (Either String JSONAddress)+jsonAddress = getJson "deprecated/address"
+ examples/Sophisticated/api.gql view
@@ -0,0 +1,66 @@+# for Input Union++input Cat {+  name: String!+}++input Dog {+  name: String!+}++input Bird {+  name: String!+}++# Main APi++enum CityID {+  Paris+  BLN+  HH+}++input Coordinates {+  latitude: Euro!+  longitude: [[[UniqueID!]!]]!+}++input UniqueID {+  id: String!+}++type Address {+  city: String!+  street: String!+  houseNumber: Int!+}++type User {+  name: String!+  email: String!+  address(coordinates: Coordinates!, comment: String): Address!+  office(zipCode: [[[ID!]]!], id: CityID!): Address!+  entity: MyUnion!+  home: CityID!+}++union MyUnion = User | Address++type Query {+  user: User!+  animal(animal: Animal): String!+  wrapped1: AIntText!+  wrapped2: AText!+  set: SetInt!+  map: MapTextInt!+}++type Mutation {+  createUser: User!+  createAddress: Address!+}++type Subscription {+  newAddress: Address!+  newUser: User!+}
examples/Subscription/SimpleSubscription.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings , ScopedTypeVariables , RankNTypes #-}  module Subscription.SimpleSubscription where -import           Data.Morpheus.Types       (Event (..), GQLRootResolver (..), IOMutRes, IORes, IOSubRes, resolver,-                                            toMutResolver)+import           Data.Morpheus.Types       (Event (..), GQLRootResolver (..), IOMutRes, IORes, IOSubRes,+                                            SubResolver (..), resolver, toMutResolver) import           Data.Text                 (Text) import           GHC.Generics              (Generic) import           Mythology.Character.Deity (Deity (..), dbDeity)@@ -40,8 +40,8 @@   where     fetchDeity = resolver $ dbDeity "" Nothing     createDeity _args = toMutResolver [Event {channels = [ChannelA], content = ContentA 1}] fetchDeity-    newDeity _args = Event {channels = [ChannelA], content}+    newDeity _args = SubResolver {subChannels = [ChannelA], subResolver}       where-        content (Event [ChannelA] (ContentA _value)) = resolver $ dbDeity "" Nothing -- resolve New State-        content (Event [ChannelA] (ContentB value))  = resolver $ dbDeity value Nothing -- resolve New State-        content _                                    = fetchDeity -- Resolve Old State+        subResolver (Event [ChannelA] (ContentA _value)) = resolver $ dbDeity "" Nothing -- resolve New State+        subResolver (Event [ChannelA] (ContentB value))  = resolver $ dbDeity value Nothing -- resolve New State+        subResolver _                                    = fetchDeity -- Resolve Old State
− examples/TH/API.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE TypeFamilies      #-}--module TH.API-  ( thApi-  ) where--import qualified Data.ByteString.Lazy.Char8 as B-import           Data.Text                  (Text)-import           GHC.Generics               (Generic)---- MORPHEUS-import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Document     (gqlDocument)-import           Data.Morpheus.Kind         (SCALAR)-import           Data.Morpheus.Types        (GQLRootResolver (..), GQLScalar (..), GQLType (..), ID, IORes,-                                             ScalarValue (..))--newtype Euro =-  Euro Int-  deriving (Show, Generic)--instance GQLType Euro where-  type KIND Euro = SCALAR--instance GQLScalar Euro where-  parseValue _ = pure (Euro 0)-  serialize (Euro x) = Int (x * 100)--[gqlDocument|-   # GraphQL  Types Generated By Template Haskell--  type Query {-    user : User!-  }---  """-    GraphQL Multiline Comment-  """-  type User {-    name                                      : Text!-    email                                     : Text!-    address (zipCode: UID!, cityID : CityID ) : Address!-    myUnion (coordinates: Coordinates)        : MyUnion!-    home                                      : CityID!-  }--  type Address {-    city        : Text!-    street      : Text!-    houseNumber : Int!-  }--  union MyUnion = User | Address--  enum CityID {-    Paris-    BLN-    HH-  }--  input Coordinates {-    latitude  : Euro!-    longitude : [[UID!]]!-  }--  # simple.gql-  interface Node {-      nodeId: ID!-  }--  type SimpleType implements Node {-    nodeId: ID!-    interfaceName: String!-  }--  input UID {-    uid: Text!-  }-|]--gqlRoot :: GQLRootResolver IO () () Query () ()-gqlRoot = GQLRootResolver {queryResolver, mutationResolver = return (), subscriptionResolver = return ()}-  where-    queryResolver :: IORes Query-    queryResolver = return Query {user}-      where-        user :: () -> IORes User-        user _ =-          return-            User-              { name = const $ pure "David"-              , email = const $ pure "David@email.com"-              , address-              , home = const $ pure HH-              , myUnion = const $ pure $ MyUnionAddress $ simpleAddress "boo"-              }-        address :: AddressArgs -> IORes Address-        address AddressArgs {zipCode = UID {uid}} = return $ simpleAddress uid-        ---------------------------------        simpleAddress streetID =-          Address {city = const $ pure "Hamburg", street = const $ pure streetID, houseNumber = const $ pure 20}--thApi :: B.ByteString -> IO B.ByteString-thApi = interpreter gqlRoot
examples/TH/Simple.hs view
@@ -1,41 +1,35 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}  module TH.Simple-  ( mythologyApi+  ( thSimpleApi   ) where  import qualified Data.ByteString.Lazy.Char8 as B  import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Document     (gqlDocument)+import           Data.Morpheus.Document     (importGQLDocumentWithNamespace) import           Data.Morpheus.Types        (GQLRootResolver (..), IORes) import           Data.Text                  (Text) -[gqlDocument|--  type Query {-    deity (uid: Text! ) : Deity!-  }--  type Deity {-    name : Text!-    power    : Text-  }--|]+importGQLDocumentWithNamespace "examples/TH/simple.gql" -rootResolver :: GQLRootResolver IO () () Query () ()+rootResolver :: GQLRootResolver IO () () (Query IORes) () () rootResolver =-  GQLRootResolver {queryResolver = return Query {deity}, mutationResolver = pure (), subscriptionResolver = pure ()}+  GQLRootResolver+    {queryResolver = return Query {queryDeity}, mutationResolver = pure (), subscriptionResolver = pure ()}   where-    deity DeityArgs {uid} = pure Deity {name, power}+    queryDeity QueryDeityArgs {queryDeityArgsName} = pure Deity {deityName, deityPower}       where-        name _ = pure "Morpheus"-        power _ = pure (Just "Shapeshifting")+        deityName _ = pure "Morpheus"+        deityPower _ = pure (Just "Shapeshifting") -mythologyApi :: B.ByteString -> IO B.ByteString-mythologyApi = interpreter rootResolver+thSimpleApi :: B.ByteString -> IO B.ByteString+thSimpleApi = interpreter rootResolver
+ examples/TH/simple.gql view
@@ -0,0 +1,8 @@+type Query {+  deity(name: String!): Deity!+}++type Deity {+  name: String!+  power: String+}
morpheus-graphql.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e5802f5202e1f3d85dbcbbfa5bbeccbe45394f9039335d2315915df0cee9d49a+-- hash: 9eb00b52c6088e489408ff248d45e1402e955f2885390bbcc2fbd26944051b36  name:           morpheus-graphql-version:        0.2.2+version:        0.3.0 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -24,6 +24,8 @@     assets/pubsub.gql     assets/simple.gql     changelog.md+    examples/Sophisticated/api.gql+    examples/TH/simple.gql     README.md data-files:     test/Feature/Holistic/API.gql@@ -246,8 +248,12 @@       Data.Morpheus.Execution.Document.Compile       Data.Morpheus.Execution.Document.Convert       Data.Morpheus.Execution.Document.Declare+      Data.Morpheus.Execution.Document.Decode+      Data.Morpheus.Execution.Document.Encode       Data.Morpheus.Execution.Document.GQLType+      Data.Morpheus.Execution.Document.Introspect       Data.Morpheus.Execution.Internal.Declare+      Data.Morpheus.Execution.Internal.Decode       Data.Morpheus.Execution.Internal.Utils       Data.Morpheus.Execution.Server.Decode       Data.Morpheus.Execution.Server.Encode@@ -265,27 +271,22 @@       Data.Morpheus.Parsing.Internal.Internal       Data.Morpheus.Parsing.Internal.Terms       Data.Morpheus.Parsing.JSONSchema.Parse+      Data.Morpheus.Parsing.JSONSchema.Types       Data.Morpheus.Parsing.Request.Arguments       Data.Morpheus.Parsing.Request.Body       Data.Morpheus.Parsing.Request.Fragment       Data.Morpheus.Parsing.Request.Operation       Data.Morpheus.Parsing.Request.Parser       Data.Morpheus.Parsing.Request.Value-      Data.Morpheus.Rendering.GQL       Data.Morpheus.Rendering.Haskell.Render+      Data.Morpheus.Rendering.Haskell.RenderHS       Data.Morpheus.Rendering.Haskell.Terms       Data.Morpheus.Rendering.Haskell.Types       Data.Morpheus.Rendering.Haskell.Values-      Data.Morpheus.Schema.Directive-      Data.Morpheus.Schema.DirectiveLocation-      Data.Morpheus.Schema.EnumValue-      Data.Morpheus.Schema.Field-      Data.Morpheus.Schema.InputValue-      Data.Morpheus.Schema.Internal.RenderIntrospection-      Data.Morpheus.Schema.JSONType+      Data.Morpheus.Rendering.RenderGQL+      Data.Morpheus.Rendering.RenderIntrospection       Data.Morpheus.Schema.Schema       Data.Morpheus.Schema.SchemaAPI-      Data.Morpheus.Schema.Type       Data.Morpheus.Schema.TypeKind       Data.Morpheus.Types.Custom       Data.Morpheus.Types.GQLScalar@@ -343,15 +344,15 @@ executable api   main-is: Main.hs   other-modules:-      Deprecated.API-      Deprecated.Model+      Client.Client       Files       Mythology.API       Mythology.Character.Deity       Mythology.Character.Human       Mythology.Place.Places+      Sophisticated.API+      Sophisticated.Model       Subscription.SimpleSubscription-      TH.API       TH.Simple       Paths_morpheus_graphql   hs-source-dirs:
src/Data/Morpheus.hs view
src/Data/Morpheus/Document.hs view
@@ -6,6 +6,8 @@   , toMorpheusHaskellAPi   , gqlDocument   , parseFullGQLDocument+  , importGQLDocument+  , importGQLDocumentWithNamespace   ) where  import           Control.Monad                                ((>=>))@@ -13,14 +15,14 @@ import           Data.Text                                    (Text) import qualified Data.Text.Lazy                               as LT (toStrict) import           Data.Text.Lazy.Encoding                      (decodeUtf8)-import           Language.Haskell.TH.Quote+import           Language.Haskell.TH  -- -- MORPHEUS-import           Data.Morpheus.Execution.Document.Compile     (compileDec, compileExp)+import           Data.Morpheus.Execution.Document.Compile     (compileDocument, gqlDocument) import           Data.Morpheus.Execution.Server.Resolve       (RootResCon, fullSchema)-import           Data.Morpheus.Rendering.GQL                  (renderGraphQLDocument) import           Data.Morpheus.Rendering.Haskell.Render       (renderHaskellDocument)+import           Data.Morpheus.Rendering.RenderGQL            (renderGraphQLDocument) import           Data.Morpheus.Types                          (GQLRootResolver)  import           Data.Morpheus.Parsing.Document.Parser        (parseTypes)@@ -52,9 +54,8 @@     Left errors -> Left $ pack (show errors)     Right lib   -> Right $ renderHaskellDocument moduleName lib -gqlDocument :: QuasiQuoter-gqlDocument =-  QuasiQuoter-    {quoteExp = compileExp, quotePat = notHandled "Patterns", quoteType = notHandled "Types", quoteDec = compileDec}-  where-    notHandled things = error $ things ++ " are not supported by the GraphQL QuasiQuoter"+importGQLDocument :: String -> Q [Dec]+importGQLDocument src = runIO (readFile src) >>= compileDocument False++importGQLDocumentWithNamespace :: String -> Q [Dec]+importGQLDocumentWithNamespace src = runIO (readFile src) >>= compileDocument True
src/Data/Morpheus/Error/Selection.hs view
@@ -6,14 +6,18 @@   , duplicateQuerySelections   , hasNoSubfields   , fieldNotResolved+  , resolverError   ) 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           Data.Text                               (Text, pack) 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@@ -23,44 +27,21 @@ 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."-        ]+    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, "\"."]+    text = T.concat ["Cannot query field \"", key, "\" on type \"", typeName, "\"."]  duplicateQuerySelections :: Text -> [EnhancedKey] -> 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-        , "\"."-        ]+    keyToError (EnhancedKey key' pos) = GQLError {desc = toMessage key', positions = [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"-        ]+    text = T.concat ["Field \"", key, "\" of type \"", typeName, "\" must have a selection of subfields"]
src/Data/Morpheus/Execution/Client/Aeson.hs view
@@ -15,14 +15,16 @@  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  -- -- MORPHEUS-import Data.Morpheus.Types.Internal.DataD (AppD (..), ConsD (..), FieldD (..), TypeD (..))+import           Data.Morpheus.Types.Internal.Data  (DataField (..), isFieldNullable)+import           Data.Morpheus.Types.Internal.DataD (ConsD (..), TypeD (..))+import           Data.Morpheus.Types.Internal.TH    (instanceFunD, instanceHeadT)  deriveFromJSON :: TypeD -> Q Dec deriveFromJSON TypeD {tCons = []} = fail "Type Should Have at least one Constructor"@@ -38,14 +40,17 @@ aesonObjectBody ConsD {cName, cFields} = handleFields cFields   where     consName = mkName cName+    ------------------------------------------     handleFields [] = fail $ "No Empty Object"     handleFields fields = startExp fields     -----------------------------------------------------------------------------------         -- Optional Field+      -- Optional Field       where-        defField FieldD {fieldNameD, fieldTypeD = MaybeD _} = [|o .:? fieldNameD|]-        -- Required Field-        defField FieldD {fieldNameD}                        = [|o .: fieldNameD|]+        defField field@DataField {fieldName}+          | isFieldNullable field = [|o .:? fName|]+          | otherwise = [|o .: fName|]+          where+            fName = unpack fieldName             -------------------------------------------------------------------         startExp fNames = uInfixE (conE consName) (varE '(<$>)) (applyFields fNames)           where@@ -70,11 +75,11 @@ takeValueType _ _ = fail $ "expected Object"  defineFromJSON :: String -> (t -> ExpQ) -> t -> DecQ-defineFromJSON tName func inp =-  instanceD (cxt []) (appT (conT ''FromJSON) (conT $ mkName tName)) [parseJSONExp func inp]+defineFromJSON tName parseJ cFields = instanceD (cxt []) iHead [method]   where-    parseJSONExp :: (t -> ExpQ) -> t -> DecQ-    parseJSONExp parseJ cFields = funD 'parseJSON [clause [] (normalB $ parseJ cFields) []]+    iHead = instanceHeadT ''FromJSON tName []+    -----------------------------------------+    method = instanceFunD 'parseJSON [] (parseJ cFields)  isEnum :: [ConsD] -> Bool isEnum = not . isEmpty . filter (isEmpty . cFields)
src/Data/Morpheus/Execution/Client/Fetch.hs view
@@ -10,15 +10,16 @@   , deriveFetch   ) 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  -- -- MORPHEUS-import           Data.Morpheus.Types.IO (GQLRequest (..), JSONResponse (..))+import           Data.Morpheus.Types.Internal.TH (instanceHeadT)+import           Data.Morpheus.Types.IO          (GQLRequest (..), JSONResponse (..))  class Fetch a where   type Args a :: *@@ -32,16 +33,16 @@   __fetch strQuery opName trans vars = (eitherDecode >=> processResponse) <$> trans (encode gqlReq)     where       gqlReq = GQLRequest {operationName = Just (pack opName), query = pack strQuery, variables = Just (toJSON vars)}-      ----+      -------------------------------------------------------------       processResponse JSONResponse {responseData = Just x} = pure x       processResponse invalidResponse                      = fail $ show invalidResponse   fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either String a)  deriveFetch :: Type -> String -> String -> Q [Dec]-deriveFetch argDatatype typeName query =-  pure <$> instanceD (cxt []) (appT (conT ''Fetch) (conT $ mkName typeName)) methods+deriveFetch argDatatype typeName query = pure <$> instanceD (cxt []) iHead methods   where+    iHead = instanceHeadT ''Fetch typeName []     methods =-      [ funD (mkName "fetch") [clause [] (normalB [|__fetch query typeName|]) []]+      [ funD 'fetch [clause [] (normalB [|__fetch query typeName|]) []]       , pure $ TySynInstD ''Args (TySynEqn [ConT $ mkName typeName] argDatatype)       ]
src/Data/Morpheus/Execution/Client/Selection.hs view
@@ -18,9 +18,9 @@                                                              VariableDefinitions) import           Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..)) import           Data.Morpheus.Types.Internal.Data          (DataField (..), DataFullType (..), DataLeaf (..),-                                                             DataType (..), DataTypeLib (..), DataTypeWrapper,+                                                             DataTyCon (..), DataTypeLib (..), TypeAlias (..),                                                              allDataTypes)-import           Data.Morpheus.Types.Internal.DataD         (ConsD (..), FieldD (..), TypeD (..), gqlToHSWrappers)+import           Data.Morpheus.Types.Internal.DataD         (ConsD (..), TypeD (..)) import           Data.Morpheus.Types.Internal.Validation    (GQLErrors, Validation) import           Data.Morpheus.Validation.Internal.Utils    (lookupType) @@ -33,15 +33,15 @@     queryDataType = OutputObject $ snd $ query lib     -----------------------------------------------------     typeByField :: Text -> DataFullType -> Validation DataFullType-    typeByField key datatype = fst <$> fieldDataType datatype key+    typeByField key datatype = fst <$> lookupFieldType datatype key     -------------------------------------------------------    fieldDataType :: DataFullType -> Text -> Validation (DataFullType, [DataTypeWrapper])-    fieldDataType (OutputObject DataType {typeData}) key =+    lookupFieldType :: DataFullType -> Text -> Validation (DataFullType, TypeAlias)+    lookupFieldType (OutputObject DataTyCon {typeData}) key =       case lookup key typeData of-        Just DataField {fieldTypeWrappers, fieldType} -> trans <$> getType lib fieldType-          where trans x = (x, fieldTypeWrappers)+        Just DataField {fieldType = alias@TypeAlias {aliasTyCon}} -> trans <$> getType lib aliasTyCon+          where trans x = (x, alias {aliasTyCon = typeFrom x, aliasArgs = Nothing})         Nothing -> Left (compileError key)-    fieldDataType _ key = Left (compileError key)+    lookupFieldType _ key = Left (compileError key)     -----------------------------------------------------     genOperation Operation {operationName, operationSelection} = do       argTypes <- rootArguments (operationName <> "Args")@@ -51,22 +51,20 @@     genInputType :: Text -> Validation [TypeD]     genInputType name = getType lib name >>= subTypes       where-        subTypes (InputObject DataType {typeName, typeData}) = do+        subTypes (InputObject DataTyCon {typeName, typeData}) = do           types <- concat <$> mapM toInputTypeD typeData           fields <- traverse toFieldD typeData           pure $ typeD fields : types           where             typeD fields = TypeD {tName = unpack typeName, tCons = [ConsD {cName = unpack typeName, cFields = fields}]}             ----------------------------------------------------------------            toInputTypeD :: (Text, DataField a) -> Validation [TypeD]-            toInputTypeD (_, DataField {fieldType}) = genInputType fieldType+            toInputTypeD :: (Text, DataField) -> Validation [TypeD]+            toInputTypeD (_, DataField {fieldType}) = genInputType $ aliasTyCon fieldType             -----------------------------------------------------------------            toFieldD :: (Text, DataField a) -> Validation FieldD-            toFieldD (key, DataField {fieldType, fieldTypeWrappers}) = do-              fType <- typeFrom <$> getType lib fieldType-              pure $ FieldD (unpack key) (wrType fType)-              where-                wrType fieldT = gqlToHSWrappers fieldTypeWrappers (unpack fieldT)+            toFieldD :: (Text, DataField) -> Validation DataField+            toFieldD (_, field@DataField {fieldType}) = do+              aliasTyCon <- typeFrom <$> getType lib (aliasTyCon fieldType)+              pure $ field {fieldType = fieldType {aliasTyCon}}         subTypes (Leaf x) = buildLeaf x         subTypes _ = pure []     -------------------------------------------@@ -78,10 +76,16 @@         typeD :: TypeD         typeD = TypeD {tName = unpack name, tCons = [ConsD {cName = unpack name, cFields = map fieldD variables}]}         ----------------------------------------        fieldD :: (Text, Variable ()) -> FieldD-        fieldD (key, Variable {variableType, variableTypeWrappers}) = FieldD (unpack key) wrType-          where-            wrType = gqlToHSWrappers variableTypeWrappers (unpack variableType)+        fieldD :: (Text, Variable ()) -> DataField+        fieldD (key, Variable {variableType, variableTypeWrappers}) =+          DataField+            { fieldName = key+            , fieldArgs = []+            , fieldArgsType = Nothing+            , fieldType =+                TypeAlias {aliasWrappers = variableTypeWrappers, aliasTyCon = variableType, aliasArgs = Nothing}+            , fieldHidden = False+            }     -------------------------------------------     getCon name dataType selectionSet = do       cFields <- genFields dataType selectionSet@@ -91,14 +95,13 @@       where         genFields datatype = mapM typeNameFromField           where-            typeNameFromField :: (Text, Selection) -> Validation FieldD-            typeNameFromField (key, Selection {selectionRec = SelectionAlias {aliasFieldName}}) =-              FieldD (unpack key) <$> lookupFieldType aliasFieldName-            typeNameFromField (key, _) = FieldD (unpack key) <$> lookupFieldType key-            -------------------------------------------------------------            lookupFieldType key = do-              (newType, wrappers) <- fieldDataType datatype key-              pure $ gqlToHSWrappers wrappers (unpack $ typeFrom newType)+            typeNameFromField :: (Text, Selection) -> Validation DataField+            typeNameFromField (fieldName, Selection {selectionRec = SelectionAlias {aliasFieldName}}) = do+              fieldType <- snd <$> lookupFieldType datatype aliasFieldName+              pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}+            typeNameFromField (fieldName, _) = do+              fieldType <- snd <$> lookupFieldType datatype fieldName+              pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}     --------------------------------------------     genRecordType name dataType selectionSet = do       (con, subTypes) <- getCon name dataType selectionSet@@ -127,7 +130,7 @@               getCon typeKey conDatatype selSet  buildLeaf :: DataLeaf -> Validation [TypeD]-buildLeaf (LeafEnum DataType {typeName, typeData}) =+buildLeaf (LeafEnum DataTyCon {typeName, typeData}) =   pure [TypeD {tName = unpack typeName, tCons = map enumOption typeData}]   where     enumOption name = ConsD {cName = unpack name, cFields = []}@@ -146,7 +149,7 @@  typeFrom :: DataFullType -> Text typeFrom (Leaf (BaseScalar x)) = typeName x-typeFrom (Leaf (CustomScalar DataType {typeName}))+typeFrom (Leaf (CustomScalar DataTyCon {typeName}))   | isPrimitive typeName = typeName   | otherwise = "ScalarValue" typeFrom (Leaf (LeafEnum x)) = typeName x
src/Data/Morpheus/Execution/Document/Compile.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE NamedFieldPuns  #-}-{-# LANGUAGE QuasiQuotes     #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NamedFieldPuns #-}  module Data.Morpheus.Execution.Document.Compile-  ( compileExp-  , compileDec+  ( compileDocument+  , gqlDocument+  , gqlDocumentNamespace   ) where  import qualified Data.Text                                    as T (pack) import           Language.Haskell.TH+import           Language.Haskell.TH.Quote  -- --  Morpheus@@ -18,14 +18,30 @@ import           Data.Morpheus.Parsing.Document.Parser        (parseTypes) import           Data.Morpheus.Validation.Document.Validation -compileExp :: String -> Q Exp-compileExp documentTXT =-  case parseTypes (T.pack documentTXT) >>= validatePartialDocument >>= renderTHTypes of-    Left errors -> fail (renderGQLErrors errors)-    Right root  -> [|root|]+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" -compileDec :: String -> Q [Dec]-compileDec documentTXT =-  case parseTypes (T.pack documentTXT) >>= validatePartialDocument >>= renderTHTypes of-    Left errors -> fail (renderGQLErrors errors)-    Right root  -> declareTypes root+gqlDocument :: QuasiQuoter+gqlDocument =+  QuasiQuoter+    { quoteExp = notHandled "Expressions"+    , quotePat = notHandled "Patterns"+    , quoteType = notHandled "Types"+    , quoteDec = compileDocument False+    }+  where+    notHandled things = error $ things ++ " are not supported by the GraphQL QuasiQuoter"++compileDocument :: Bool -> String -> Q [Dec]+compileDocument namespace documentTXT =+  case parseTypes (T.pack documentTXT) >>= validatePartialDocument >>= renderTHTypes namespace of+    Left errors  -> fail (renderGQLErrors errors)+    Right schema -> declareTypes namespace schema
src/Data/Morpheus/Execution/Document/Convert.hs view
@@ -5,72 +5,136 @@ {-# LANGUAGE TypeOperators       #-}  module Data.Morpheus.Execution.Document.Convert-  ( renderTHTypes+  ( renderTHTypes , sysTypes   ) where  import           Data.Semigroup                          ((<>))-import           Data.Text                               (Text, unpack)+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       (DataField (..), DataFullType (..), DataLeaf (..),-                                                          DataOutputField, DataType (..), DataTypeKind (..))-import           Data.Morpheus.Types.Internal.DataD      (AppD (..), ConsD (..), FieldD (..), GQLTypeD, TypeD (..),-                                                          gqlToHSWrappers)+import           Data.Morpheus.Types.Internal.Data       (ArgsType (..), DataField (..), DataField, DataFullType (..),+                                                          DataLeaf (..), DataTyCon (..), DataTypeKind (..),+                                                          DataTypeKind (..), OperationKind (..), ResolverKind (..),+                                                          TypeAlias (..))+import           Data.Morpheus.Types.Internal.DataD      (ConsD (..), GQLTypeD (..), TypeD (..)) import           Data.Morpheus.Types.Internal.Validation (Validation) -renderTHTypes :: [(Text, DataFullType)] -> Validation [GQLTypeD]-renderTHTypes = traverse renderTHType+sysTypes :: [Text]+sysTypes =+  ["__Schema", "__Type", "__Directive", "__TypeKind", "__Field", "__DirectiveLocation", "__InputValue", "__EnumValue"] -renderTHType :: (Text, DataFullType) -> Validation GQLTypeD-renderTHType (_, x) = genType x+renderTHTypes :: Bool -> [(Text, DataFullType)] -> Validation [GQLTypeD]+renderTHTypes namespace lib = traverse renderTHType lib   where-    argsTypeName fieldName = capital (unpack fieldName) <> "Args"-    genArgumentType :: (Text, DataField [(Text, DataField ())]) -> Validation [TypeD]-    genArgumentType (_, DataField {fieldArgs = []}) = pure []-    genArgumentType (fieldName, DataField {fieldArgs}) =-      pure [TypeD {tName, tCons = [ConsD {cName = tName, cFields = map genField fieldArgs}]}]-      where-        tName = argsTypeName fieldName-    ----------------------------------------------------------------------------------------------    genField :: (Text, DataField a) -> FieldD-    genField (key, DataField {fieldType, fieldTypeWrappers}) = FieldD (unpack key) fType-      where-        fType = gqlToHSWrappers fieldTypeWrappers (unpack fieldType)-    ----------------------------------------------------------------------------------------------    genResField :: (Text, DataOutputField) -> FieldD-    genResField (key, DataField {fieldName, fieldArgs, fieldType, fieldTypeWrappers}) = FieldD (unpack key) fType-      where-        fType = ResD (argsTName fieldArgs) "IORes" $ gqlToHSWrappers fieldTypeWrappers (unpack fieldType)-        argsTName [] = "()"-        argsTName _  = argsTypeName fieldName-    ---------------------------------------------    genType (Leaf (LeafEnum DataType {typeName, typeData})) =-      pure (TypeD {tName = unpack typeName, tCons = map enumOption typeData}, KindEnum, [])-      where-        enumOption name = ConsD {cName = unpack name, cFields = []}-    genType (Leaf _) = internalError "Scalar Types should defined By Native Haskell Types"-    genType (InputUnion _) = internalError "Input Unions not Supported"-    genType (InputObject DataType {typeName, typeData}) =-      pure-        ( TypeD {tName = unpack typeName, tCons = [ConsD {cName = unpack typeName, cFields = map genField typeData}]}-        , KindInputObject-        , [])-    genType (OutputObject DataType {typeName, typeData}) = do-      subTypes <- concat <$> traverse genArgumentType typeData-      pure-        ( TypeD {tName = unpack typeName, tCons = [ConsD {cName = unpack typeName, cFields = map genResField typeData}]}-        , KindObject-        , subTypes)-    genType (Union DataType {typeName, typeData}) = do-      let tCons = map unionCon typeData-      pure (TypeD {tName = unpack typeName, tCons}, KindUnion, [])+    renderTHType :: (Text, DataFullType) -> Validation GQLTypeD+    renderTHType (tyConName, x) = genType x       where-        unionCon DataField {fieldType} =-          ConsD {cName, cFields = [FieldD {fieldNameD = "un" <> cName, fieldTypeD = BaseD utName}]}+        genArgsTypeName fieldName+          | namespace = sysName tyConName <> argTName+          | otherwise = argTName           where-            cName = unpack typeName <> utName-            utName = unpack fieldType-    ------------------------------------------------------------------------------------------------------------+            argTName = capital fieldName <> "Args"+        genArgumentType :: (Text, DataField) -> Validation [TypeD]+        genArgumentType (_, DataField {fieldArgs = []}) = pure []+        genArgumentType (fieldName, DataField {fieldArgs}) =+          pure [TypeD {tName, 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 OutputObject {} -> Just "m"+                Just Union {}        -> 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 OutputObject {} -> TypeVarResolver+                    Just Union {}        -> TypeVarResolver+                    Just _               -> PlainResolver+        --------------------------------------------+        genType (Leaf (LeafEnum DataTyCon {typeName, typeData})) =+          pure+            GQLTypeD+              { typeD = TypeD {tName = sysName typeName, tCons = map enumOption typeData}+              , typeKindD = KindEnum+              , typeArgD = []+              }+          where+            enumOption name = ConsD {cName = sysName name, cFields = []}+        genType (Leaf _) = internalError "Scalar Types should defined By Native Haskell Types"+        genType (InputUnion _) = internalError "Input Unions not Supported"+        genType (InputObject DataTyCon {typeName, typeData}) =+          pure+            GQLTypeD+              { typeD =+                  TypeD+                    { tName = sysName typeName+                    , tCons = [ConsD {cName = sysName typeName, cFields = map genField typeData}]+                    }+              , typeKindD = KindInputObject+              , typeArgD = []+              }+        genType (OutputObject DataTyCon {typeName, typeData}) = do+          typeArgD <- concat <$> traverse genArgumentType typeData+          pure+            GQLTypeD+              { typeD =+                  TypeD+                    { tName = sysName typeName+                    , tCons = [ConsD {cName = sysName typeName, cFields = map genResField typeData}]+                    }+              , typeKindD =+                  if typeName == "Subscription"+                    then KindObject (Just Subscription)+                    else KindObject Nothing+              , typeArgD+              }+        genType (Union DataTyCon {typeName, typeData}) = do+          let tCons = map unionCon typeData+          pure GQLTypeD {typeD = TypeD {tName = unpack typeName, 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+                cName = sysName typeName <> utName+                utName = sysName $ aliasTyCon fieldType
src/Data/Morpheus/Execution/Document/Declare.hs view
@@ -1,24 +1,54 @@-{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE TemplateHaskell #-}  module Data.Morpheus.Execution.Document.Declare   ( declareTypes   ) where -import           Data.Semigroup                           ((<>))+import           Data.Semigroup                              ((<>)) import           Language.Haskell.TH  -- -- MORPHEUS-import           Data.Morpheus.Execution.Document.GQLType (deriveGQLType)-import           Data.Morpheus.Execution.Internal.Declare (declareType)-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)+import           Data.Morpheus.Execution.Internal.Declare    (declareGQLT)+import           Data.Morpheus.Types.Internal.Data           (isInput, isObject)+import           Data.Morpheus.Types.Internal.DataD          (GQLTypeD (..)) -declareTypes :: [GQLTypeD] -> Q [Dec]-declareTypes = fmap concat . traverse declareGQLType+declareTypes :: Bool -> [GQLTypeD] -> Q [Dec]+declareTypes namespace = fmap concat . traverse (declareGQLType namespace) -declareGQLType :: GQLTypeD -> Q [Dec]-declareGQLType gqlType@(typeD, _, argTypes) = do-  let types = map (declareType []) (typeD : argTypes)+declareGQLType :: Bool -> GQLTypeD -> Q [Dec]+declareGQLType namespace gqlType@GQLTypeD {typeD, typeKindD, typeArgD} = do+  mainType <- declareMainType+  argTypes <- declareArgTypes+  gqlInstances <- deriveGQLInstances   typeClasses <- deriveGQLType gqlType-  pure $ types <> typeClasses+  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 (declareGQLT namespace Nothing []) typeArgD+        --------------------------------------------------+    declareMainType = declareT+      where+        declareT = pure [declareGQLT namespace (Just typeKindD) derivingClasses typeD]+        derivingClasses+          | isInput typeKindD = [''Show]+          | otherwise = []
+ src/Data/Morpheus/Execution/Document/Decode.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE MonoLocalBinds    #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TemplateHaskell   #-}++module Data.Morpheus.Execution.Document.Decode+  ( deriveDecode+  ) where++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)++(.:) :: 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 _ = pure []
+ src/Data/Morpheus/Execution/Document/Encode.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Data.Morpheus.Execution.Document.Encode+  ( deriveEncode+  ) where++import           Data.Text                               (unpack)+import           Data.Typeable                           (Typeable)+import           Language.Haskell.TH++--+-- MORPHEUS+import           Data.Morpheus.Execution.Server.Encode   (Encode (..), ObjectResolvers (..))+import           Data.Morpheus.Types.GQLType             (TRUE)+import           Data.Morpheus.Types.Internal.Data       (DataField (..), isSubscription)+import           Data.Morpheus.Types.Internal.DataD      (ConsD (..), GQLTypeD (..), TypeD (..))+import           Data.Morpheus.Types.Internal.TH         (applyT, instanceHeadMultiT, typeT)+import           Data.Morpheus.Types.Internal.Validation (ResolveT)+import           Data.Morpheus.Types.Internal.Value      (Value)+import           Data.Morpheus.Types.Resolver++-- @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)]+--+--+deriveEncode :: GQLTypeD -> Q [Dec]+deriveEncode GQLTypeD {typeKindD, typeD = TypeD {tName, tCons = [ConsD {cFields}]}} =+  pure <$> instanceD (cxt constrains) appHead methods+  where+    result = appT resultMonad (conT ''Value)+      where+        resultMonad+          | isSubscription typeKindD = typeT ''SubResolveT ["m", "e", "c"] -- (SubResolveT m e c Value)+          | otherwise = typeT ''ResolveT ["m"] -- (ResolveT m Value)+    mainType = applyT (mkName tName) [mainTypeArg] -- defines  (<Type> (SubResolver m e c)) or (<Type> (Resolver m))+      where+        mainTypeArg+          | isSubscription typeKindD = typeT ''SubResolver ["m", "e", "c"] -- (SubResolver m e c)+          | otherwise = typeT ''Resolver ["m"] -- (Resolver m)+    -----------------------------------------------------------------------------------------+    -- defines Constraint: (Typeable m, Monad m)+    constrains = [typeT ''Monad ["m"], typeT ''Typeable ["m"]]+    -------------------------------------------------------------------+    -- defines: instance <constraint> =>  ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value) where+    appHead = instanceHeadMultiT ''ObjectResolvers (conT ''TRUE) [mainType, result]+    ------------------------------------------------------------------+    -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...]+    methods = [funD 'objectResolvers [clause argsE (normalB body) []]]+      where+        argsE = [varP (mkName "_"), conP (mkName tName) (map (varP . mkName) varNames)]+        body = listE $ map decodeVar varNames+        decodeVar name = [|(name, encode $(varName))|]+          where+            varName = varE $ mkName name+        varNames = map (unpack . fieldName) cFields+deriveEncode _ = pure []
src/Data/Morpheus/Execution/Document/GQLType.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds         #-} {-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}@@ -7,26 +8,65 @@   ( deriveGQLType   ) where +import           Data.Text                                (pack) import           Language.Haskell.TH -import           Data.Morpheus.Kind                 (ENUM, INPUT_OBJECT, INPUT_UNION, OBJECT, SCALAR, UNION, WRAPPER)+import           Data.Morpheus.Execution.Document.Convert (sysTypes)  -- -- MORPHEUS-import           Data.Morpheus.Types.GQLType        (GQLType (..))-import           Data.Morpheus.Types.Internal.Data  (DataTypeKind (..))-import           Data.Morpheus.Types.Internal.DataD (GQLTypeD, TypeD (..))+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)+import           Data.Morpheus.Types.Internal.DataD       (GQLTypeD (..), TypeD (..))+import           Data.Morpheus.Types.Internal.TH          (instanceHeadT, typeT)+import           Data.Typeable                            (Typeable) +genTypeName :: String -> String+genTypeName ('S':name)+  | pack name `elem` sysTypes = name+genTypeName name = name+ deriveGQLType :: GQLTypeD -> Q [Dec]-deriveGQLType (TypeD {tName}, gqlKind, _) =-  pure <$> instanceD (cxt []) (appT (conT ''GQLType) (conT $ mkName tName)) methods+deriveGQLType GQLTypeD {typeD = TypeD {tName}, typeKindD} =+  pure <$> instanceD (cxt constrains) iHead (def__typeName : typeFamilies)   where-    methods = [pure $ TySynInstD ''KIND (TySynEqn [ConT $ mkName tName] (ConT $ toKIND gqlKind))]-    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+    def__typeName = funD '__typeName [clause argsE (normalB body) []]+    -- defines method: __typeName _ = tName+      where+        argsE = map (varP . mkName) ["_"]+        body = [|pack name|]+          where+            name = genTypeName tName+    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 $ TySynInstD ''CUSTOM (TySynEqn [typeN] (ConT ''TRUE))+        ---------------------------------------------------------------+        deriveKind = do+          typeN <- headSig+          pure $ TySynInstD ''KIND (TySynEqn [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
+ src/Data/Morpheus/Execution/Document/Introspect.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TemplateHaskell   #-}++module Data.Morpheus.Execution.Document.Introspect+  ( deriveObjectRep+  ) where++import           Data.Proxy                                (Proxy (..))+import           Data.Text                                 (unpack)+import           Data.Typeable                             (Typeable)+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)++-- [((Text, DataField), TypeUpdater)]+deriveObjectRep :: (TypeD, Maybe DataTypeKind) -> Q [Dec]+deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, tKind) =+  pure <$> instanceWithOverlapD overlapping (cxt constrains) iHead methods+  where+    overlapping = Just Overlapping+    typeArgs =+      case tKind of+        Just typeKind -> tyConArgs typeKind+        Nothing       -> []+    constrains = map conTypeable typeArgs+      where+        conTypeable name = typeT ''Typeable [name]+    -----------------------------------------------+    iHead = instanceHeadMultiT ''ObjectFields (conT ''TRUE) [typeT (mkName tName) typeArgs]+    methods = [instanceFunD 'objectFields ["_proxy1", "_proxy2"] body]+      where+        body = [|($(buildFields cFields), concat $(buildTypes cFields))|]+deriveObjectRep _ = pure []++buildTypes :: [DataField] -> ExpQ+buildTypes = listE . concatMap introspectField+  where+    introspectField DataField {fieldType, fieldArgsType} =+      [|[introspect $(proxyT fieldType)]|] : inputTypes fieldArgsType+      where+        inputTypes (Just ArgsType {argsTypeName})+          | argsTypeName /= "()" = [[|snd $ objectFields (Proxy :: Proxy TRUE) $(proxyT tAlias)|]]+          where+            tAlias = TypeAlias {aliasTyCon = argsTypeName, aliasWrappers = [], aliasArgs = Nothing}+        inputTypes _ = []++proxyT :: TypeAlias -> Q Exp+proxyT TypeAlias {aliasTyCon, aliasArgs} = [|(Proxy :: Proxy $(genSig aliasArgs))|]+  where+    genSig (Just m) = appT (conT $ mkName $ unpack aliasTyCon) (varT $ mkName $ unpack m)+    genSig _        = conT $ mkName $ unpack aliasTyCon++buildFields :: [DataField] -> ExpQ+buildFields = listE . map buildField+  where+    buildField DataField {fieldName, fieldArgs, fieldType = alias@TypeAlias {aliasArgs, aliasWrappers}} =+      [|( fName+        , DataField+            { fieldName = fName+            , fieldArgs = fArgs+            , fieldArgsType = Nothing+            , fieldType = TypeAlias {aliasTyCon = __typeName $(proxyT alias), aliasArgs = aArgs, aliasWrappers}+            , fieldHidden = False+            })|]+      where+        fName = unpack fieldName+        fArgs = map (\(k, v) -> (unpack k, v)) fieldArgs+        aArgs = unpack <$> aliasArgs
src/Data/Morpheus/Execution/Internal/Declare.hs view
@@ -9,34 +9,78 @@  module Data.Morpheus.Execution.Internal.Declare   ( declareType+  , declareGQLT+  , tyConArgs   ) where +import           Data.Maybe                             (maybe)+import           Data.Text                              (unpack)+import           GHC.Generics                           (Generic) import           Language.Haskell.TH --- -- MORPHEUS-import           Data.Morpheus.Types.Internal.DataD (AppD (..), ConsD (..), FieldD (..), TypeD (..))-import           GHC.Generics                       (Generic)+import           Data.Morpheus.Execution.Internal.Utils (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.Resolver           (UnSubResolver)  type FUNC = (->) ------ declareType :: [Name] -> TypeD -> Dec-declareType derivingList TypeD {tName, tCons} =-  DataD [] (mkName tName) [] Nothing (map cons tCons) $ map derive (''Generic : derivingList)+declareType = declareGQLT False Nothing++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++tyConArgs :: DataTypeKind -> [String]+tyConArgs kindD+  | isOutputObject kindD || kindD == KindUnion = ["m"]+  | otherwise = []++-- declareType+declareGQLT :: Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec+declareGQLT namespace kindD derivingList TypeD {tName, tCons} =+  DataD [] (mkName tName) tVars Nothing (map cons tCons) $ map derive (''Generic : derivingList)+  where+    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 (mkName cName) (map genField cFields)+    cons ConsD {cName, cFields} = RecC (mkName cName) (map declareField cFields)       where-        genField FieldD {fieldNameD, fieldTypeD} = (mkName fieldNameD, defBang, genFieldT fieldTypeD)+        declareField DataField {fieldName, fieldArgsType, fieldType} = (fName, defBang, fiType)           where-            genFieldT (ListD td) = AppT (ConT ''[]) (genFieldT td)-            genFieldT (MaybeD td) = AppT (ConT ''Maybe) (genFieldT td)-            genFieldT (BaseD name) = ConT (mkName name)-            genFieldT (ResD arg mon td) = AppT (AppT arrowType argType) resultType+            fName+              | namespace = mkName (nameSpaceWith tName (unpack fieldName))+              | otherwise = mkName (unpack fieldName)+            fiType = genFieldT fieldArgsType               where-                argType = ConT $ mkName arg-                arrowType = ConT ''FUNC-                resultType = AppT (ConT $ mkName mon) (genFieldT td)+                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 ''FUNC+                ------------------------------------------------+                fType isResolver+                  | maybe False isSubscription kindD = AppT monadVar result+                  | isResolver = AppT monadVar result+                  | otherwise = result+                ------------------------------------------------+                result = declareTypeAlias (maybe False isSubscription kindD) fieldType
+ src/Data/Morpheus/Execution/Internal/Decode.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Data.Morpheus.Execution.Internal.Decode+  ( withObject+  , withMaybe+  , withList+  , withEnum+  , withUnion+  , decodeFieldWith+  , decodeObjectExpQ+  ) where++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 (..))++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++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++withList :: (Value -> Validation a) -> Value -> Validation [a]+withList decode (List li) = mapM decode li+withList _ isType         = internalTypeMismatch "List" isType++withEnum :: (Key -> Validation a) -> Value -> Validation a+withEnum decode (Enum value) = decode value+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"++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
src/Data/Morpheus/Execution/Server/Decode.hs view
@@ -11,172 +11,122 @@ {-# LANGUAGE UndecidableInstances  #-}  module Data.Morpheus.Execution.Server.Decode-  ( ArgumentsConstraint-  , decodeArguments+  ( decodeArguments+  , Decode(..)+  , DecodeObject(..)   ) where  import           Data.Proxy                                      (Proxy (..)) import           Data.Semigroup                                  ((<>))-import           Data.Text                                       (Text, pack)+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,-                                                                  WRAPPER)+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              (Value (..))------- GENERIC UNION----class DecodeInputUnion f where-  decodeUnion :: Value -> Validation (f a)-  unionTags :: Proxy f -> [Text]--instance (Datatype c, DecodeInputUnion f) => DecodeInputUnion (M1 D c f) where-  decodeUnion = fmap M1 . decodeUnion-  unionTags _ = unionTags (Proxy @f)--instance (Constructor c, DecodeInputUnion f) =>-         DecodeInputUnion (M1 C c f) where-  decodeUnion = fmap M1 . decodeUnion-  unionTags _ = unionTags (Proxy @f)--instance (Selector c, DecodeInputUnion f) => DecodeInputUnion (M1 S c f) where-  decodeUnion = fmap M1 . decodeUnion-  unionTags _ = unionTags (Proxy @f)--instance (DecodeInputUnion a, DecodeInputUnion b) =>-         DecodeInputUnion (a :+: b) where-  decodeUnion (Object pairs) =-    case lookup "tag" pairs of-      Nothing -> internalArgumentError "tag not found on Input Union"-      Just (Enum name) ->-        case lookup name pairs of-          Nothing ->-            internalArgumentError-              ("type \"" <> name <> "\" was not provided on object")-          -- Decodes first Matching Union Type Value-          Just value-            | [name] == l1Tags -> L1 <$> decodeUnion value-          -- Decodes last Matching Union Type Value-          Just value-            | [name] == r1Tags -> R1 <$> decodeUnion value-          Just _-            -- JUMPS to Next Union Pair-            | name `elem` r1Tags -> R1 <$> decodeUnion (Object pairs)-          Just _ ->-            internalArgumentError-              ("type \"" <> name <> "\" could not find in union")-        where l1Tags = unionTags $ Proxy @a-              r1Tags = unionTags $ Proxy @b-      Just _ -> internalArgumentError "tag must be Enum"-  decodeUnion _ = internalArgumentError "Expected Input Object Union!"-  unionTags _ = unionTags (Proxy @a) ++ unionTags (Proxy @b)--instance (GQLType a, Decode a (KIND a)) => DecodeInputUnion (K1 i a) where-  decodeUnion value = K1 <$> decode value-  unionTags _ = [__typeName (Proxy @a)]-------  GENERIC INPUT OBJECT AND ARGUMENTS----type ArgumentsConstraint a = (Generic a, DecodeInputObject (Rep a))--decodeArguments ::-     (Generic p, DecodeInputObject (Rep p)) => Arguments -> Validation p-decodeArguments args =-  to <$> decodeObject (Object $ fmap (\(x, y) -> (x, argumentValue y)) args)--class DecodeInputObject f where-  decodeObject :: Value -> Validation (f a)--instance DecodeInputObject U1 where-  decodeObject _ = pure U1--type Sel s = M1 S s--proxySelName ::-     forall s. Selector s-  => Proxy (M1 S s)-  -> Text-proxySelName _ = pack $ selName (undefined :: M1 S s f a)--instance (Selector s, DecodeInputObject f) => DecodeInputObject (M1 S s f) where-  decodeObject (Object object) = M1 <$> selectFromObject-    where-      selectorName = proxySelName (Proxy @(Sel s))-      selectFromObject =-        case lookup selectorName object of-          Nothing    -> internalArgumentError ("Missing Field: " <> selectorName)-          Just value -> decodeObject value-  decodeObject isType = internalTypeMismatch "InputObject" isType--instance DecodeInputObject f => DecodeInputObject (M1 D c f) where-  decodeObject = fmap M1 . decodeObject+import           Data.Morpheus.Types.Internal.Value              (Object, Value (..)) -instance DecodeInputObject f => DecodeInputObject (M1 C c f) where-  decodeObject = fmap M1 . decodeObject+-- | Decode GraphQL query arguments and input values+class Decode a where+  decode :: Value -> Validation a -instance (DecodeInputObject f, DecodeInputObject g) =>-         DecodeInputObject (f :*: g) where-  decodeObject gql = (:*:) <$> decodeObject gql <*> decodeObject gql+instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where+  decode = decodeKind (Proxy @(KIND a)) -instance (Decode a (KIND a)) => DecodeInputObject (K1 i a) where-  decodeObject = fmap K1 . decode+instance Decode a => Decode (Maybe a) where+  decode = withMaybe decode -decode ::-     forall a. Decode a (KIND a)-  => Value-  -> Validation a-decode = __decode (Proxy @(KIND a))+instance Decode a => Decode [a] where+  decode = withList decode --- | Decode GraphQL query arguments and input values-class Decode a (b :: GQL_KIND) where-  __decode :: Proxy b -> Value -> Validation a+-- | Decode GraphQL type with Specific Kind+class DecodeKind (kind :: GQL_KIND) a where+  decodeKind :: Proxy kind -> Value -> Validation a --- -- SCALAR----instance (GQLScalar a) => Decode a SCALAR where-  __decode _ value =+instance (GQLScalar a) => DecodeKind SCALAR a where+  decodeKind _ value =     case toScalar value >>= parseValue of       Right scalar      -> return scalar       Left errorMessage -> internalTypeMismatch errorMessage value --- -- ENUM----instance (Generic a, EnumRep (Rep a)) => Decode a ENUM where-  __decode _ (Enum value) = to <$> decodeEnum value-  __decode _ isType       = internalTypeMismatch "Enum" isType+instance (Generic a, EnumRep (Rep a)) => DecodeKind ENUM a where+  decodeKind _ = withEnum (fmap to . decodeEnum) --- -- INPUT_OBJECT----instance (Generic a, DecodeInputObject (Rep a)) => Decode a INPUT_OBJECT where-  __decode _ (Object x) = to <$> decodeObject (Object x)-  __decode _ isType     = internalTypeMismatch "InputObject" isType+instance DecodeObject a => DecodeKind INPUT_OBJECT a where+  decodeKind _ = withObject decodeObject --- -- INPUT_UNION----instance (Generic a, DecodeInputUnion (Rep a)) => Decode a INPUT_UNION where-  __decode _ (Object x) = to <$> decodeUnion (Object x)-  __decode _ isType     = internalTypeMismatch "InputObject" isType+instance (Generic a, GDecode (Rep a)) => DecodeKind INPUT_UNION a where+  decodeKind _ = withObject (fmap to . decodeUnion) +-- GENERIC+decodeArguments :: DecodeObject p => Arguments -> Validation p+decodeArguments = decodeObject . fmap toObject+  where+    toObject (x, y) = (x, argumentValue y)++class DecodeObject a where+  decodeObject :: Object -> Validation a++instance {-# OVERLAPPABLE #-} (Generic a, GDecode (Rep a)) => DecodeObject a where+  decodeObject = fmap to . __decodeObject . Object+ ----- WRAPPERS: Maybe, List+-- GENERICS ---instance Decode a (KIND a) => Decode (Maybe a) WRAPPER where-  __decode _ Null = pure Nothing-  __decode _ x    = Just <$> decode x+class GDecode f where+  unionTags :: Proxy f -> [Key]+  decodeUnion :: Object -> Validation (f a)+  __decodeObject :: Value -> Validation (f a) -instance Decode a (KIND a) => Decode [a] WRAPPER where-  __decode _ (List li) = mapM decode li-  __decode _ isType    = internalTypeMismatch "List" isType+instance GDecode U1 where+  unionTags _ = []+  __decodeObject _ = pure U1+  decodeUnion _ = pure U1++-- 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+  __decodeObject = fmap (M1 . K1) . decodeRec+    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+  unionTags _ = unionTags (Proxy @f)+  __decodeObject = fmap M1 . __decodeObject++instance (Constructor c, GDecode f) => GDecode (M1 C c f) where+  decodeUnion = fmap M1 . decodeUnion+  unionTags _ = unionTags (Proxy @f)+  __decodeObject = fmap M1 . __decodeObject++instance (GDecode f, GDecode g) => GDecode (f :*: g) where+  __decodeObject gql = (:*:) <$> __decodeObject gql <*> __decodeObject gql++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+  unionTags _ = unionTags (Proxy @a) ++ unionTags (Proxy @b)
src/Data/Morpheus/Execution/Server/Encode.hs view
@@ -16,333 +16,220 @@   ( EncodeCon   , EncodeMutCon   , EncodeSubCon+  , GResolver(..)+  , Encode(..)   , encodeQuery-  , encodeMut-  , encodeSub+  , encodeOperation+  , ObjectResolvers(..)+  , OBJ_RES   ) where  import           Control.Monad                                   ((>=>))-import           Control.Monad.Trans.Except+import           Control.Monad.Except                            (liftEither, runExceptT, withExceptT) import           Data.Map                                        (Map) import qualified Data.Map                                        as M (toList) import           Data.Maybe                                      (fromMaybe) import           Data.Proxy                                      (Proxy (..)) import           Data.Set                                        (Set) import qualified Data.Set                                        as S (toList)-import           Data.Text                                       (Text, pack)-import           Data.Typeable                                   (Typeable)+import           Data.Text                                       (pack) import           GHC.Generics  -- MORPHEUS import           Data.Morpheus.Error.Internal                    (internalErrorT)-import           Data.Morpheus.Error.Selection                   (fieldNotResolved, subfieldsNotSelected)-import           Data.Morpheus.Execution.Server.Decode           (ArgumentsConstraint, decodeArguments)+import           Data.Morpheus.Error.Selection                   (resolverError, subfieldsNotSelected)+import           Data.Morpheus.Execution.Server.Decode           (DecodeObject, decodeArguments) import           Data.Morpheus.Execution.Server.Generics.EnumRep (EnumRep (..))-import           Data.Morpheus.Kind                              (ENUM, GQL_KIND, OBJECT, SCALAR, UNION, WRAPPER)+import           Data.Morpheus.Kind                              (Context (..), ENUM, GQL_KIND, OBJECT, SCALAR, UNION,+                                                                  VContext (..)) import           Data.Morpheus.Types.Custom                      (MapKind, Pair (..), mapKindFromList) import           Data.Morpheus.Types.GQLScalar                   (GQLScalar (..))-import           Data.Morpheus.Types.GQLType                     (GQLType (KIND, __typeName))+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 (..), SelectionSet)-import           Data.Morpheus.Types.Internal.Base               (Position)-import           Data.Morpheus.Types.Internal.Stream             (PublishStream, StreamState (..), StreamT (..),-                                                                  SubscribeStream)+import           Data.Morpheus.Types.Internal.Base               (Key)+import           Data.Morpheus.Types.Internal.Stream             (PublishStream, StreamT (..), SubscribeStream,+                                                                  initExceptStream, injectEvents) import           Data.Morpheus.Types.Internal.Validation         (GQLErrors, ResolveT, failResolveT)-import           Data.Morpheus.Types.Internal.Value              (ScalarValue (..), Value (..))-import           Data.Morpheus.Types.Resolver                    (Event (..), Resolver, SubResolveT, SubResolver)--type EncodeOperator m a value-   = Resolver m a -> ValidOperation -> m (Either GQLErrors value)---- EXPORT --------------------------------------------------------type EncodeCon m a v-   = (Generic a, Typeable a, ObjectFieldResolvers (Rep a) (ResolveT m v))+import           Data.Morpheus.Types.Internal.Value              (GQLValue (..), Value (..))+import           Data.Morpheus.Types.Resolver                    (Event (..), Resolver, SubResolveT, SubResolver (..)) -type EncodeMutCon m event con mut-   = EncodeCon (PublishStream m event con) mut Value+class Encode resolver value where+  encode :: resolver -> (Key, Selection) -> value -type EncodeSubCon m event con sub-   = EncodeCon (SubscribeStream m event) sub (Event event con -> ResolveT m Value)+instance {-# OVERLAPPABLE #-} EncodeKind (KIND a) a res => Encode a res where+  encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a) -encodeQuery ::-     (Monad m, EncodeCon m schema Value, EncodeCon m a Value)-  => schema-  -> EncodeOperator m a Value-encodeQuery types rootResolver operator@Operation {operationSelection} =-  runExceptT-    (fmap resolversBy (operatorToResolveT operator rootResolver) >>=-     resolveBySelection operationSelection . (++) (resolversBy types))+-- MAYBE+instance (GQLValue value, Encode a value) => Encode (Maybe a) value where+  encode Nothing      = const gqlNull+  encode (Just value) = encode value -encodeMut :: (Monad m, EncodeCon m a Value) => EncodeOperator m a Value-encodeMut = encodeOperator resolveBySelection+--  Tuple  (a,b)+instance Encode (Pair k v) value => Encode (k, v) value where+  encode (key, value) = encode (Pair key value) -encodeSub ::-     (Monad m, EncodeSubCon m event con a)-  => EncodeOperator (SubscribeStream m event) a (Event event con -> ResolveT m Value)-encodeSub = encodeOperator (flip resolveSelection)-  where-    resolveSelection resolvers =-      fmap toObj . mapM (selectResolver (const $ pure Null) resolvers)-      where-        toObj pairs args =-          Object <$> mapM (\(key, valFunc) -> (key, ) <$> valFunc args) pairs+--  Set+instance Encode [a] value => Encode (Set a) value where+  encode = encode . S.toList ----------------------------------------------------------------  OBJECT--- | Derives resolvers by object fields-class ObjectFieldResolvers f o where-  objectFieldResolvers :: f a -> [(Text, (Text, Selection) -> o)]+--  Map+instance (Eq k, Monad m, Encode (MapKind k v (Resolver m)) (ResolveT m value)) =>+         Encode (Map k v) (ResolveT m value) where+  encode value = encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver m)) -instance ObjectFieldResolvers U1 res where-  objectFieldResolvers _ = []+-- LIST []+instance (Monad m, GQLValue value, Encode a (m value)) => Encode [a] (m value) where+  encode list query = gqlList <$> traverse (`encode` query) list -instance (Selector s, Encoder a (KIND a) res) =>-         ObjectFieldResolvers (M1 S s (K1 s2 a)) res where-  objectFieldResolvers m@(M1 (K1 src)) = [(pack $ selName m, encode src)]+--  GQL a -> b+instance (DecodeObject a, Monad m, Encode b (ResolveT m value)) => Encode (a -> b) (ResolveT m value) where+  encode resolver selection = decodeArgs selection >>= (`encode` selection) . resolver+    where+      decodeArgs :: (Key, Selection) -> ResolveT m a+      decodeArgs = liftEither . decodeArguments . selectionArguments . snd -instance ObjectFieldResolvers f res => ObjectFieldResolvers (M1 D c f) res where-  objectFieldResolvers (M1 src) = objectFieldResolvers src+-- GQL Either Resolver Monad+instance (Monad m, Encode a (ResolveT m value)) => Encode (Either String a) (ResolveT m value) where+  encode resolver = (`encodeResolver` liftEither resolver) -instance ObjectFieldResolvers f res => ObjectFieldResolvers (M1 C c f) res where-  objectFieldResolvers (M1 src) = objectFieldResolvers src+--  GQL ExceptT Resolver Monad+instance (Monad m, Encode b (ResolveT m value)) => Encode (Resolver m b) (ResolveT m value) where+  encode = flip encodeResolver -instance (ObjectFieldResolvers f res, ObjectFieldResolvers g res) =>-         ObjectFieldResolvers (f :*: g) res where-  objectFieldResolvers (a :*: b) =-    objectFieldResolvers a ++ objectFieldResolvers b+-- GQL Mutation Resolver Monad+instance (Monad m, Encode b (ResolveT m value)) => Encode (Resolver m b) (ResolveT (StreamT m c) value) where+  encode resolver = injectEvents [] . encode resolver ------ UNION----class UnionResolvers f result where-  unionResolvers :: f a -> (Text, (Text, Selection) -> result)+-- GQL Subscription Resolver Monad+instance (Monad m, Encode b (ResolveT m Value)) => Encode (SubResolver m e c b) (SubResolveT m e c Value) where+  encode resolver selection = handleResolver resolver+    where+      handleResolver SubResolver {subChannels, subResolver} =+        initExceptStream [subChannels] (encodeResolver selection . subResolver) -instance UnionResolvers f res => UnionResolvers (M1 S s f) res where-  unionResolvers (M1 x) = unionResolvers x+-- ENCODE GQL KIND+class EncodeKind (kind :: GQL_KIND) a value where+  encodeKind :: VContext kind a -> (Key, Selection) -> value -instance UnionResolvers f res => UnionResolvers (M1 D c f) res where-  unionResolvers (M1 x) = unionResolvers x+-- SCALAR+instance (GQLScalar a, GQLValue value) => EncodeKind SCALAR a value where+  encodeKind = pure . gqlScalar . serialize . unVContext -instance UnionResolvers f res => UnionResolvers (M1 C c f) res where-  unionResolvers (M1 x) = unionResolvers x+-- ENUM+instance (Generic a, EnumRep (Rep a), GQLValue value) => EncodeKind ENUM a value where+  encodeKind = pure . gqlString . encodeRep . from . unVContext -instance (UnionResolvers a res, UnionResolvers b res) =>-         UnionResolvers (a :+: b) res where-  unionResolvers (L1 x) = unionResolvers x-  unionResolvers (R1 x) = unionResolvers x+--  OBJECT+instance (Monad m, EncodeCon m a value, GQLValue value) => EncodeKind OBJECT a (ResolveT m value) where+  encodeKind (VContext value) (_, Selection {selectionRec = SelectionSet selection}) =+    resolveFields selection (__typenameResolver : objectResolvers (Proxy :: Proxy (CUSTOM a)) value)+    where+      __typenameResolver = ("__typename", const $ pure $ gqlString $ __typeName (Proxy @a))+  encodeKind _ (key, Selection {selectionPosition}) = failResolveT $ subfieldsNotSelected key "" selectionPosition -type ObjectConstraint a m-   = ( Monad m-     , Generic a-     , GQLType a-     , ObjectFieldResolvers (Rep a) (ResolveT m Value))+-- UNION+instance (Monad m, GQL_RES a, GResolver UNION (Rep a) (ResolveT m value)) => EncodeKind UNION a (ResolveT m value) 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 _ _ = internalErrorT "union Resolver only should recieve UnionSelection" -type UnionConstraint a m-   = (Monad m, Generic a, GQLType a, UnionResolvers (Rep a) (ResolveT m Value))+-- Types & Constrains -------------------------------------------------------+type GQL_RES a = (Generic a, GQLType a) -type EnumConstraint a = (Generic a, EnumRep (Rep a))+type EncodeOperator m a value = Resolver m a -> ValidOperation -> m (Either GQLErrors value) -newtype WithGQLKind a (b :: GQL_KIND) =-  WithGQLKind-    { resolverValue :: a-    }+type OBJ_RES m a value = ObjectResolvers (CUSTOM a) a (ResolveT m value) -type GQLKindOf a = WithGQLKind a (KIND a)+type EncodeCon m a value = (GQL_RES a, OBJ_RES m a value) -encode ::-     forall a result. Encoder a (KIND a) result-  => a-  -> (Text, Selection)-  -> result-encode resolver = __encode (WithGQLKind resolver :: GQLKindOf a)+type EncodeMutCon m event con mut = EncodeCon (PublishStream m event con) mut Value -class Encoder a kind result where-  __encode :: WithGQLKind a kind -> (Text, Selection) -> result+type EncodeSubCon m event con sub = EncodeCon (SubscribeStream m event) sub (Event event con -> ResolveT m Value) -type ResValue m = (ResolveT m Value)+type FieldRes m value = (Key, (Key, Selection) -> ResolveT m value) ------ SCALAR----instance (GQLScalar a, Monad m) => Encoder a SCALAR (ResValue m) where-  __encode = pure . pure . Scalar . serialize . resolverValue+type family GRes (kind :: GQL_KIND) value :: * ------ ENUM----instance (EnumConstraint a, Monad m) => Encoder a ENUM (ResValue m) where-  __encode = pure . pure . Scalar . String . encodeRep . from . resolverValue+type instance GRes OBJECT v = [(Key, (Key, Selection) -> v)] ------  OBJECTS----instance ObjectConstraint a m => Encoder a OBJECT (ResValue m) where-  __encode (WithGQLKind value) (_, Selection {selectionRec = SelectionSet selection'}) =-    resolveBySelection selection' (__typenameResolver : resolversBy value)-    where-      __typenameResolver =-        ("__typename", const $ return $ Scalar $ String $ __typeName (Proxy @a))-  __encode _ (key, Selection {selectionPosition}) =-    failResolveT $ subfieldsNotSelected key "" selectionPosition+type instance GRes UNION v = (Key, (Key, Selection) -> v) --- | Resolves and encodes UNION,--- Handles all operators: Query, Mutation and Subscription,-instance UnionConstraint a m => Encoder a UNION (ResValue m) where-  __encode (WithGQLKind value) (key', sel@Selection {selectionRec = UnionSelection selections'}) =-    resolver (key', sel {selectionRec = SelectionSet lookupSelection})-    where-      lookupSelection :: SelectionSet-      -- SPEC: if there is no any fragment that supports current object Type GQL returns {}-      lookupSelection = fromMaybe [] $ lookup typeName selections'-      (typeName, resolver) = unionResolvers (from value)-  __encode _ _ =-    internalErrorT "union Resolver only should recieve UnionSelection"+--- GENERICS ------------------------------------------------+class ObjectResolvers (custom :: Bool) a value where+  objectResolvers :: Proxy custom -> a -> [(Key, (Key, Selection) -> value)] -instance (GQLType a, Encoder a (KIND a) result) =>-         UnionResolvers (K1 s a) result where-  unionResolvers (K1 src) = (__typeName (Proxy @a), encode src)+instance (Generic a, GResolver OBJECT (Rep a) value) => ObjectResolvers 'False a value where+  objectResolvers _ = getResolvers (Context :: Context OBJECT value) . from ------  RESOLVERS------ | Handles all operators: Query, Mutation and Subscription,--- if you use it with Mutation or Subscription all effects inside will be lost-instance (ArgumentsConstraint a, Monad m, Encoder b (KIND b) (ResValue m)) =>-         Encoder (a -> Resolver m b) WRAPPER (ResValue m) where-  __encode (WithGQLKind resolver) selection =-    decodeArgs selection >>= encodeResolver selection . resolver+unionResolver :: (Generic a, GResolver UNION (Rep a) value) => a -> (Key, (Key, Selection) -> value)+unionResolver = getResolvers (Context :: Context UNION value) . from --- packs Monad in StreamMonad-instance (Monad m, Encoder a (KIND a) (ResValue m), ArgumentsConstraint p) =>-         Encoder (p -> Either String a) WRAPPER (ResValue m) where-  __encode (WithGQLKind resolver) selection =-    decodeArgs selection >>=-    encodeResolver selection . (ExceptT . pure . resolver)+-- | Derives resolvers for OBJECT and UNION+class GResolver (kind :: GQL_KIND) f value where+  getResolvers :: Context kind value -> f a -> GRes kind value --- packs Monad in StreamMonad-instance (ArgumentsConstraint a, Monad m, Encoder b (KIND b) (ResValue m)) =>-         Encoder (a -> Resolver m b) WRAPPER (ResValue (StreamT m c)) where-  __encode resolver selection =-    ExceptT $-    StreamT $ StreamState [] <$> runExceptT (__encode resolver selection)+instance GResolver kind f value => GResolver kind (M1 D c f) value where+  getResolvers context (M1 src) = getResolvers context src -instance (ArgumentsConstraint a, Monad m, Encoder b (KIND b) (ResValue m)) =>-         Encoder (a -> SubResolver m e c b) WRAPPER (SubResolveT m e c Value) where-  __encode (WithGQLKind resolver) selection =-    decodeArgs selection >>= handleResolver . resolver-    where-      handleResolver Event {channels, content} =-        ExceptT $-        StreamT $-        pure $-        StreamState [channels] (Right $ encodeResolver selection . content)+instance GResolver kind f value => GResolver kind (M1 C c f) value where+  getResolvers context (M1 src) = getResolvers context src ------ MAYBE----instance (Monad m, Encoder a (KIND a) (ResValue m)) =>-         Encoder (Maybe a) WRAPPER (ResValue m) where-  __encode (WithGQLKind Nothing)      = const $ pure Null-  __encode (WithGQLKind (Just value)) = encode value+-- OBJECT+instance GResolver OBJECT U1 value where+  getResolvers _ _ = [] ------ LIST----instance (Monad m, Encoder a (KIND a) (ResValue m)) =>-         Encoder [a] WRAPPER (ResValue m) where-  __encode (WithGQLKind list) query =-    List <$> mapM (`__encode` query) (map WithGQLKind list :: [GQLKindOf a])+instance (Selector s, GQLType a, Encode a value) => GResolver OBJECT (M1 S s (K1 s2 a)) value where+  getResolvers _ m@(M1 (K1 src)) = [(pack (selName m), encode src)] ------  Tuple----instance Encoder (Pair k v) OBJECT (ResValue m) =>-         Encoder (k, v) WRAPPER (ResValue m) where-  __encode (WithGQLKind (key, value)) = encode (Pair key value)+instance (GResolver OBJECT f value, GResolver OBJECT g value) => GResolver OBJECT (f :*: g) value where+  getResolvers context (a :*: b) = getResolvers context a ++ getResolvers context b ------  Set----instance Encoder [a] WRAPPER result => Encoder (Set a) WRAPPER result where-  __encode (WithGQLKind dataSet) = encode (S.toList dataSet)+-- UNION+instance (Selector s, GQLType a, Encode a value) => GResolver UNION (M1 S s (K1 s2 a)) value where+  getResolvers _ (M1 (K1 src)) = (__typeName (Proxy @a), encode src) ------  Map----instance (Eq k, Monad m, Encoder (MapKind k v (Resolver m)) OBJECT (ResValue m)) =>-         Encoder (Map k v) WRAPPER (ResValue m) where-  __encode (WithGQLKind value) =-    encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver m))+instance (GResolver UNION a value, GResolver UNION b value) => GResolver UNION (a :+: b) value where+  getResolvers context (L1 x) = getResolvers context x+  getResolvers context (R1 x) = getResolvers context x  ----- HELPERS -----------------------------type ResolveSel result-   = SelectionSet -> [(Text, (Text, Selection) -> result)] -> result+encodeQuery ::+     forall m a schema. (GQL_RES a, GQL_RES schema, Monad m, EncodeCon m schema Value, EncodeCon m a Value)+  => schema+  -> EncodeOperator m a Value+encodeQuery schema = encodeOperationWith (objectResolvers (Proxy :: Proxy (CUSTOM schema)) schema) -resolverToResolveT ::-     Monad m => Position -> Text -> Resolver m a -> ResolveT m a-resolverToResolveT pos name = ExceptT . toResolveM+encodeOperation :: (Monad m, GQL_RES a, EncodeCon m a value, GQLValue value) => EncodeOperator m a value+encodeOperation = encodeOperationWith []++encodeOperationWith ::+     forall m a value. (Monad m, GQL_RES a, GQLValue value, EncodeCon m a value)+  => [FieldRes m value]+  -> EncodeOperator m a value+encodeOperationWith externalRes rootResolver Operation {operationSelection, operationPosition, operationName} =+  runExceptT $+  operationResolveT >>=+  resolveFields operationSelection . (++) externalRes . objectResolvers (Proxy :: Proxy (CUSTOM a))   where-    toResolveM :: Monad m => Resolver m a -> m (Either GQLErrors a)-    toResolveM resolver = runExceptT resolver >>= runExceptT . liftEither-      where-        liftEither :: Monad m => Either String a -> ResolveT m a-        liftEither (Left message) =-          failResolveT $ fieldNotResolved pos name (pack message)-        liftEither (Right value) = pure value+    operationResolveT = withExceptT (resolverError operationPosition operationName) rootResolver -encodeResolver ::-     (Monad m, Encoder a (KIND a) (ResValue m))-  => (Text, Selection)-  -> Resolver m a-  -> ResValue m+encodeResolver :: (Monad m, Encode a (ResolveT m res)) => (Key, Selection) -> Resolver m a -> ResolveT m res encodeResolver selection@(fieldName, Selection {selectionPosition}) =-  resolverToResolveT selectionPosition fieldName >=> (`encode` selection)--decodeArgs ::-     (Monad m, ArgumentsConstraint a) => (Text, Selection) -> ResolveT m a-decodeArgs (_, Selection {selectionArguments}) =-  ExceptT $ pure $ decodeArguments selectionArguments--operatorToResolveT :: Monad m => ValidOperation -> Resolver m a -> ResolveT m a-operatorToResolveT Operation {operationPosition, operationName} =-  resolverToResolveT operationPosition operationName--encodeOperator ::-     (Monad m, EncodeCon m a v)-  => ResolveSel (ResolveT m v)-  -> EncodeOperator m a v-encodeOperator resSel rootResolver operation@Operation {operationSelection} =-  runExceptT-    (operatorToResolveT operation rootResolver >>=-     resSel operationSelection . resolversBy)--resolveBySelection :: Monad m => ResolveSel (ResolveT m Value)-resolveBySelection selection resolvers =-  Object <$> mapM (selectResolver Null resolvers) selection+  withExceptT (resolverError selectionPosition fieldName) >=> (`encode` selection) -selectResolver ::-     Monad m-  => a-  -> [(Text, (Text, Selection) -> m a)]-  -> (Text, Selection)-  -> m (Text, a)-selectResolver defaultValue resolvers (key, selection) =-  case selectionRec selection of-    SelectionAlias name selectionRec ->-      unwrapMonadTuple (key, lookupResolver name (selection {selectionRec}))-    _ -> unwrapMonadTuple (key, lookupResolver key selection)+resolveFields :: (Monad m, GQLValue a) => SelectionSet -> [FieldRes m a] -> ResolveT m a+resolveFields selectionSet resolvers = gqlObject <$> traverse selectResolver selectionSet   where-    unwrapMonadTuple :: Monad m => (Text, m a) -> m (Text, a)-    unwrapMonadTuple (text, ioa) = ioa >>= \x -> pure (text, x)-    --------------------------------------------------------------    lookupResolver resolverKey sel =-      (fromMaybe (const $ return $defaultValue) $ lookup resolverKey resolvers)-        (key, sel)--resolversBy ::-     (Generic a, ObjectFieldResolvers (Rep a) result)-  => a-  -> [(Text, (Text, Selection) -> result)]-resolversBy = objectFieldResolvers . from---------------------------------------------+    selectResolver (key, selection) =+      (key, ) <$>+      case selectionRec selection of+        SelectionAlias name selectionRec -> lookupRes name (selection {selectionRec})+        _                                -> lookupRes key selection+        -------------------------------------------------------------+      where+        lookupRes resKey sel = (fromMaybe (const $ return gqlNull) $ lookup resKey resolvers) (key, sel)
src/Data/Morpheus/Execution/Server/Introspect.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DefaultSignatures     #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -13,10 +15,13 @@ {-# LANGUAGE UndecidableInstances  #-}  module Data.Morpheus.Execution.Server.Introspect-  ( introspectOutputType-  , TypeUpdater-  , ObjectRep(..)+  ( TypeUpdater+  , Introspect(..)+  , ObjectFields(..)+  , IntroCon   , resolveTypes+  , updateLib+  , buildType   ) where  import           Control.Monad                                   (foldM)@@ -31,349 +36,210 @@ -- MORPHEUS import           Data.Morpheus.Error.Schema                      (nameCollisionError) import           Data.Morpheus.Execution.Server.Generics.EnumRep (EnumRep (..))-import           Data.Morpheus.Kind                              (ENUM, INPUT_OBJECT, INPUT_UNION, OBJECT, SCALAR,-                                                                  UNION, WRAPPER)+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 (..), DataFullType (..),-                                                                  DataInputField, DataLeaf (..), DataType (..),-                                                                  DataTypeLib, DataTypeWrapper (..), DataValidator,-                                                                  defineType, isTypeDefined)+                                                                  DataLeaf (..), DataTyCon (..), DataTypeLib,+                                                                  TypeAlias (..), defineType, isTypeDefined,+                                                                  toListField, toNullableField) import           Data.Morpheus.Types.Internal.Validation         (SchemaValidation)-import           Data.Morpheus.Types.Resolver                    (Resolver, SubResolver) -type SelOf s = M1 S s (Rec0 ()) ()--type RecSel s a = M1 S s (Rec0 a)--type TypeUpdater = DataTypeLib -> SchemaValidation DataTypeLib-------  GENERIC UNION----class UnionRep f t where-  possibleTypes :: Proxy f -> Proxy t -> [(DataField (), TypeUpdater)]--instance UnionRep f t => UnionRep (M1 D x f) t where-  possibleTypes _ = possibleTypes (Proxy @f)--instance UnionRep f t => UnionRep (M1 C x f) t where-  possibleTypes _ = possibleTypes (Proxy @f)--instance (UnionRep a t, UnionRep b t) => UnionRep (a :+: b) t where-  possibleTypes _ x = possibleTypes (Proxy @a) x ++ possibleTypes (Proxy @b) x-------  GENERIC OBJECT: INPUT and OUTPUT plus ARGUMENTS----resolveTypes :: DataTypeLib -> [TypeUpdater] -> SchemaValidation DataTypeLib-resolveTypes = foldM (&)--class ObjectRep rep t where-  objectFieldTypes :: Proxy rep -> [((Text, DataField t), TypeUpdater)]--instance ObjectRep f t => ObjectRep (M1 D x f) t where-  objectFieldTypes _ = objectFieldTypes (Proxy @f)--instance ObjectRep f t => ObjectRep (M1 C x f) t where-  objectFieldTypes _ = objectFieldTypes (Proxy @f)--instance (ObjectRep a t, ObjectRep b t) => ObjectRep (a :*: b) t where-  objectFieldTypes _ =-    objectFieldTypes (Proxy @a) ++ objectFieldTypes (Proxy @b)--instance ObjectRep U1 t where-  objectFieldTypes _ = []---- class Types class-type GQL_TYPE a = (Generic a, GQLType a)--type EnumConstraint a = (GQL_TYPE a, EnumRep (Rep a))--type InputObjectConstraint a = (GQL_TYPE a, ObjectRep (Rep a) ())--type ObjectConstraint a = (GQL_TYPE a, ObjectRep (Rep a) DataArguments)--scalarTypeOf :: GQLType a => DataValidator -> Proxy a -> DataFullType-scalarTypeOf validator = Leaf . CustomScalar . buildType validator--enumTypeOf :: GQLType a => [Text] -> Proxy a -> DataFullType-enumTypeOf tags' = Leaf . LeafEnum . buildType tags'--type InputType = ()--type OutputType = DataArguments+type IntroCon a = (GQLType a, ObjectFields (CUSTOM a) a) -type InputOf t = Context t (KIND t) InputType+-- |  Generates internal GraphQL Schema for query validation and introspection rendering+class Introspect a where+  field :: proxy a -> Text -> DataField+  introspect :: proxy a -> TypeUpdater+  -----------------------------------------------+  default field :: GQLType a =>+    proxy a -> Text -> DataField+  field _ = buildField (Proxy @a) [] -type OutputOf t = Context t (KIND t) OutputType+instance {-# OVERLAPPABLE #-} (GQLType a, IntrospectKind (KIND a) a) => Introspect a where+  introspect _ = introspectKind (Context :: Context (KIND a) a) -introspectOutputType ::-     forall a. Introspect a (KIND a) OutputType-  => Proxy a-  -> TypeUpdater-introspectOutputType _ = introspect (Context :: OutputOf a)+-- Maybe+instance Introspect a => Introspect (Maybe a) where+  field _ = toNullableField . field (Proxy @a)+  introspect _ = introspect (Proxy @a) --- | context , like Proxy with multiple parameters--- contains types of :--- * 'a': actual gql type--- * 'kind': object, scalar, enum ...--- * 'args': InputType | OutputType-data Context a kind args =-  Context+-- List+instance Introspect a => Introspect [a] where+  field _ = toListField . field (Proxy @a)+  introspect _ = introspect (Proxy @a) -buildField :: GQLType a => Proxy a -> t -> Text -> DataField t-buildField proxy fieldArgs fieldName =-  DataField-    { fieldName-    , fieldArgs-    , fieldTypeWrappers = [NonNullType]-    , fieldType = __typeName proxy-    , fieldHidden = False-    }+-- Tuple+instance Introspect (Pair k v) => Introspect (k, v) where+  field _ = field (Proxy @(Pair k v))+  introspect _ = introspect (Proxy @(Pair k v)) -buildType :: GQLType a => t -> Proxy a -> DataType t-buildType typeData proxy =-  DataType-    { typeName = __typeName proxy-    , typeFingerprint = __typeFingerprint proxy-    , typeDescription = description proxy-    , typeVisibility = __typeVisibility proxy-    , typeData-    }+-- Set+instance Introspect [a] => Introspect (Set a) where+  field _ = field (Proxy @[a])+  introspect _ = introspect (Proxy @[a]) -updateLib ::-     GQLType a-  => (Proxy a -> DataFullType)-  -> [TypeUpdater]-  -> Proxy a-  -> TypeUpdater-updateLib typeBuilder stack proxy lib' =-  case isTypeDefined (__typeName proxy) lib' of-    Nothing ->-      resolveTypes (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)+-- Map+instance Introspect (MapKind k v Maybe) => Introspect (Map k v) where+  field _ = field (Proxy @(MapKind k v Maybe))+  introspect _ = introspect (Proxy @(MapKind k v Maybe)) --- |   Generates internal GraphQL Schema for query validation and introspection rendering--- * 'kind': object, scalar, enum ...--- * 'args': type of field arguments---    * '()' for 'input values' , they are just JSON properties and does not have any argument---    * 'DataArguments' for field Resolvers Types, where 'DataArguments' is type of arguments-class Introspect a kind args where-  __field :: Context a kind args -> Text -> DataField args-    --   generates data field representation of object field-    --   according to parameter 'args' it could be-    --   * input object field: if args is '()'-    --   * object: if args is 'DataArguments'-  introspect :: Context a kind args -> TypeUpdater -- Generates internal GraphQL Schema+-- 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 = resolveTypes typeLib (introspect (Proxy @b) : argTypes)+    where+      argTypes :: [TypeUpdater]+      argTypes = snd $ objectFields (Proxy :: Proxy 'False) (Proxy @a) -type OutputConstraint a = Introspect a (KIND a) DataArguments+-- | Introspect With specific Kind: 'kind': object, scalar, enum ...+class IntrospectKind (kind :: GQL_KIND) a where+  introspectKind :: Context kind a -> TypeUpdater -- Generates internal GraphQL Schema --- -- SCALAR----instance (GQLScalar a, GQLType a) => Introspect a SCALAR InputType where-  __field _ = buildField (Proxy @a) ()-  introspect _ =-    updateLib (scalarTypeOf (scalarValidator $ Proxy @a)) [] (Proxy @a)--instance (GQLScalar a, GQLType a) => Introspect a SCALAR OutputType where-  __field _ = buildField (Proxy @a) []-  introspect _ =-    updateLib (scalarTypeOf (scalarValidator $ Proxy @a)) [] (Proxy @a)+instance (GQLType a, GQLScalar a) => IntrospectKind SCALAR a where+  introspectKind _ = updateLib scalarType [] (Proxy @a)+    where+      scalarType = Leaf . CustomScalar . buildType (scalarValidator (Proxy @a)) --- -- ENUM----instance EnumConstraint a => Introspect a ENUM InputType where-  __field _ = buildField (Proxy @a) ()-  introspect _ = introspectEnum (Context :: InputOf a)--instance EnumConstraint a => Introspect a ENUM OutputType where-  __field _ = buildField (Proxy @a) []-  introspect _ = introspectEnum (Context :: OutputOf a)--introspectEnum ::-     forall a f. (GQLType a, EnumRep (Rep a))-  => Context a (KIND a) f-  -> TypeUpdater-introspectEnum _ =-  updateLib (enumTypeOf $ enumTags (Proxy @(Rep a))) [] (Proxy @a)+instance (GQL_TYPE a, EnumRep (Rep a)) => IntrospectKind ENUM a where+  introspectKind _ = updateLib enumType [] (Proxy @a)+    where+      enumType = Leaf . LeafEnum . buildType (enumTags (Proxy @(Rep a))) ------ OBJECTS , INPUT_OBJECT----instance InputObjectConstraint a => Introspect a INPUT_OBJECT InputType where-  __field _ = buildField (Proxy @a) ()-  introspect _ = updateLib (InputObject . buildType fields') stack' (Proxy @a)+-- INPUT_OBJECT+instance (GQL_TYPE a, ObjectFields (CUSTOM a) a) => IntrospectKind INPUT_OBJECT a where+  introspectKind _ = updateLib (InputObject . buildType fields) types (Proxy @a)     where-      (fields', stack') = unzip $ objectFieldTypes (Proxy @(Rep a))+      (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a) -instance ObjectConstraint a => Introspect a OBJECT OutputType where-  __field _ = buildField (Proxy @a) []-  introspect _ =-    updateLib-      (OutputObject . buildType (__typename : fields'))-      stack'-      (Proxy @a)+-- OBJECTS+instance (GQL_TYPE a, ObjectFields (CUSTOM a) a) => IntrospectKind OBJECT a where+  introspectKind _ = updateLib (OutputObject . buildType (__typename : fields)) types (Proxy @a)     where       __typename =         ( "__typename"         , DataField             { fieldName = "__typename"             , fieldArgs = []-            , fieldTypeWrappers = []-            , fieldType = "String"+            , fieldArgsType = Nothing+            , fieldType = buildAlias "String"             , fieldHidden = True             })-      (fields', stack') = unzip $ objectFieldTypes (Proxy @(Rep a))---- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'--- iterates on field types  and introspects them recursively-instance (Selector s, Introspect a (KIND a) f) => ObjectRep (RecSel s a) f where-  objectFieldTypes _ =-    [ ( (name, __field (Context :: Context a (KIND a) f) name)-      , introspect (Context :: Context a (KIND a) f))-    ]-    where-      name = pack $ selName (undefined :: SelOf s)+      (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a) --- -- UNION------ | recursion for union types--- iterates on possible types for UNION and introspects them recursively-instance (OutputConstraint a, ObjectConstraint a) =>-         UnionRep (RecSel s a) OutputType where-  possibleTypes _ _ =-    [(buildField (Proxy @a) () "", introspect (Context :: OutputOf a))]--instance (GQL_TYPE a, UnionRep (Rep a) OutputType) =>-         Introspect a UNION OutputType where-  __field _ = buildField (Proxy @a) []-  introspect _ = updateLib (Union . buildType fields) stack (Proxy @a)+instance (GQL_TYPE a, GQLRep UNION (Rep a)) => IntrospectKind UNION a where+  introspectKind _ = updateLib (Union . buildType fields) stack (Proxy @a)     where-      (fields, stack) =-        unzip $ possibleTypes (Proxy @(Rep a)) (Proxy @OutputType)+      (fields, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a)) --- -- INPUT_UNION----instance (GQL_TYPE a, Introspect a INPUT_OBJECT InputType) =>-         UnionRep (RecSel s a) InputType where-  possibleTypes _ _ =-    [ ( maybeField $ buildField (Proxy @a) () (__typeName $ Proxy @a)-      , introspect (Context :: Context a INPUT_OBJECT InputType))-    ]--instance (GQL_TYPE a, UnionRep (Rep a) InputType) =>-         Introspect a INPUT_UNION InputType where-  __field _ = buildField (Proxy @a) ()-  introspect _ =-    updateLib-      (InputUnion . buildType (fieldTag : fields))-      (tagsEnumType : stack)-      (Proxy @a)+instance (GQL_TYPE a, GQLRep UNION (Rep a)) => IntrospectKind INPUT_UNION a where+  introspectKind _ = updateLib (InputUnion . buildType (fieldTag : fields)) (tagsEnumType : stack) (Proxy @a)     where-      (fields, stack) =-        unzip $ possibleTypes (Proxy @(Rep a)) (Proxy @InputType)+      (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 (enumTypeName, Leaf $ LeafEnum tagsEnum) x+      tagsEnumType x = pure $ defineType (typeName, Leaf $ LeafEnum tagsEnum) x         where           tagsEnum =-            DataType-              { typeName = enumTypeName-              -- has same fingerprint as object because it depends on it+            DataTyCon+              { typeName+                -- has same fingerprint as object because it depends on it               , typeFingerprint = __typeFingerprint (Proxy @a)               , typeVisibility = __typeVisibility (Proxy @a)-              , typeDescription = ""-              , typeData = map fieldName fields+              , typeDescription = Nothing+              , typeData = map fieldName inputUnions               }-      enumTypeName = __typeName (Proxy @a) <> "Tags"+      typeName = __typeName (Proxy @a) <> "Tags"       fieldTag =         DataField           { fieldName = "tag"-          , fieldArgs = ()-          , fieldTypeWrappers = [NonNullType]-          , fieldType = enumTypeName+          , fieldArgs = []+          , fieldArgsType = Nothing+          , fieldType = buildAlias typeName           , fieldHidden = False           } ------ WRAPPER : Maybe, LIST , Resolver----maybeField :: DataField f -> DataField f-maybeField field@DataField {fieldTypeWrappers = NonNullType:xs} =-  field {fieldTypeWrappers = xs}-maybeField field = field+-- Types+type TypeUpdater = DataTypeLib -> SchemaValidation DataTypeLib -instance Introspect a (KIND a) f => Introspect (Maybe a) WRAPPER f where-  __field _ name = maybeField $ __field (Context :: Context a (KIND a) f) name-  introspect _ = introspect (Context :: Context a (KIND a) f)+type GQL_TYPE a = (Generic a, GQLType a) -instance Introspect a (KIND a) f => Introspect [a] WRAPPER f where-  __field _ name = listField (__field (Context :: Context a (KIND a) f) name)-    where-      listField :: DataField f -> DataField f-      listField x =-        x {fieldTypeWrappers = [NonNullType, ListType] ++ fieldTypeWrappers x}-  introspect _ = introspect (Context :: Context a (KIND a) f)+-- Object Fields+class ObjectFields (custom :: Bool) a where+  objectFields :: proxy1 custom -> proxy2 a -> ([(Text, DataField)], [TypeUpdater]) ------ CUSTOM Types: Tuple, Map, Set----instance Introspect (Pair k v) OBJECT f => Introspect (k, v) WRAPPER f where-  __field _ = __field (Context :: Context (Pair k v) OBJECT f)-  introspect _ = introspect (Context :: Context (Pair k v) OBJECT f)+instance GQLRep OBJECT (Rep a) => ObjectFields 'False a where+  objectFields _ _ = unzip $ gqlRep (Context :: Context OBJECT (Rep a)) -instance Introspect [a] WRAPPER f => Introspect (Set a) WRAPPER f where-  __field _ = __field (Context :: Context [a] WRAPPER f)-  introspect _ = introspect (Context :: Context [a] WRAPPER f)+type family GQLRepResult (a :: GQL_KIND) :: * --- | introspection Does not care about resolving monad, some fake monad just for mocking-type MockRes = (Resolver Maybe)+type instance GQLRepResult OBJECT = (Text, DataField) -instance Introspect (MapKind k v MockRes) OBJECT f =>-         Introspect (Map k v) WRAPPER f where-  __field _ = __field (Context :: Context (MapKind k v MockRes) OBJECT f)-  introspect _ = introspect (Context :: Context (MapKind k v MockRes) OBJECT f)+type instance GQLRepResult UNION = DataField --- |introspects Of Resolver 'a' as argument and 'b' as output type-instance (ObjectRep (Rep a) (), OutputConstraint b) =>-         Introspect (a -> Resolver m b) WRAPPER OutputType where-  __field _ name =-    (__field (Context :: OutputOf b) name)-      {fieldArgs = map fst $ objectFieldTypes (Proxy @(Rep a))}-  introspect _ typeLib =-    resolveTypes typeLib $ map snd args ++ [introspect (Context :: OutputOf b)]-    where-      args :: [((Text, DataInputField), TypeUpdater)]-      args = objectFieldTypes (Proxy @(Rep a))+--  GENERIC UNION+class GQLRep (kind :: GQL_KIND) f where+  gqlRep :: Context kind f -> [(GQLRepResult kind, TypeUpdater)] -instance (ObjectRep (Rep a) (), OutputConstraint b) =>-         Introspect (a -> Either String b) WRAPPER OutputType where-  __field _ name =-    (__field (Context :: OutputOf b) name)-      {fieldArgs = map fst $ objectFieldTypes (Proxy @(Rep a))}-  introspect _ typeLib =-    resolveTypes typeLib $ map snd args ++ [introspect (Context :: OutputOf b)]-    where-      args :: [((Text, DataInputField), TypeUpdater)]-      args = objectFieldTypes (Proxy @(Rep a))+instance GQLRep kind f => GQLRep kind (M1 D d f) where+  gqlRep _ = gqlRep (Context :: Context kind f) -instance (ObjectRep (Rep a) (), OutputConstraint b) =>-         Introspect (a -> SubResolver m c v b) WRAPPER OutputType where-  __field _ name =-    (__field (Context :: OutputOf b) name)-      {fieldArgs = map fst $ objectFieldTypes (Proxy @(Rep a))}-  introspect _ typeLib =-    resolveTypes typeLib $ map snd args ++ [introspect (Context :: OutputOf b)]+instance GQLRep kind f => GQLRep kind (M1 C c f) where+  gqlRep _ = gqlRep (Context :: Context kind f)++-- | 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)++instance (GQL_TYPE a, Introspect a) => GQLRep UNION (M1 S s (Rec0 a)) where+  gqlRep _ = [(buildField (Proxy @a) [] (__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)++instance (Selector s, Introspect a) => GQLRep OBJECT (M1 S s (Rec0 a)) where+  gqlRep _ = [((name, field (Proxy @a) name), introspect (Proxy @a))]     where-      args :: [((Text, DataInputField), TypeUpdater)]-      args = objectFieldTypes (Proxy @(Rep a))+      name = pack $ selName (undefined :: M1 S s (Rec0 ()) ())++instance GQLRep OBJECT U1 where+  gqlRep _ = []++buildAlias :: Text -> TypeAlias+buildAlias aliasTyCon = TypeAlias {aliasTyCon, aliasWrappers = [], aliasArgs = Nothing}++-- Helper Functions+resolveTypes :: DataTypeLib -> [TypeUpdater] -> SchemaValidation DataTypeLib+resolveTypes = foldM (&)++buildField :: GQLType a => Proxy a -> DataArguments -> Text -> DataField+buildField proxy fieldArgs fieldName =+  DataField+    {fieldName, fieldArgs, fieldArgsType = Nothing, fieldType = buildAlias $ __typeName proxy, fieldHidden = False}++buildType :: GQLType a => t -> Proxy a -> DataTyCon t+buildType typeData proxy =+  DataTyCon+    { typeName = __typeName proxy+    , typeFingerprint = __typeFingerprint proxy+    , typeDescription = description proxy+    , typeVisibility = __typeVisibility proxy+    , typeData+    }++updateLib :: GQLType a => (Proxy a -> DataFullType) -> [TypeUpdater] -> Proxy a -> TypeUpdater+updateLib typeBuilder stack proxy lib' =+  case isTypeDefined (__typeName proxy) lib' of+    Nothing -> resolveTypes (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)
src/Data/Morpheus/Execution/Server/Resolve.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}  module Data.Morpheus.Execution.Server.Resolve   ( statelessResolver@@ -15,6 +16,7 @@   ) where  import qualified Codec.Binary.UTF8.String                            as UTF8+import           Control.Monad.Except                                (liftEither) import           Control.Monad.Trans.Except                          (ExceptT (..), runExceptT) import           Data.Aeson                                          (Result (..), encode, fromJSON) import           Data.Aeson.Parser                                   (jsonNoDup)@@ -22,39 +24,41 @@ import qualified Data.ByteString                                     as S import qualified Data.ByteString.Lazy.Char8                          as L import           Data.Functor.Identity                               (Identity (..))-import           Data.Proxy-import           GHC.Generics+import           Data.Proxy                                          (Proxy (..))  -- MORPHEUS import           Data.Morpheus.Error.Utils                           (badRequestError, renderErrors)-import           Data.Morpheus.Execution.Server.Encode               (EncodeCon, EncodeMutCon, EncodeSubCon, encodeMut,-                                                                      encodeQuery, encodeSub)-import           Data.Morpheus.Execution.Server.Introspect           (ObjectRep (..), resolveTypes)+import           Data.Morpheus.Execution.Server.Encode               (EncodeCon, EncodeMutCon, EncodeSubCon, OBJ_RES,+                                                                      encodeOperation, encodeQuery)+import           Data.Morpheus.Execution.Server.Introspect           (IntroCon, ObjectFields (..), resolveTypes) 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.Internal.AST.Operation          (Operation (..), OperationKind (..))-import           Data.Morpheus.Types.Internal.Data                   (DataArguments, DataFingerprint (..),-                                                                      DataType (..), DataTypeLib (..), initTypeLib)+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 (..), OperationKind (..), initTypeLib) import           Data.Morpheus.Types.Internal.Stream                 (Event (..), ResponseEvent (..), ResponseStream,                                                                       StreamState (..), StreamT (..), closeStream, mapS)-import           Data.Morpheus.Types.Internal.Validation             (SchemaValidation)+import           Data.Morpheus.Types.Internal.Validation             (Validation) import           Data.Morpheus.Types.Internal.Value                  (Value (..)) import           Data.Morpheus.Types.IO                              (GQLRequest (..), GQLResponse (..))-import           Data.Morpheus.Types.Resolver                        (GQLRootResolver (..))+import           Data.Morpheus.Types.Resolver                        (GQLRootResolver (..), Resolver, ResponseT) import           Data.Morpheus.Validation.Internal.Utils             (VALIDATION_MODE (..)) import           Data.Morpheus.Validation.Query.Validation           (validateRequest)+import           Data.Typeable                                       (Typeable)  type EventCon event = Eq event -type IntroCon a = (Generic a, ObjectRep (Rep a) DataArguments)- type RootResCon m event cont query mutation subscription    = ( EventCon event+     , Typeable m       -- Introspection      , IntroCon query      , IntroCon mutation      , IntroCon subscription+     , OBJ_RES m (Root (Resolver m)) Value      -- Resolving      , EncodeCon m query Value      , EncodeMutCon m event cont mutation@@ -80,27 +84,35 @@ statelessResolver root = fmap snd . closeStream . streamResolver root  streamResolver ::-     (Monad m, RootResCon m s cont query mut sub)-  => GQLRootResolver m s cont query mut sub+     (Monad m, RootResCon m event cont query mut sub)+  => GQLRootResolver m event cont query mut sub   -> GQLRequest-  -> ResponseStream m s cont GQLResponse+  -> ResponseStream m event cont GQLResponse streamResolver root@GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver} request =-  renderResponse <$> runExceptT (ExceptT (pure validRequest) >>= ExceptT . execOperator)+  renderResponse <$> runExceptT (validRequest >>= execOperator)+  ------------------------------------------------------------   where     renderResponse (Left errors) = Errors $ renderErrors errors     renderResponse (Right value) = Data value     ----------------------------------------------------------    validRequest = do-      schema <- fullSchema $ Identity root-      query <- parseGQL request >>= validateRequest schema FULL_VALIDATION-      return (schema, query)+    validRequest :: Monad m => ResponseT m event cont (DataTypeLib, ValidOperation)+    validRequest =+      liftEither $ do+        schema <- fullSchema $ Identity root+        query <- parseGQL request >>= validateRequest schema FULL_VALIDATION+        Right (schema, query)     -----------------------------------------------------------    execOperator (schema, operation@Operation {operationKind = QUERY}) =-      StreamT $ StreamState [] <$> encodeQuery (schemaAPI schema) queryResolver operation-    execOperator (_, operation@Operation {operationKind = MUTATION}) =-      mapS Publish (encodeMut mutationResolver operation)-    execOperator (_, operation@Operation {operationKind = SUBSCRIPTION}) =-      StreamT $ handleActions <$> closeStream (encodeSub subscriptionResolver operation)+    execOperator (schema, operation@Operation {operationKind = Query}) =+      ExceptT $+      StreamT+        (StreamState [] <$>+         runExceptT+           (do schemaRes <- schemaAPI schema+               ExceptT (encodeQuery schemaRes queryResolver operation)))+    execOperator (_, operation@Operation {operationKind = Mutation}) =+      ExceptT $ mapS Publish (encodeOperation mutationResolver operation)+    execOperator (_, operation@Operation {operationKind = Subscription}) =+      ExceptT $ StreamT $ handleActions <$> closeStream (encodeOperation subscriptionResolver operation)       where         handleActions (_, Left gqlError) = StreamState [] (Left gqlError)         handleActions (channels, Right subResolver) =@@ -125,30 +137,30 @@ fullSchema ::      forall proxy m s cont query mutation subscription. (IntroCon query, IntroCon mutation, IntroCon subscription)   => proxy (GQLRootResolver m s cont query mutation subscription)-  -> SchemaValidation DataTypeLib+  -> Validation DataTypeLib fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema   where     querySchema = resolveTypes (initTypeLib (operatorType (hiddenRootFields ++ fields) "Query")) (defaultTypes : types)       where-        (fields, types) = unzip $ objectFieldTypes (Proxy :: Proxy (Rep query))+        (fields, types) = objectFields (Proxy @(CUSTOM query)) (Proxy @query)     ------------------------------     mutationSchema lib = resolveTypes (lib {mutation = maybeOperator fields "Mutation"}) types       where-        (fields, types) = unzip $ objectFieldTypes (Proxy :: Proxy (Rep mutation))+        (fields, types) = objectFields (Proxy @(CUSTOM mutation)) (Proxy @mutation)     ------------------------------     subscriptionSchema lib = resolveTypes (lib {subscription = maybeOperator fields "Subscription"}) types       where-        (fields, types) = unzip $ objectFieldTypes (Proxy :: Proxy (Rep subscription))-     -- maybeOperator :: [a] -> Text -> Maybe (Text, DataType [a])+        (fields, types) = objectFields (Proxy @(CUSTOM subscription)) (Proxy @subscription)+     -- maybeOperator :: [a] -> Text -> Maybe (Text, DataTyCon[a])     maybeOperator []     = const Nothing     maybeOperator fields = Just . operatorType fields-    -- operatorType :: [a] -> Text -> (Text, DataType [a])+    -- operatorType :: [a] -> Text -> (Text, DataTyCon[a])     operatorType typeData typeName =       ( typeName-      , DataType+      , DataTyCon           { typeData           , typeVisibility = True           , typeName           , typeFingerprint = SystemFingerprint typeName-          , typeDescription = ""+          , typeDescription = Nothing           })
src/Data/Morpheus/Kind.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds     #-}+{-# LANGUAGE PolyKinds     #-} {-# LANGUAGE TypeFamilies  #-} {-# LANGUAGE TypeOperators #-} @@ -12,6 +13,8 @@   , INPUT_OBJECT   , INPUT_UNION   , GQL_KIND+  , Context(..)+  , VContext(..)   ) where  data GQL_KIND@@ -22,6 +25,17 @@   | UNION   | INPUT_UNION   | WRAPPER++--type ObjectConstraint a =+-- | context , like Proxy with multiple parameters+-- * 'kind': object, scalar, enum ...+-- * 'a': actual gql type+data Context (kind :: GQL_KIND) a =+  Context++newtype VContext (kind :: GQL_KIND) a = VContext+  { unVContext :: a+  }  -- | GraphQL Scalar: Int, Float, String, Boolean or any user defined custom Scalar type type SCALAR = 'SCALAR
src/Data/Morpheus/Parsing/Document/DataType.hs view
@@ -11,8 +11,8 @@ import           Data.Morpheus.Parsing.Internal.Terms    (parseAssignment, parseMaybeTuple, parseNonNull,                                                           parseWrappedType, pipeLiteral, qualifier, setOf,                                                           spaceAndComments, token)-import           Data.Morpheus.Types.Internal.Data       (DataArgument, DataFullType (..), DataOutputField, Key,-                                                          RawDataType (..))+import           Data.Morpheus.Types.Internal.Data       (DataArgument, DataField, DataFullType (..), Key,+                                                          RawDataType (..), toHSWrappers) import           Data.Text                               (Text) import           Text.Megaparsec                         (label, sepBy1, some, (<|>)) import           Text.Megaparsec.Char                    (char, space1, string)@@ -22,7 +22,7 @@   label "Argument" $ do     ((fieldName, _), (wrappers, fieldType)) <- parseAssignment qualifier parseWrappedType     nonNull <- parseNonNull-    pure $ createArgument fieldName (nonNull ++ wrappers, fieldType)+    pure $ createArgument fieldName (toHSWrappers $ nonNull ++ wrappers, fieldType)  typeDef :: Text -> Parser Text typeDef kind = do@@ -44,9 +44,9 @@       label "entry" $ do         ((fieldName, _), (wrappers, fieldType)) <- parseAssignment qualifier parseWrappedType         nonNull <- parseNonNull-        return (fieldName, createField () fieldName (nonNull ++ wrappers, fieldType))+        return (fieldName, createField [] fieldName (toHSWrappers $ nonNull ++ wrappers, fieldType)) -outputObjectEntries :: Parser [(Key, DataOutputField)]+outputObjectEntries :: Parser [(Key, DataField)] outputObjectEntries = label "entries" $ setOf entry   where     fieldWithArgs =@@ -58,7 +58,7 @@       label "entry" $ do         ((fieldName, fieldArgs), (wrappers, fieldType)) <- parseAssignment fieldWithArgs parseWrappedType         nonNull <- parseNonNull-        return (fieldName, createField fieldArgs fieldName (nonNull ++ wrappers, fieldType))+        return (fieldName, createField fieldArgs fieldName (toHSWrappers $ nonNull ++ wrappers, fieldType))  dataObject :: Parser (Text, RawDataType) dataObject =
src/Data/Morpheus/Parsing/Internal/Create.hs view
@@ -11,21 +11,29 @@   , createDataTypeLib   ) where -import           Data.Morpheus.Types.Internal.Data (DataField (..), DataFingerprint (..), DataFullType (..),-                                                    DataLeaf (..), DataType (..), DataTypeLib (..), DataTypeWrapper,-                                                    DataValidator (..), defineType, initTypeLib)+import           Data.Morpheus.Types.Internal.Data (DataArguments, DataField (..), DataFingerprint (..),+                                                    DataFullType (..), DataLeaf (..), DataTyCon (..), DataTypeLib (..),+                                                    DataValidator (..), TypeAlias (..), WrapperD, defineType,+                                                    initTypeLib) import           Data.Text                         (Text) -createField :: a -> Text -> ([DataTypeWrapper], Text) -> DataField a-createField fieldArgs fieldName (fieldTypeWrappers, fieldType) =-  DataField {fieldArgs, fieldName, fieldType, fieldTypeWrappers, fieldHidden = False}+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 -> ([DataTypeWrapper], Text) -> (Text, DataField ())-createArgument fieldName x = (fieldName, createField () fieldName x)+createArgument :: Text -> ([WrapperD], Text) -> (Text, DataField)+createArgument fieldName x = (fieldName, createField [] fieldName x) -createType :: Text -> a -> DataType a+createType :: Text -> a -> DataTyCon a createType typeName typeData =-  DataType {typeName, typeDescription = "", typeFingerprint = SystemFingerprint "", typeVisibility = True, typeData}+  DataTyCon+    {typeName, typeDescription = Nothing, typeFingerprint = SystemFingerprint "", typeVisibility = True, typeData}  createScalarType :: Text -> (Text, DataFullType) createScalarType typeName = (typeName, Leaf $ CustomScalar $ createType typeName (DataValidator pure))@@ -36,7 +44,7 @@ createUnionType :: Text -> [Text] -> (Text, DataFullType) createUnionType typeName typeData = (typeName, Union $ createType typeName $ map unionField typeData)   where-    unionField fieldType = createField () "" ([], fieldType)+    unionField fieldType = createField [] "" ([], fieldType)  createDataTypeLib :: Monad m => [(Text, DataFullType)] -> m DataTypeLib createDataTypeLib types =
src/Data/Morpheus/Parsing/JSONSchema/Parse.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeOperators         #-}  module Data.Morpheus.Parsing.JSONSchema.Parse   ( decodeIntrospection@@ -11,63 +13,66 @@ import           Data.Morpheus.Error.Internal            (internalError) import           Data.Morpheus.Parsing.Internal.Create   (createArgument, createDataTypeLib, createEnumType,                                                           createField, createScalarType, createType, createUnionType)-import qualified Data.Morpheus.Schema.EnumValue          as E (EnumValue (..))-import qualified Data.Morpheus.Schema.Field              as F (Field (..))-import qualified Data.Morpheus.Schema.InputValue         as I (InputValue (..))-import           Data.Morpheus.Schema.JSONType           (JSONIntro (..), JSONSchema (..), JSONType (..))+import           Data.Morpheus.Parsing.JSONSchema.Types  (EnumValue (..), Field (..), InputValue (..),+                                                          Introspection (..), Schema (..), Type (..)) import           Data.Morpheus.Schema.TypeKind           (TypeKind (..))-import           Data.Morpheus.Types.Internal.Data       (DataFullType (..), DataTypeLib, DataTypeWrapper (..))+import           Data.Morpheus.Types.Internal.Data       (DataField, DataFullType (..), 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) -typeFromJSON :: JSONType -> Validation (Text, DataFullType)-typeFromJSON JSONType {name = Just typeName, kind = SCALAR} = pure $ createScalarType typeName-typeFromJSON JSONType {name = Just typeName, kind = ENUM, enumValues = Just enums} =-  pure $ createEnumType typeName (map E.name enums)-typeFromJSON JSONType {name = Just typeName, kind = UNION, possibleTypes = Just unions} =-  case traverse name unions of-    Nothing  -> fail "ERROR: GQL ERROR"-    Just uni -> pure $ createUnionType typeName uni-typeFromJSON JSONType {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} = do-  fields <- traverse iField iFields-  pure (typeName, InputObject $ createType typeName fields)-  where-    iField I.InputValue {I.name = fieldName, I.type' = fType} = do-      fieldType <- fieldTypeFromJSON fType-      pure (fieldName, createField () fieldName fieldType)-typeFromJSON JSONType {name = Just typeName, kind = OBJECT, fields = Just oFields} = do-  fields <- traverse oField oFields-  pure (typeName, OutputObject $ createType typeName fields)-  where-    oField F.Field {F.name = fieldName, F.args = fArgs, F.type' = fType} = do-      fieldType <- fieldTypeFromJSON fType-      args <- traverse genArg fArgs-      pure (fieldName, createField args fieldName fieldType)-      where-        genArg I.InputValue {I.name = argName, I.type' = argType} = createArgument argName <$> fieldTypeFromJSON argType-typeFromJSON x = internalError $ "Unsuported type" <> pack (show x)--fieldTypeFromJSON :: JSONType -> Validation ([DataTypeWrapper], Text)-fieldTypeFromJSON = fieldTypeRec []-  where-    fieldTypeRec :: [DataTypeWrapper] -> JSONType -> Validation ([DataTypeWrapper], Text)-    fieldTypeRec acc JSONType {kind = LIST, ofType = Just ofType} = fieldTypeRec (ListType : acc) ofType-    fieldTypeRec acc JSONType {kind = NON_NULL, ofType = Just ofType} = fieldTypeRec (NonNullType : acc) ofType-    fieldTypeRec acc JSONType {name = Just name} = pure (acc, name)-    fieldTypeRec _ x = internalError $ "Unsuported Field" <> pack (show x)--schemaFromJSON :: [JSONType] -> Validation [(Text, DataFullType)]-schemaFromJSON = traverse typeFromJSON- decodeIntrospection :: ByteString -> Validation DataTypeLib decodeIntrospection jsonDoc =   case jsonSchema of     Left errors -> internalError $ pack errors-    Right JSONResponse {responseData = Just JSONIntro {__schema = JSONSchema {types}}} ->-      schemaFromJSON types >>= createDataTypeLib+    Right JSONResponse {responseData = Just Introspection {__schema = Schema {types}}} ->+      traverse parse types >>= createDataTypeLib     Right res -> fail $ show res   where-    jsonSchema :: Either String (JSONResponse JSONIntro)+    jsonSchema :: Either String (JSONResponse Introspection)     jsonSchema = eitherDecode jsonDoc++class ParseJSONSchema a b where+  parse :: a -> Validation (Key, b)++instance ParseJSONSchema Type DataFullType 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  -> fail "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, InputObject $ createType typeName fields)+  parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} = do+    fields <- traverse parse oFields+    pure (typeName, OutputObject $ createType typeName fields)+  parse x = internalError $ "Unsuported type" <> pack (show x)++instance ParseJSONSchema Field DataField where+  parse Field {fieldName, fieldArgs, fieldType} = do+    fType <- fieldTypeFromJSON fieldType+    args <- traverse genArg fieldArgs+    pure (fieldName, createField args fieldName fType)+    where+      genArg InputValue {inputName = argName, inputType = argType} =+        createArgument argName <$> fieldTypeFromJSON argType++instance ParseJSONSchema InputValue DataField where+  parse InputValue {inputName, inputType} = do+    fieldType <- fieldTypeFromJSON inputType+    pure (inputName, createField [] inputName fieldType)++fieldTypeFromJSON :: Type -> Validation ([WrapperD], 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)
+ src/Data/Morpheus/Parsing/JSONSchema/Types.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeOperators     #-}++module Data.Morpheus.Parsing.JSONSchema.Types+  ( Introspection(..)+  , Schema(..)+  , Type(..)+  , Field(..)+  , InputValue(..)+  , EnumValue(..)+  ) where++import           Data.Aeson+import           Data.Text                     (Text)+import           GHC.Generics                  (Generic)++--+-- MORPHEUS+import           Data.Morpheus.Schema.TypeKind (TypeKind)++-- TYPES FOR DECODING JSON INTROSPECTION+--+newtype Introspection = Introspection+  { __schema :: Schema+  } deriving (Generic, Show, FromJSON)++newtype Schema = Schema+  { types :: [Type]+  } deriving (Generic, Show, FromJSON)++-- TYPE+data Type = Type+  { kind          :: TypeKind+  , name          :: Maybe Text+  , fields        :: Maybe [Field]+  , interfaces    :: Maybe [Type]+  , possibleTypes :: Maybe [Type]+  , enumValues    :: Maybe [EnumValue]+  , inputFields   :: Maybe [InputValue]+  , ofType        :: Maybe Type+  } deriving (Generic, Show, FromJSON)++-- FIELD+data Field = Field+  { fieldName :: Text+  , fieldArgs :: [InputValue]+  , fieldType :: Type+  } deriving (Show, Generic)++instance FromJSON Field where+  parseJSON = withObject "Field" objectParser+    where+      objectParser o = Field <$> o .: "name" <*> o .: "args" <*> o .: "type"++-- INPUT+data InputValue = InputValue+  { inputName :: Text+  , inputType :: Type+  } deriving (Show, Generic)++instance FromJSON InputValue where+  parseJSON = withObject "InputValue" objectParser+    where+      objectParser o = InputValue <$> o .: "name" <*> o .: "type"++-- ENUM+newtype EnumValue = EnumValue+  { enumName :: Text+  } deriving (Generic, Show)++instance FromJSON EnumValue where+  parseJSON = withObject "EnumValue" objectParser+    where+      objectParser o = EnumValue <$> o .: "name"
src/Data/Morpheus/Parsing/Request/Operation.hs view
@@ -17,8 +17,8 @@ import           Data.Morpheus.Parsing.Internal.Terms       (parseAssignment, parseMaybeTuple, parseNonNull,                                                              parseWrappedType, spaceAndComments1, token, variable) import           Data.Morpheus.Parsing.Request.Body         (entries)-import           Data.Morpheus.Types.Internal.AST.Operation (Operation (..), OperationKind (..), RawOperation,-                                                             Variable (..))+import           Data.Morpheus.Types.Internal.AST.Operation (Operation (..), RawOperation, Variable (..))+import           Data.Morpheus.Types.Internal.Data          (OperationKind (..), toHSWrappers)  operationArgument :: Parser (Text, Variable ()) operationArgument =@@ -30,7 +30,7 @@       , Variable           { variableType           , isVariableRequired = 0 < length nonNull-          , variableTypeWrappers = nonNull ++ wrappers+          , variableTypeWrappers = toHSWrappers $ nonNull ++ wrappers           , variablePosition           , variableValue = ()           })@@ -53,7 +53,7 @@     pure       (Operation          { operationName = "AnonymousQuery"-         , operationKind = QUERY+         , operationKind = Query          , operationArgs = []          , operationSelection          , operationPosition@@ -63,6 +63,6 @@ parseOperationKind :: Parser OperationKind parseOperationKind =   label "operatorKind" $ do-    kind <- (string "query" $> QUERY) <|> (string "mutation" $> MUTATION) <|> (string "subscription" $> SUBSCRIPTION)+    kind <- (string "query" $> Query) <|> (string "mutation" $> Mutation) <|> (string "subscription" $> Subscription)     spaceAndComments1     return kind
− src/Data/Morpheus/Rendering/GQL.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Rendering.GQL-  ( renderGraphQLDocument-  ) where--import           Data.ByteString.Lazy.Char8        (ByteString)-import           Data.Semigroup                    ((<>))-import           Data.Text                         (Text, intercalate)-import qualified Data.Text.Lazy                    as LT (fromStrict)-import           Data.Text.Lazy.Encoding           (encodeUtf8)---- MORPHEUS-import           Data.Morpheus.Types.Internal.Data (DataArgument, DataField (..), DataFullType (..), DataLeaf (..),-                                                    DataType (..), DataTypeLib, allDataTypes, showWrappedType)--renderGraphQLDocument :: DataTypeLib -> ByteString-renderGraphQLDocument lib =-  encodeUtf8 $ LT.fromStrict $ intercalate "\n\n" $ map renderType visibleTypes-  where-    visibleTypes = filter (isVisible . snd) (allDataTypes lib)--isVisible :: DataFullType -> Bool-isVisible (Leaf (BaseScalar DataType {typeVisibility}))   = typeVisibility-isVisible (Leaf (CustomScalar DataType {typeVisibility})) = typeVisibility-isVisible (Leaf (LeafEnum DataType {typeVisibility}))     = typeVisibility-isVisible (Union DataType {typeVisibility})               = typeVisibility-isVisible (InputObject DataType {typeVisibility})         = typeVisibility-isVisible (InputUnion DataType {typeVisibility})          = typeVisibility-isVisible (OutputObject DataType {typeVisibility})        = typeVisibility--renderIndent :: Text-renderIndent = "  "--renderType :: (Text, DataFullType) -> Text-renderType (name, Leaf (BaseScalar _)) = "scalar " <> name-renderType (name, Leaf (CustomScalar _)) = "scalar " <> name-renderType (name, Leaf (LeafEnum DataType {typeData})) =-  "enum " <> name <> renderObject id typeData-renderType (name, Union DataType {typeData}) =-  "union " <> name <> " =\n    " <>-  intercalate ("\n" <> renderIndent <> "| ") (map fieldType typeData)-renderType (name, InputObject DataType {typeData}) =-  "input " <> name <> renderDataObject renderInputField typeData-renderType (name, InputUnion DataType {typeData}) =-  "input " <> name <> renderDataObject renderInputField (mapKeys typeData)-renderType (name, OutputObject DataType {typeData}) =-  "type " <> name <> renderDataObject renderField typeData--mapKeys :: [DataField a] -> [(Text, DataField a)]-mapKeys = map (\x -> (fieldName x, x))--renderObject :: (a -> Text) -> [a] -> Text-renderObject f list =-  " { \n  " <> intercalate ("\n" <> renderIndent) (map f list) <> "\n}"--renderDataObject ::-     ((Text, DataField a) -> Text) -> [(Text, DataField a)] -> Text-renderDataObject f list = renderObject f (ignoreHidden list)-  where-    ignoreHidden :: [(Text, DataField a)] -> [(Text, DataField a)]-    ignoreHidden = filter (not . fieldHidden . snd)--renderInputField :: (Text, DataField ()) -> Text-renderInputField (key, DataField {fieldTypeWrappers, fieldType}) =-  key <> ": " <> showWrappedType fieldTypeWrappers fieldType--renderField :: (Text, DataField [(Text, DataArgument)]) -> Text-renderField (key, DataField {fieldTypeWrappers, fieldType, fieldArgs}) =-  key <> renderArguments fieldArgs <> ": " <>-  showWrappedType fieldTypeWrappers fieldType-  where-    renderArguments :: [(Text, DataArgument)] -> Text-    renderArguments [] = ""-    renderArguments list =-      "(" <> intercalate ", " (map renderInputField list) <> ")"
+ src/Data/Morpheus/Rendering/Haskell/RenderHS.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DefaultSignatures    #-}+{-# LANGUAGE NamedFieldPuns       #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Data.Morpheus.Rendering.Haskell.RenderHS+  ( RenderHS(..)+  ) where++import           Data.Semigroup                    ((<>))++-- MORPHEUS+import           Data.Morpheus.Types.Internal.Data++class RenderHS a where+  render :: a -> Key+  renderWrapped :: a -> [WrapperD] -> Key+  default renderWrapped :: a -> [WrapperD] -> Key+  renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers)+    where+      showGQLWrapper []               = render x+      showGQLWrapper (ListType:xs)    = "[" <> showGQLWrapper xs <> "]"+      showGQLWrapper (NonNullType:xs) = showGQLWrapper xs <> "!"++instance RenderHS Key where+  render = id++instance RenderHS TypeAlias where+  render TypeAlias {aliasTyCon, aliasWrappers} = renderWrapped aliasTyCon aliasWrappers++instance RenderHS DataKind where+  render (ScalarKind x) = typeName x+  render (EnumKind x)   = typeName x+  render (ObjectKind x) = typeName x+  render (UnionKind x)  = typeName x
src/Data/Morpheus/Rendering/Haskell/Terms.hs view
@@ -22,7 +22,7 @@ import           Data.Text                         (Text, intercalate, toUpper)  -- MORPHEUS-import           Data.Morpheus.Types.Internal.Data (DataTypeWrapper (..))+import           Data.Morpheus.Types.Internal.Data (WrapperD (..))  indent :: Text indent = "  "@@ -49,8 +49,7 @@ renderTuple typeName = "(" <> typeName <> ")"  renderSet :: [Text] -> Text-renderSet fields =-  bracket "{ " <> intercalate ("\n  ," <> indent) fields <> bracket "}\n"+renderSet fields = bracket "{ " <> intercalate ("\n  ," <> indent) fields <> bracket "}\n"   where     bracket x = "\n    " <> x @@ -60,12 +59,10 @@ renderExtension :: Text -> Text renderExtension name = "{-# LANGUAGE " <> name <> " #-}\n" -renderWrapped :: [DataTypeWrapper] -> Text -> Text-renderWrapped []                          = renderMaybe . strToText-renderWrapped [NonNullType]               = strToText-renderWrapped (NonNullType:(ListType:xs)) = renderList . renderWrapped xs-renderWrapped (ListType:xs)               = renderMaybe . renderList . renderWrapped xs-renderWrapped (NonNullType:xs)            = renderWrapped xs+renderWrapped :: [WrapperD] -> Text -> Text+renderWrapped (ListD:xs)  = renderList . renderWrapped xs+renderWrapped (MaybeD:xs) = renderMaybe . renderWrapped xs+renderWrapped []          = strToText  strToText :: Text -> Text strToText "String" = "Text"@@ -79,11 +76,10 @@   | Subscription   | Query -data Context =-  Context-    { moduleName :: Text-    , imports    :: [(Text, [Text])]-    , extensions :: [Text]-    , scope      :: Scope-    , pubSub     :: (Text, Text)-    }+data Context = Context+  { moduleName :: Text+  , imports    :: [(Text, [Text])]+  , extensions :: [Text]+  , scope      :: Scope+  , pubSub     :: (Text, Text)+  }
src/Data/Morpheus/Rendering/Haskell/Types.hs view
@@ -15,62 +15,43 @@                                                         renderData, renderSet, renderTuple, renderUnionCon,                                                         renderWrapped) import           Data.Morpheus.Types.Internal.Data     (DataArgument, DataField (..), DataFullType (..), DataLeaf (..),-                                                        DataType (..), DataTypeWrapper (..))+                                                        DataTyCon (..), TypeAlias (..), isNullable)  renderType :: Context -> (Text, DataFullType) -> Text-renderType context (name, dataType) =-  typeIntro <> renderData name <> renderT dataType+renderType context (name, dataType) = typeIntro <> renderData name <> renderT dataType   where-    renderT (Leaf (BaseScalar _)) =-      renderCon name <> "Int Int" <> defineTypeClass "SCALAR" <>-      renderGQLScalar name-    renderT (Leaf (CustomScalar _)) =-      renderCon name <> "Int Int" <> defineTypeClass "SCALAR" <>-      renderGQLScalar name-    renderT (Leaf (LeafEnum DataType {typeData})) =-      unionType typeData <> defineTypeClass "ENUM"-    renderT (Union DataType {typeData}) =-      renderUnion name typeData <> defineTypeClass "UNION"-    renderT (InputObject DataType {typeData}) =-      renderCon name <> renderObject renderInputField typeData <>-      defineTypeClass "INPUT_OBJECT"+    renderT (Leaf (BaseScalar _)) = renderCon name <> "Int Int" <> defineTypeClass "SCALAR" <> renderGQLScalar name+    renderT (Leaf (CustomScalar _)) = renderCon name <> "Int Int" <> defineTypeClass "SCALAR" <> renderGQLScalar name+    renderT (Leaf (LeafEnum DataTyCon {typeData})) = unionType typeData <> defineTypeClass "ENUM"+    renderT (Union DataTyCon {typeData}) = renderUnion name typeData <> defineTypeClass "UNION"+    renderT (InputObject DataTyCon {typeData}) =+      renderCon name <> renderObject renderInputField typeData <> defineTypeClass "INPUT_OBJECT"     renderT (InputUnion _) = "\n -- Error: Input Union Not Supported"-    renderT (OutputObject DataType {typeData}) =-      renderCon name <> renderObject (renderField context) typeData <>-      defineTypeClass "OBJECT"+    renderT (OutputObject DataTyCon {typeData}) =+      renderCon name <> renderObject (renderField context) typeData <> defineTypeClass "OBJECT"     ----------------------------------------------------------------------------------------------------------     typeIntro = "\n\n---- GQL " <> name <> " ------------------------------- \n"     ----------------------------------------------------------------------------------------------------------     defineTypeClass kind =-      "\n\n" <> renderTypeInstanceHead "GQLType" name <> indent <> "type KIND " <>-      name <>-      " = " <>-      kind <>-      "\n\n"+      "\n\n" <> renderTypeInstanceHead "GQLType" name <> indent <> "type KIND " <> name <> " = " <> kind <> "\n\n"     ----------------------------------------------------------------------------------------------------------  renderTypeInstanceHead :: Text -> Text -> Text-renderTypeInstanceHead className name =-  "instance " <> className <> " " <> name <> " where\n"+renderTypeInstanceHead className name = "instance " <> className <> " " <> name <> " where\n"  renderGQLScalar :: Text -> Text-renderGQLScalar name =-  renderTypeInstanceHead "GQLScalar " name <> renderParse <> renderSerialize <>-  "\n\n"+renderGQLScalar name = renderTypeInstanceHead "GQLScalar " name <> renderParse <> renderSerialize <> "\n\n"   where     renderParse = indent <> "parseValue _ = pure (" <> name <> " 0 0 )" <> "\n"     renderSerialize = indent <> "serialize (" <> name <> " x y ) = Int (x + y)" -renderUnion :: Text -> [DataField ()] -> Text+renderUnion :: Text -> [DataField] -> Text renderUnion typeName = unionType . map renderElem   where-    renderElem DataField {fieldType} =-      renderUnionCon typeName fieldType <> fieldType+    renderElem DataField {fieldType = TypeAlias {aliasTyCon}} = renderUnionCon typeName aliasTyCon <> aliasTyCon  unionType :: [Text] -> Text-unionType ls =-  "\n" <> indent <> intercalate ("\n" <> indent <> "| ") ls <>-  " deriving (Generic)"+unionType ls = "\n" <> indent <> intercalate ("\n" <> indent <> "| ") ls <> " deriving (Generic)"  renderObject :: (a -> (Text, Maybe Text)) -> [a] -> Text renderObject f list = intercalate "\n\n" $ renderMainType : catMaybes types@@ -78,19 +59,17 @@     renderMainType = renderSet fields <> " deriving (Generic)"     (fields, types) = unzip (map f list) -renderInputField :: (Text, DataField ()) -> (Text, Maybe Text)-renderInputField (key, DataField {fieldTypeWrappers, fieldType}) =-  (key `renderAssignment` renderWrapped fieldTypeWrappers fieldType, Nothing)+renderInputField :: (Text, DataField) -> (Text, Maybe Text)+renderInputField (key, DataField {fieldType = TypeAlias {aliasTyCon, aliasWrappers}}) =+  (key `renderAssignment` renderWrapped aliasWrappers aliasTyCon, Nothing) -renderField ::-     Context -> (Text, DataField [(Text, DataArgument)]) -> (Text, Maybe Text)-renderField Context {scope, pubSub = (channel, content)} (key, DataField { fieldTypeWrappers-                                                                         , fieldType+renderField :: Context -> (Text, DataField) -> (Text, Maybe Text)+renderField Context {scope, pubSub = (channel, content)} (key, DataField { fieldType = TypeAlias { aliasWrappers+                                                                                                 , aliasTyCon+                                                                                                 }                                                                          , fieldArgs                                                                          }) =-  ( key `renderAssignment` argTypeName <> " -> " <> renderMonad scope <>-    result fieldTypeWrappers-  , argTypes)+  (key `renderAssignment` argTypeName <> " -> " <> renderMonad scope <> result aliasWrappers, argTypes)   where     renderMonad Subscription = "IOSubRes " <> channel <> " " <> content <> " "     renderMonad Mutation =@@ -99,16 +78,15 @@         _    -> "IOMutRes " <> channel <> " " <> content <> " "     renderMonad _ = "IORes "     ------------------------------------------------------------------    result wrappers@(NonNullType:_) = renderWrapped wrappers fieldType-    result wrappers                 = renderTuple (renderWrapped wrappers fieldType)+    result wrappers+      | isNullable wrappers = renderTuple (renderWrapped wrappers aliasTyCon)+      | otherwise = renderWrapped wrappers aliasTyCon     (argTypeName, argTypes) = renderArguments fieldArgs     renderArguments :: [(Text, DataArgument)] -> (Text, Maybe Text)     renderArguments [] = ("()", Nothing)     renderArguments list =       ( fieldArgTypeName-      , Just-          (renderData fieldArgTypeName <> renderCon fieldArgTypeName <>-           renderObject renderInputField list))+      , Just (renderData fieldArgTypeName <> renderCon fieldArgTypeName <> renderObject renderInputField list))       where         fieldArgTypeName = "Arg" <> camelCase key         camelCase :: Text -> Text
src/Data/Morpheus/Rendering/Haskell/Values.hs view
@@ -13,22 +13,16 @@ -- MORPHEUS import           Data.Morpheus.Rendering.Haskell.Terms (Context (..), Scope (..), renderAssignment, renderCon,                                                         renderEqual, renderReturn, renderSet, renderUnionCon)-import           Data.Morpheus.Types.Internal.Data     (DataField (..), DataFullType (..), DataLeaf (..), DataType (..),-                                                        DataTypeLib (..), DataTypeWrapper (..))+import           Data.Morpheus.Types.Internal.Data     (DataField (..), DataFullType (..), DataLeaf (..),+                                                        DataTyCon (..), DataTypeLib (..), TypeAlias (..), WrapperD (..))  renderRootResolver :: Context -> DataTypeLib -> Text-renderRootResolver _ DataTypeLib {mutation, subscription} =-  renderSignature <> renderBody <> "\n\n"+renderRootResolver _ DataTypeLib {mutation, subscription} = renderSignature <> renderBody <> "\n\n"   where-    renderSignature =-      "rootResolver :: " <> renderRootSig (fst <$> subscription) <> "\n"+    renderSignature = "rootResolver :: " <> renderRootSig (fst <$> subscription) <> "\n"       where-        renderRootSig (Just sub) =-          "GQLRootResolver IO Channel Content Query " <> maybeOperator mutation <>-          " " <>-          sub-        renderRootSig Nothing =-          "GQLRootResolver IO () () Query " <> maybeOperator mutation <> " ()"+        renderRootSig (Just sub) = "GQLRootResolver IO Channel Content Query " <> maybeOperator mutation <> " " <> sub+        renderRootSig Nothing    = "GQLRootResolver IO () () Query " <> maybeOperator mutation <> " ()"         ----------------------         maybeOperator (Just (name, _)) = name         maybeOperator Nothing          = "()"@@ -44,60 +38,43 @@         maybeRes Nothing          = "return ()"  renderResolver :: Context -> (Text, DataFullType) -> Text-renderResolver Context {scope, pubSub = (channel, content)} (name, dataType) =-  renderSig dataType+renderResolver Context {scope, pubSub = (channel, content)} (name, dataType) = renderSig dataType   where-    renderSig (Leaf BaseScalar {}) =-      defFunc <> renderReturn <> "$ " <> renderCon name <> "0 0"-    renderSig (Leaf CustomScalar {}) =-      defFunc <> renderReturn <> "$ " <> renderCon name <> "0 0"-    renderSig (Leaf (LeafEnum DataType {typeData})) =-      defFunc <> renderReturn <> renderCon (head typeData)-    renderSig (Union DataType {typeData}) =-      defFunc <> renderUnionCon name typeCon <> " <$> " <> "resolve" <> typeCon+    renderSig (Leaf BaseScalar {}) = defFunc <> renderReturn <> "$ " <> renderCon name <> "0 0"+    renderSig (Leaf CustomScalar {}) = defFunc <> renderReturn <> "$ " <> renderCon name <> "0 0"+    renderSig (Leaf (LeafEnum DataTyCon {typeData})) = defFunc <> renderReturn <> renderCon (head typeData)+    renderSig (Union DataTyCon {typeData}) = defFunc <> renderUnionCon name typeCon <> " <$> " <> "resolve" <> typeCon       where-        typeCon = fieldType $ head typeData-    renderSig (OutputObject DataType {typeData}) =-      defFunc <> renderReturn <> renderCon name <> renderObjFields+        typeCon = aliasTyCon $ fieldType $ head typeData+    renderSig (OutputObject DataTyCon {typeData}) = defFunc <> renderReturn <> renderCon name <> renderObjFields       where         renderObjFields = renderResObject (map renderFieldRes typeData)-        renderFieldRes (key, DataField {fieldType, fieldTypeWrappers}) =-          ( key-          , "const " <>-            withScope scope (renderValue fieldTypeWrappers fieldType))+        renderFieldRes (key, DataField {fieldType = TypeAlias {aliasWrappers, aliasTyCon}}) =+          (key, "const " <> withScope scope (renderValue aliasWrappers aliasTyCon))           where-            renderValue [] = const $ "$ " <> renderReturn <> "Nothing"-            renderValue [NonNullType] = fieldValue-            renderValue (ListType:_) = const $ "$ " <> renderReturn <> "Just []"-            renderValue (NonNullType:(ListType:_)) =-              const $ "$ " <> renderReturn <> "[]"-            renderValue (NonNullType:(NonNullType:xs)) =-              renderValue (NonNullType : xs)+            renderValue (MaybeD:_) = const $ "$ " <> renderReturn <> "Nothing"+            renderValue (ListD:_)  = const $ "$ " <> renderReturn <> "[]"+            renderValue []         = fieldValue             ----------------------------------------------------------------------------             fieldValue "String" = "$ return \"\""             fieldValue "Int"    = "$ return 0"             fieldValue fName    = "resolve" <> fName             --------------------------------------------            withScope Subscription x =-              "$ Event { channels = [Channel], content = const " <> x <> " }"+            withScope Subscription x = "$ Event { channels = [Channel], content = const " <> x <> " }"             withScope Mutation x =               case (channel, content) of                 ("()", "()") -> x-                _ ->-                  "$ toMutResolver [Event {channels = [Channel], content = Content}] " <>-                  x+                _            -> "$ toMutResolver [Event {channels = [Channel], content = Content}] " <> x             withScope _ x = x     renderSig _ = "" -- INPUT Types Does not Need Resolvers     --------------------------------     defFunc = renderSignature <> renderFunc     -----------------------------------------------------------------------------------------------------------    renderSignature =-      renderAssignment ("resolve" <> name) (renderMonad name) <> "\n"+    renderSignature = renderAssignment ("resolve" <> name) (renderMonad name) <> "\n"     ----------------------------------------------------------------------------------    renderMonad "Mutation" =-      "IOMutRes " <> channel <> " " <> content <> " Mutation"+    renderMonad "Mutation"     = "IOMutRes " <> channel <> " " <> content <> " Mutation"     renderMonad "Subscription" = "SubRootRes IO " <> channel <> " Subscription"-    renderMonad tName = "IORes " <> tName+    renderMonad tName          = "IORes " <> tName     ----------------------------------------------------------------------------------------------------------     renderFunc = "resolve" <> name <> " = "     ---------------------------------------
+ src/Data/Morpheus/Rendering/RenderGQL.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DefaultSignatures    #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE NamedFieldPuns       #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL(..)+  , renderGraphQLDocument+  ) where++import           Data.ByteString.Lazy.Char8        (ByteString)+import           Data.Semigroup                    ((<>))+import           Data.Text                         (Text, intercalate)+import qualified Data.Text.Lazy                    as LT (fromStrict)+import           Data.Text.Lazy.Encoding           (encodeUtf8)++-- MORPHEUS+import           Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataKind (..), DataLeaf (..),+                                                    DataTyCon (..), DataTypeLib, DataTypeWrapper (..), Key,+                                                    TypeAlias (..), WrapperD (..), allDataTypes, isVisible,+                                                    toGQLWrapper)++renderGraphQLDocument :: DataTypeLib -> ByteString+renderGraphQLDocument lib = encodeUtf8 $ LT.fromStrict $ intercalate "\n\n" $ map render visibleTypes+  where+    visibleTypes = filter (isVisible . snd) (allDataTypes lib)++class RenderGQL a where+  render :: a -> Key+  renderWrapped :: a -> [WrapperD] -> Key+  default renderWrapped :: a -> [WrapperD] -> Key+  renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers)+    where+      showGQLWrapper []               = render x+      showGQLWrapper (ListType:xs)    = "[" <> showGQLWrapper xs <> "]"+      showGQLWrapper (NonNullType:xs) = showGQLWrapper xs <> "!"++instance RenderGQL Key where+  render = id++instance RenderGQL TypeAlias where+  render TypeAlias {aliasTyCon, aliasWrappers} = renderWrapped aliasTyCon aliasWrappers++instance RenderGQL DataKind where+  render (ScalarKind x) = typeName x+  render (EnumKind x)   = typeName x+  render (ObjectKind x) = typeName x+  render (UnionKind x)  = typeName x++instance RenderGQL (Key, DataFullType) where+  render (name, Leaf (BaseScalar _)) = "scalar " <> name+  render (name, Leaf (CustomScalar _)) = "scalar " <> name+  render (name, Leaf (LeafEnum DataTyCon {typeData})) = "enum " <> name <> renderObject id typeData+  render (name, Union DataTyCon {typeData}) =+    "union " <> name <> " =\n    " <> intercalate ("\n" <> renderIndent <> "| ") (map (render . fieldType) typeData)+  render (name, InputObject DataTyCon {typeData}) = "input " <> name <> render typeData+  render (name, InputUnion DataTyCon {typeData}) = "input " <> name <> render (mapKeys typeData)+  render (name, OutputObject DataTyCon {typeData}) = "type " <> name <> render typeData++-- OBJECT+instance RenderGQL [(Text, DataField)] where+  render = renderObject renderField . ignoreHidden+    where+      renderField :: (Text, DataField) -> Text+      renderField (key, DataField {fieldType, fieldArgs}) = key <> renderArgs fieldArgs <> ": " <> render fieldType+        where+          renderArgs []   = ""+          renderArgs list = "(" <> intercalate ", " (map renderField list) <> ")"+      -----------------------------------------------------------+      ignoreHidden :: [(Text, DataField)] -> [(Text, DataField)]+      ignoreHidden = filter (not . fieldHidden . snd)++renderIndent :: Text+renderIndent = "  "++mapKeys :: [DataField] -> [(Text, DataField)]+mapKeys = map (\x -> (fieldName x, x))++renderObject :: (a -> Text) -> [a] -> Text+renderObject f list = " { \n  " <> intercalate ("\n" <> renderIndent) (map f list) <> "\n}"
+ src/Data/Morpheus/Rendering/RenderIntrospection.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeOperators         #-}++module Data.Morpheus.Rendering.RenderIntrospection+  ( render+  , createObjectType+  ) where++import           Data.Semigroup                     ((<>))+import           Data.Text                          (Text, unpack)++import           Data.Morpheus.Schema.Schema++-- Morpheus+import           Data.Morpheus.Schema.TypeKind      (TypeKind (..))+import           Data.Morpheus.Types.Internal.Data  (DataField (..), DataField, DataFullType (..), DataLeaf (..),+                                                     DataObject, DataTyCon (..), DataTypeKind (..), DataTypeLib,+                                                     DataTypeWrapper (..), DataUnion, TypeAlias (..), kindOf,+                                                     lookupDataType, toGQLWrapper)+import           Data.Morpheus.Types.Internal.Value (convertToJSONName)++constRes :: Applicative m => a -> b -> m a+constRes = const . pure++type Result m a = DataTypeLib -> m a++class RenderSchema a b where+  render :: Monad m => (Text, a) -> DataTypeLib -> m (b m)++instance RenderSchema DataFullType S__Type where+  render (name, Leaf leaf) = render (name, leaf)+  render (name, InputObject iObject) = renderInputObject (name, iObject)+  render (name, OutputObject object') = typeFromObject (name, object')+    where+      typeFromObject (key, DataTyCon {typeData, typeDescription}) lib =+        createObjectType key typeDescription <$>+        (Just <$> traverse (`render` lib) (filter (not . fieldHidden . snd) typeData))+  render (name, Union union') = const $ pure $ typeFromUnion (name, union')+  render (name, InputUnion inpUnion') = renderInputUnion (name, inpUnion')++instance RenderSchema DataLeaf S__Type where+  render (key, BaseScalar DataTyCon {typeDescription}) _ = pure $ createLeafType SCALAR key typeDescription Nothing+  render (key, CustomScalar DataTyCon {typeDescription}) _ = pure $ createLeafType SCALAR key typeDescription Nothing+  render (key, LeafEnum DataTyCon {typeDescription, typeData}) _ =+    pure $ createLeafType ENUM key typeDescription (Just $ map createEnumValue typeData)++instance RenderSchema DataField S__Field where+  render (key, field@DataField {fieldType = TypeAlias {aliasTyCon}, fieldArgs}) lib = do+    kind <- renderTypeKind <$> lookupKind aliasTyCon lib+    createFieldWith key (wrap field $ createType kind aliasTyCon Nothing $ Just []) <$>+      traverse (`inputValueFromArg` lib) fieldArgs++renderTypeKind :: DataTypeKind -> TypeKind+renderTypeKind KindScalar      = SCALAR+renderTypeKind (KindObject _)  = OBJECT+renderTypeKind KindUnion       = UNION+renderTypeKind KindInputUnion  = INPUT_OBJECT+renderTypeKind KindEnum        = ENUM+renderTypeKind KindInputObject = INPUT_OBJECT+renderTypeKind KindList        = LIST+renderTypeKind KindNonNull     = NON_NULL++wrap :: Monad m => DataField -> S__Type m -> S__Type m+wrap DataField {fieldType = TypeAlias {aliasWrappers}} typ = foldr wrapByTypeWrapper typ (toGQLWrapper aliasWrappers)++wrapByTypeWrapper :: Monad m => DataTypeWrapper -> S__Type m -> S__Type m+wrapByTypeWrapper ListType    = wrapAs LIST+wrapByTypeWrapper NonNullType = wrapAs NON_NULL++lookupKind :: Monad m => Text -> Result m DataTypeKind+lookupKind name lib =+  case lookupDataType name lib of+    Nothing    -> fail $ unpack ("Kind Not Found: " <> name)+    Just value -> pure (kindOf value)++inputValueFromArg :: Monad m => (Text, DataField) -> Result m (S__InputValue m)+inputValueFromArg (key, input) = fmap (createInputValueWith key) . createInputObjectType input++createInputObjectType :: Monad m => DataField -> Result m (S__Type m)+createInputObjectType field@DataField {fieldType = TypeAlias {aliasTyCon}} lib = do+  kind <- renderTypeKind <$> lookupKind aliasTyCon lib+  pure $ wrap field $ createType kind aliasTyCon Nothing $ Just []++renderInputObject :: Monad m => (Text, DataObject) -> Result m (S__Type m)+renderInputObject (key, DataTyCon {typeData, typeDescription}) lib = do+  fields <- traverse (`inputValueFromArg` lib) typeData+  pure $ createInputObject key typeDescription fields++renderInputUnion :: Monad m => (Text, DataUnion) -> Result m (S__Type m)+renderInputUnion (key', DataTyCon {typeData, typeDescription}) lib =+  createInputObject key' typeDescription <$> traverse createField typeData+  where+    createField field = createInputValueWith (fieldName field) <$> createInputObjectType field lib++createLeafType :: Monad m => TypeKind -> Text -> Maybe Text -> Maybe [S__EnumValue m] -> S__Type m+createLeafType kind name description enums =+  S__Type+    { s__TypeKind = constRes kind+    , s__TypeName = constRes $ Just name+    , s__TypeDescription = constRes description+    , s__TypeFields = constRes Nothing+    , s__TypeOfType = constRes Nothing+    , s__TypeInterfaces = constRes Nothing+    , s__TypePossibleTypes = constRes Nothing+    , s__TypeEnumValues = constRes enums+    , s__TypeInputFields = constRes Nothing+    }++typeFromUnion :: Monad m => (Text, DataUnion) -> S__Type m+typeFromUnion (name, DataTyCon {typeData, typeDescription}) =+  S__Type+    { s__TypeKind = constRes UNION+    , s__TypeName = constRes $ Just name+    , s__TypeDescription = constRes typeDescription+    , s__TypeFields = constRes Nothing+    , s__TypeOfType = constRes Nothing+    , s__TypeInterfaces = constRes Nothing+    , s__TypePossibleTypes =+        constRes $ Just (map (\x -> createObjectType (aliasTyCon $ fieldType x) Nothing $ Just []) typeData)+    , s__TypeEnumValues = constRes Nothing+    , s__TypeInputFields = constRes Nothing+    }++createObjectType :: Monad m => Text -> Maybe Text -> Maybe [S__Field m] -> S__Type m+createObjectType name description fields =+  S__Type+    { s__TypeKind = constRes OBJECT+    , s__TypeName = constRes $ Just name+    , s__TypeDescription = constRes description+    , s__TypeFields = constRes fields+    , s__TypeOfType = constRes Nothing+    , s__TypeInterfaces = constRes $ Just []+    , s__TypePossibleTypes = constRes Nothing+    , s__TypeEnumValues = constRes Nothing+    , s__TypeInputFields = constRes Nothing+    }++createInputObject :: Monad m => Text -> Maybe Text -> [S__InputValue m] -> S__Type m+createInputObject name description fields =+  S__Type+    { s__TypeKind = constRes INPUT_OBJECT+    , s__TypeName = constRes $ Just name+    , s__TypeDescription = constRes description+    , s__TypeFields = constRes Nothing+    , s__TypeOfType = constRes Nothing+    , s__TypeInterfaces = constRes Nothing+    , s__TypePossibleTypes = constRes Nothing+    , s__TypeEnumValues = constRes Nothing+    , s__TypeInputFields = constRes $ Just fields+    }++createType :: Monad m => TypeKind -> Text -> Maybe Text -> Maybe [S__Field m] -> S__Type m+createType kind name description fields' =+  S__Type+    { s__TypeKind = constRes kind+    , s__TypeName = constRes $ Just name+    , s__TypeDescription = constRes description+    , s__TypeFields = constRes fields'+    , s__TypeOfType = constRes Nothing+    , s__TypeInterfaces = constRes Nothing+    , s__TypePossibleTypes = constRes Nothing+    , s__TypeEnumValues = constRes $ Just []+    , s__TypeInputFields = constRes Nothing+    }++wrapAs :: Monad m => TypeKind -> S__Type m -> S__Type m+wrapAs kind contentType =+  S__Type+    { s__TypeKind = constRes kind+    , s__TypeName = constRes Nothing+    , s__TypeDescription = constRes Nothing+    , s__TypeFields = constRes Nothing+    , s__TypeOfType = constRes $ Just contentType+    , s__TypeInterfaces = constRes Nothing+    , s__TypePossibleTypes = constRes Nothing+    , s__TypeEnumValues = constRes Nothing+    , s__TypeInputFields = constRes Nothing+    }++createFieldWith :: Monad m => Text -> S__Type m -> [S__InputValue m] -> S__Field m+createFieldWith _name fieldType fieldArgs =+  S__Field+    { s__FieldName = constRes $ convertToJSONName _name+    , s__FieldDescription = constRes Nothing+    , s__FieldArgs = constRes fieldArgs+    , s__FieldType' = constRes fieldType+    , s__FieldIsDeprecated = constRes False+    , s__FieldDeprecationReason = constRes Nothing+    }++createInputValueWith :: Monad m => Text -> S__Type m -> S__InputValue m+createInputValueWith name ivType =+  S__InputValue+    { s__InputValueName = constRes name+    , s__InputValueDescription = constRes Nothing+    , s__InputValueType' = constRes ivType+    , s__InputValueDefaultValue = constRes Nothing+    }++createEnumValue :: Monad m => Text -> S__EnumValue m+createEnumValue name =+  S__EnumValue+    { s__EnumValueName = constRes name+    , s__EnumValueDescription = constRes Nothing+    , s__EnumValueIsDeprecated = constRes False+    , s__EnumValueDeprecationReason = constRes Nothing+    }
− src/Data/Morpheus/Schema/Directive.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE DeriveAnyClass    #-}-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE TypeOperators     #-}--module Data.Morpheus.Schema.Directive-  ( Directive(..)-  ) where--import           Data.Aeson                             (FromJSON (..))-import           Data.Morpheus.Kind                     (OBJECT)-import           Data.Morpheus.Schema.DirectiveLocation (DirectiveLocation)-import           Data.Morpheus.Schema.InputValue        (InputValue)-import           Data.Morpheus.Types.GQLType            (GQLType (KIND, __typeName, __typeVisibility))-import           Data.Text                              (Text)-import           Data.Typeable                          (Typeable)-import           GHC.Generics                           (Generic)--instance Typeable a => GQLType (Directive a) where-  type KIND (Directive a) = OBJECT-  __typeName = const "__Directive"-  __typeVisibility = const False--data Directive t = Directive-  { name        :: Text-  , description :: Maybe Text-  , locations   :: [DirectiveLocation]-  , args        :: [InputValue t]-  } deriving (Show, Generic, FromJSON)
− src/Data/Morpheus/Schema/DirectiveLocation.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE DeriveAnyClass    #-}-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}--module Data.Morpheus.Schema.DirectiveLocation-  ( DirectiveLocation(..)-  ) where--import           Data.Aeson                  (FromJSON (..))-import           Data.Morpheus.Kind          (ENUM)-import           Data.Morpheus.Types.GQLType (GQLType (KIND, __typeName, __typeVisibility))-import           GHC.Generics--data DirectiveLocation-  = QUERY-  | MUTATION-  | SUBSCRIPTION-  | FIELD-  | FRAGMENT_DEFINITION-  | FRAGMENT_SPREAD-  | INLINE_FRAGMENT-  | VARIABLE_DEFINITION-  | SCHEMA-  | SCALAR-  | OBJECT-  | FIELD_DEFINITION-  | ARGUMENT_DEFINITION-  | INTERFACE-  | UNION-  | ENUM-  | ENUM_VALUE-  | INPUT_OBJECT-  | INPUT_FIELD_DEFINITION-  deriving (Show, Generic, FromJSON)--instance GQLType DirectiveLocation where-  type KIND DirectiveLocation = ENUM-  __typeName = const "__DirectiveLocation"-  __typeVisibility = const False
− src/Data/Morpheus/Schema/EnumValue.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE DeriveAnyClass    #-}-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}--module Data.Morpheus.Schema.EnumValue-  ( EnumValue(..)-  , createEnumValue-  , isEnumOf-  ) where--import           Data.Aeson                  (FromJSON (..))-import           Data.Morpheus.Kind          (OBJECT)-import           Data.Morpheus.Types.GQLType (GQLType (KIND, __typeName, __typeVisibility))-import           Data.Text                   (Text)-import           GHC.Generics--instance GQLType EnumValue where-  type KIND EnumValue = OBJECT-  __typeName = const "__EnumValue"-  __typeVisibility = const False--data EnumValue = EnumValue-  { name              :: Text-  , description       :: Maybe Text-  , isDeprecated      :: Bool-  , deprecationReason :: Maybe Text-  } deriving (Show, Generic, FromJSON)--createEnumValue :: Text -> EnumValue-createEnumValue enumName =-  EnumValue {name = enumName, description = Nothing, isDeprecated = False, deprecationReason = Nothing}--isEnumValue :: Text -> EnumValue -> Bool-isEnumValue inpName enum = inpName == name enum--isEnumOf :: Text -> [EnumValue] -> Bool-isEnumOf enumName enumValues =-  case filter (isEnumValue enumName) enumValues of-    [] -> False-    _  -> True
− src/Data/Morpheus/Schema/Field.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}--module Data.Morpheus.Schema.Field where--import           Data.Aeson-import           Data.Morpheus.Kind                 (OBJECT)-import           Data.Morpheus.Schema.InputValue    (InputValue)-import           Data.Morpheus.Types.GQLType        (GQLType (KIND, __typeName, __typeVisibility))-import           Data.Morpheus.Types.Internal.Value (convertToJSONName)-import           Data.Text                          (Text)-import           Data.Typeable                      (Typeable)-import           GHC.Generics--instance Typeable a => GQLType (Field a) where-  type KIND (Field a) = OBJECT-  __typeName = const "__Field"-  __typeVisibility = const False--data Field t = Field-  { name              :: Text-  , description       :: Maybe Text-  , args              :: [InputValue t]-  , type'             :: t-  , isDeprecated      :: Bool-  , deprecationReason :: Maybe Text-  } deriving (Show, Generic)--instance FromJSON a => FromJSON (Field a) where-  parseJSON = withObject "InputValue" objectParser-    where-      objectParser o =-        Field <$> o .: "name" <*> o .:? "description" <*> o .: "args" <*> o .: "type" <*> o .: "isDeprecated" <*>-        o .:? "deprecationReason"--createFieldWith :: Text -> a -> [InputValue a] -> Field a-createFieldWith _name fieldType fieldArgs =-  Field-    { name = convertToJSONName _name-    , description = Nothing-    , args = fieldArgs-    , type' = fieldType-    , isDeprecated = False-    , deprecationReason = Nothing-    }
− src/Data/Morpheus/Schema/InputValue.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}--module Data.Morpheus.Schema.InputValue-  ( InputValue(..)-  , createInputValueWith-  ) where--import           Data.Aeson-import           Data.Morpheus.Kind          (OBJECT)-import           Data.Morpheus.Types.GQLType (GQLType (KIND, __typeName, __typeVisibility))-import           Data.Text                   (Text)-import           Data.Typeable               (Typeable)-import           GHC.Generics--instance Typeable a => GQLType (InputValue a) where-  type KIND (InputValue a) = OBJECT-  __typeName = const "__InputValue"-  __typeVisibility = const False--data InputValue t = InputValue-  { name         :: Text-  , description  :: Maybe Text-  , type'        :: t-  , defaultValue :: Maybe Text-  } deriving (Show, Generic)--instance FromJSON a => FromJSON (InputValue a) where-  parseJSON = withObject "InputValue" objectParser-    where-      objectParser o = InputValue <$> o .: "name" <*> o .:? "description" <*> o .: "type" <*> o .:? "defaultValue"--createInputValueWith :: Text -> a -> InputValue a-createInputValueWith _name ofType =-  InputValue {name = _name, description = Nothing, type' = ofType, defaultValue = Nothing}
− src/Data/Morpheus/Schema/Internal/RenderIntrospection.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators     #-}--module Data.Morpheus.Schema.Internal.RenderIntrospection-  ( Type-  , Field-  , InputValue-  , renderType-  , createObjectType-  ) where--import           Data.Morpheus.Schema.EnumValue    (EnumValue, createEnumValue)-import qualified Data.Morpheus.Schema.Field        as F (Field (..), createFieldWith)-import qualified Data.Morpheus.Schema.InputValue   as IN (InputValue (..), createInputValueWith)-import           Data.Morpheus.Schema.Type         (Type (..))-import           Data.Morpheus.Schema.TypeKind     (TypeKind (..))-import           Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataInputField, DataInputObject,-                                                    DataLeaf (..), DataOutputField, DataType (..), DataTypeKind (..),-                                                    DataTypeLib, DataTypeWrapper (..), DataUnion, kindOf,-                                                    lookupDataType)-import           Data.Text                         (Text)--type InputValue = IN.InputValue Type--type Result a = DataTypeLib -> Either String a--type Field = F.Field Type--renderType :: (Text, DataFullType) -> Result Type-renderType (name', Leaf leaf') = const $ pure $ typeFromLeaf (name', leaf')-renderType (name', InputObject iObject') = renderInputObject (name', iObject')-renderType (name', OutputObject object') = typeFromObject (name', object')-  where-    typeFromObject (key, DataType {typeData, typeDescription}) lib =-      createObjectType key typeDescription <$>-      (Just <$>-       traverse-         (`fieldFromObjectField` lib)-         (filter (not . fieldHidden . snd) typeData))-renderType (name', Union union') = const $ pure $ typeFromUnion (name', union')-renderType (name', InputUnion inpUnion') = renderInputUnion (name', inpUnion')--renderTypeKind :: DataTypeKind -> TypeKind-renderTypeKind KindScalar      = SCALAR-renderTypeKind KindObject      = OBJECT-renderTypeKind KindUnion       = UNION-renderTypeKind KindInputUnion  = INPUT_OBJECT-renderTypeKind KindEnum        = ENUM-renderTypeKind KindInputObject = INPUT_OBJECT-renderTypeKind KindList        = LIST-renderTypeKind KindNonNull     = NON_NULL--wrap :: DataField a -> Type -> Type-wrap field' = wrapRec (fieldTypeWrappers field')--wrapRec :: [DataTypeWrapper] -> Type -> Type-wrapRec xs type' = foldr wrapByTypeWrapper type' xs--wrapByTypeWrapper :: DataTypeWrapper -> Type -> Type-wrapByTypeWrapper ListType    = wrapAs LIST-wrapByTypeWrapper NonNullType = wrapAs NON_NULL--lookupKind :: Text -> Result DataTypeKind-lookupKind name lib =-  case lookupDataType name lib of-    Nothing    -> Left ""-    Just value -> Right (kindOf value)--fieldFromObjectField :: (Text, DataOutputField) -> Result Field-fieldFromObjectField (key, field'@DataField {fieldType, fieldArgs}) lib = do-  kind <- renderTypeKind <$> lookupKind fieldType lib-  F.createFieldWith key (wrap field' $ createType kind fieldType "" $ Just []) <$>-    traverse (`inputValueFromArg` lib) fieldArgs--typeFromLeaf :: (Text, DataLeaf) -> Type-typeFromLeaf (key, BaseScalar DataType {typeDescription}) =-  createLeafType SCALAR key typeDescription Nothing-typeFromLeaf (key, CustomScalar DataType {typeDescription}) =-  createLeafType SCALAR key typeDescription Nothing-typeFromLeaf (key, LeafEnum DataType {typeDescription, typeData}) =-  createLeafType ENUM key typeDescription (Just $ map createEnumValue typeData)--createLeafType :: TypeKind -> Text -> Text -> Maybe [EnumValue] -> Type-createLeafType kind' name' desc' enums' =-  Type-    { kind = kind'-    , name = Just name'-    , description = Just desc'-    , fields = const $ return Nothing-    , ofType = Nothing-    , interfaces = Nothing-    , possibleTypes = Nothing-    , enumValues = const $ return enums'-    , inputFields = Nothing-    }--typeFromUnion :: (Text, DataUnion) -> Type-typeFromUnion (name', DataType { typeData = fields'-                               , typeDescription = description'-                               }) =-  Type-    { kind = UNION-    , name = Just name'-    , description = Just description'-    , fields = const $ return Nothing-    , ofType = Nothing-    , interfaces = Nothing-    , possibleTypes =-        Just (map (\x -> createObjectType (fieldType x) "" $ Just []) fields')-    , enumValues = const $ return Nothing-    , inputFields = Nothing-    }--inputValueFromArg :: (Text, DataInputField) -> Result InputValue-inputValueFromArg (key, input) =-  fmap (IN.createInputValueWith key) . createInputObjectType input--createInputObjectType :: DataInputField -> Result Type-createInputObjectType field@DataField {fieldType} lib = do-  kind <- renderTypeKind <$> lookupKind fieldType lib-  pure $ wrap field $ createType kind fieldType "" $ Just []--renderInputObject :: (Text, DataInputObject) -> Result Type-renderInputObject (key, DataType {typeData, typeDescription}) lib = do-  fields <- traverse (`inputValueFromArg` lib) typeData-  pure $ createInputObject key typeDescription fields--renderInputUnion :: (Text, DataUnion) -> Result Type-renderInputUnion (key', DataType {typeData, typeDescription}) lib =-  createInputObject key' typeDescription <$> traverse createField typeData-  where-    createField field =-      IN.createInputValueWith (fieldName field) <$>-      createInputObjectType field lib--createObjectType :: Text -> Text -> Maybe [Field] -> Type-createObjectType name' desc' fields' =-  Type-    { kind = OBJECT-    , name = Just name'-    , description = Just desc'-    , fields = const $ return fields'-    , ofType = Nothing-    , interfaces = Just []-    , possibleTypes = Nothing-    , enumValues = const $ return Nothing-    , inputFields = Nothing-    }--createInputObject :: Text -> Text -> [InputValue] -> Type-createInputObject name' desc' fields' =-  Type-    { kind = INPUT_OBJECT-    , name = Just name'-    , description = Just desc'-    , fields = const $ return Nothing-    , ofType = Nothing-    , interfaces = Nothing-    , possibleTypes = Nothing-    , enumValues = const $ return Nothing-    , inputFields = Just fields'-    }--createType :: TypeKind -> Text -> Text -> Maybe [Field] -> Type-createType kind' name' desc' fields' =-  Type-    { kind = kind'-    , name = Just name'-    , description = Just desc'-    , fields = const $ return fields'-    , ofType = Nothing-    , interfaces = Nothing-    , possibleTypes = Nothing-    , enumValues = const $ return $ Just []-    , inputFields = Nothing-    }--wrapAs :: TypeKind -> Type -> Type-wrapAs kind' contentType =-  Type-    { kind = kind'-    , name = Nothing-    , description = Nothing-    , fields = const $ return Nothing-    , ofType = Just contentType-    , interfaces = Nothing-    , possibleTypes = Nothing-    , enumValues = const $ return Nothing-    , inputFields = Nothing-    }
− src/Data/Morpheus/Schema/JSONType.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric  #-}-{-# LANGUAGE TypeFamilies   #-}-{-# LANGUAGE TypeOperators  #-}--module Data.Morpheus.Schema.JSONType-  ( JSONType(..)-  , JSONSchema(..)-  , JSONIntro(..)-  ) where--import           Data.Aeson-import           Data.Text                       (Text)-import           GHC.Generics                    (Generic)------- MORPHEUS-import           Data.Morpheus.Schema.Directive  (Directive)-import           Data.Morpheus.Schema.EnumValue  (EnumValue)-import qualified Data.Morpheus.Schema.Field      as F (Field (..))-import qualified Data.Morpheus.Schema.InputValue as I (InputValue (..))-import           Data.Morpheus.Schema.TypeKind   (TypeKind)--newtype JSONIntro = JSONIntro-  { __schema :: JSONSchema-  } deriving (Generic, Show, FromJSON)--data JSONType = JSONType-  { kind          :: TypeKind-  , name          :: Maybe Text-  , description   :: Maybe Text-  , fields        :: Maybe [F.Field JSONType]-  , interfaces    :: Maybe [JSONType]-  , possibleTypes :: Maybe [JSONType]-  , enumValues    :: Maybe [EnumValue]-  , inputFields   :: Maybe [I.InputValue JSONType]-  , ofType        :: Maybe JSONType-  } deriving (Generic, Show, FromJSON)--data JSONSchema = JSONSchema-  { types      :: [JSONType]-   --, queryType        :: JSONType- -- , mutationType     :: Maybe JSONType- -- , subscriptionType :: Maybe JSONType-  , directives :: [Directive JSONType]-  } deriving (Generic, Show, FromJSON)
src/Data/Morpheus/Schema/Schema.hs view
@@ -1,60 +1,120 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeSynonymInstances  #-}  module Data.Morpheus.Schema.Schema-  ( initSchema-  , findType-  , Schema-  , Type+  ( Root(..)+  , Root__typeArgs(..)+  , S__Schema(..)+  , S__Type(..)+  , S__Field(..)+  , S__EnumValue(..)+  , S__InputValue(..)   ) where -import           Data.Morpheus.Kind                                (OBJECT)-import           Data.Morpheus.Schema.Directive                    (Directive)-import           Data.Morpheus.Schema.Internal.RenderIntrospection (Type, createObjectType, renderType)-import           Data.Morpheus.Types.GQLType                       (GQLType (KIND, __typeName, __typeVisibility))-import           Data.Morpheus.Types.Internal.Data                 (DataOutputObject, DataTypeLib (..), allDataTypes)-import           Data.Text                                         (Text)-import           GHC.Generics                                      (Generic)+import           Data.Text                                (Text) -instance GQLType Schema where-  type KIND Schema = OBJECT-  __typeName = const "__Schema"-  __typeVisibility = const False+-- MORPHEUS+import           Data.Morpheus.Execution.Document.Compile (gqlDocumentNamespace)+import           Data.Morpheus.Schema.TypeKind            (TypeKind) -data Schema = Schema-  { types            :: [Type]-  , queryType        :: Type-  , mutationType     :: Maybe Type-  , subscriptionType :: Maybe Type-  , directives       :: [Directive Type]-  } deriving (Generic)+type S__TypeKind = TypeKind -convertTypes :: DataTypeLib -> [Type]-convertTypes lib =-  case traverse (`renderType` lib) (allDataTypes lib) of-    Left _  -> []-    Right x -> x+[gqlDocumentNamespace|+type __Schema {+  types: [__Type!]!+  queryType: __Type!+  mutationType: __Type+  subscriptionType: __Type+  directives: [__Directive!]!+} -buildSchemaLinkType :: (Text, DataOutputObject) -> Type-buildSchemaLinkType (key', _) = createObjectType key' "" $ Just []+type __Type {+  kind: __TypeKind!+  name: String+  description: String -findType :: Text -> DataTypeLib -> Maybe Type-findType name lib = (name, ) <$> lookup name (allDataTypes lib) >>= renderT-  where-    renderT i =-      case renderType i lib of-        Left _  -> Nothing-        Right x -> Just x+  # OBJECT and INTERFACE only+  fields(includeDeprecated: Boolean ): [__Field!] -initSchema :: DataTypeLib -> Schema-initSchema types' =-  Schema-    { types = convertTypes types'-    , queryType = buildSchemaLinkType $ query types'-    , mutationType = buildSchemaLinkType <$> mutation types'-    , subscriptionType = buildSchemaLinkType <$> subscription types'-    , directives = []-    }+  # OBJECT only+  interfaces: [__Type!]++  # INTERFACE and UNION only+  possibleTypes: [__Type!]++  # ENUM only+  enumValues(includeDeprecated: Boolean): [__EnumValue!]++  # INPUT_OBJECT only+  inputFields: [__InputValue!]++  # NON_NULL and LIST only+  ofType: __Type+}++type __Field {+  name: String!+  description: String+  args: [__InputValue!]!+  type: __Type!+  isDeprecated: Boolean!+  deprecationReason: String+}++type __InputValue {+  name: String!+  description: String+  type: __Type!+  defaultValue: String+}++type __EnumValue {+  name: String!+  description: String+  isDeprecated: Boolean!+  deprecationReason: String+}++type __Directive {+  name: String!+  description: String+  locations: [__DirectiveLocation!]!+  args: [__InputValue!]!+}++enum __DirectiveLocation {+  QUERY+  MUTATION+  SUBSCRIPTION+  FIELD+  FRAGMENT_DEFINITION+  FRAGMENT_SPREAD+  INLINE_FRAGMENT+  VARIABLE_DEFINITION+  SCHEMA+  SCALAR+  OBJECT+  FIELD_DEFINITION+  ARGUMENT_DEFINITION+  INTERFACE+  UNION+  ENUM+  ENUM_VALUE+  INPUT_OBJECT+  INPUT_FIELD_DEFINITION+}++  type Root  {+    __type(name: String!): __Type+    __schema : __Schema!+  }+|]
src/Data/Morpheus/Schema/SchemaAPI.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE DeriveGeneric    #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns   #-}+{-# LANGUAGE TupleSections    #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators    #-} @@ -10,42 +11,64 @@   ) where  import           Data.Proxy-import           Data.Text                                 (Text)-import           GHC.Generics+import           Data.Text                                   (Text)  -- MORPHEUS-import           Data.Morpheus.Execution.Server.Introspect (ObjectRep (..), TypeUpdater, introspectOutputType,-                                                            resolveTypes)-import           Data.Morpheus.Schema.Schema               (Schema, Type, findType, initSchema)-import           Data.Morpheus.Types.ID                    (ID)-import           Data.Morpheus.Types.Internal.Data         (DataField (..), DataOutputField, DataTypeLib (..))+import           Data.Morpheus.Execution.Server.Introspect   (ObjectFields (..), TypeUpdater, introspect, resolveTypes)+import           Data.Morpheus.Rendering.RenderIntrospection (createObjectType, render)+import           Data.Morpheus.Schema.Schema                 (Root (..), Root__typeArgs (..), S__Schema (..), S__Type)+import           Data.Morpheus.Types                         (constRes)+import           Data.Morpheus.Types.GQLType                 (CUSTOM)+import           Data.Morpheus.Types.ID                      (ID)+import           Data.Morpheus.Types.Internal.Data           (DataField (..), DataObject, DataTypeLib (..),+                                                              allDataTypes)+import           Data.Morpheus.Types.Resolver                (GQLFail (..), ResolveT, Resolver) -newtype TypeArgs = TypeArgs-  { name :: Text-  } deriving (Generic)+convertTypes :: Monad m => DataTypeLib -> (Resolver m) [S__Type (Resolver m)]+convertTypes lib = traverse (`render` lib) (allDataTypes lib) -data SchemaAPI = SchemaAPI-  { __type   :: TypeArgs -> Either String (Maybe Type)-  , __schema :: Schema-  } deriving (Generic)+buildSchemaLinkType :: Monad m => (Text, DataObject) -> S__Type (Resolver m)+buildSchemaLinkType (key', _) = createObjectType key' Nothing $ Just [] -hideFields :: (Text, DataField a) -> (Text, DataField a)+findType :: Monad m => Text -> DataTypeLib -> Resolver m (Maybe (S__Type (Resolver m)))+findType name lib = getType >>= renderT+  where+    getType = pure $ (name, ) <$> lookup name (allDataTypes lib)+    ------------------------------------------------------------+    renderT (Just datatype) = toSuccess (const Nothing) Just (render datatype lib)+    renderT Nothing         = pure Nothing++initSchema :: Monad m => DataTypeLib -> (Resolver m) (S__Schema (Resolver m))+initSchema lib =+  pure+    S__Schema+      { s__SchemaTypes = const $ convertTypes lib+      , s__SchemaQueryType = constRes $ buildSchemaLinkType $ query lib+      , s__SchemaMutationType = constRes $ buildSchemaLinkType <$> mutation lib+      , s__SchemaSubscriptionType = constRes $ buildSchemaLinkType <$> subscription lib+      , s__SchemaDirectives = constRes []+      }++hideFields :: (Text, DataField) -> (Text, DataField) hideFields (key', field) = (key', field {fieldHidden = True}) -hiddenRootFields :: [(Text, DataOutputField)]-hiddenRootFields = map (hideFields . fst) $ objectFieldTypes $ Proxy @(Rep SchemaAPI)+hiddenRootFields :: [(Text, DataField)]+hiddenRootFields = map hideFields $ fst $ objectFields (Proxy :: Proxy (CUSTOM (Root Maybe))) (Proxy @(Root Maybe))  defaultTypes :: TypeUpdater defaultTypes =   flip     resolveTypes-    [ introspectOutputType (Proxy @Bool)-    , introspectOutputType (Proxy @Int)-    , introspectOutputType (Proxy @Float)-    , introspectOutputType (Proxy @Text)-    , introspectOutputType (Proxy @ID)-    , introspectOutputType (Proxy @Schema)+    [ introspect (Proxy @Bool)+    , introspect (Proxy @Int)+    , introspect (Proxy @Float)+    , introspect (Proxy @Text)+    , introspect (Proxy @ID)+    , introspect (Proxy @(S__Schema Maybe))     ] -schemaAPI :: DataTypeLib -> SchemaAPI-schemaAPI lib = SchemaAPI {__type = \TypeArgs {name} -> return $ findType name lib, __schema = initSchema lib}+schemaAPI :: Monad m => DataTypeLib -> ResolveT m (Root (Resolver m))+schemaAPI lib = pure $ Root {root__type, root__schema}+  where+    root__type (Root__typeArgs name) = findType name lib+    root__schema _ = initSchema lib
− src/Data/Morpheus/Schema/Type.hs 
@@ -1,43 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE TypeOperators     #-}--module Data.Morpheus.Schema.Type-  ( Type(..)-  , DeprecationArgs(..)-  ) where--import           Data.Morpheus.Kind              (OBJECT)-import           Data.Morpheus.Schema.EnumValue  (EnumValue)-import qualified Data.Morpheus.Schema.Field      as F (Field (..))-import qualified Data.Morpheus.Schema.InputValue as I (InputValue (..))-import           Data.Morpheus.Schema.TypeKind   (TypeKind)-import           Data.Morpheus.Types.GQLType     (GQLType (KIND, __typeName, __typeVisibility))-import           Data.Text                       (Text)-import           GHC.Generics                    (Generic)--instance GQLType Type where-  type KIND Type = OBJECT-  __typeName = const "__Type"-  __typeVisibility = const False--data Type =-  Type-    { kind          :: TypeKind-    , name          :: Maybe Text-    , description   :: Maybe Text-    , fields        :: DeprecationArgs -> Either String (Maybe [F.Field Type])-    , interfaces    :: Maybe [Type]-    , possibleTypes :: Maybe [Type]-    , enumValues    :: DeprecationArgs -> Either String (Maybe [EnumValue])-    , inputFields   :: Maybe [I.InputValue Type]-    , ofType        :: Maybe Type-    }-  deriving (Generic)--newtype DeprecationArgs =-  DeprecationArgs-    { includeDeprecated :: Maybe Bool-    }-  deriving (Generic)
src/Data/Morpheus/Types.hs view
@@ -9,6 +9,7 @@   , IOSubRes   , Resolver   , SubRootRes+  , SubResolver(..)   , Event(..)   -- Type Classes   , GQLType(KIND, description)@@ -19,6 +20,7 @@   , ID(..)   , ScalarValue(..)   , GQLRootResolver(..)+  , constRes   ) where  import           Data.Morpheus.Types.GQLScalar      (GQLScalar (parseValue, serialize))@@ -27,10 +29,14 @@ import           Data.Morpheus.Types.Internal.Value (ScalarValue (..)) import           Data.Morpheus.Types.IO             (GQLRequest (..), GQLResponse (..)) import           Data.Morpheus.Types.Resolver       (Event (..), GQLRootResolver (..), MutResolver, Resolver,-                                                     SubResolver, SubRootRes, mutResolver, resolver, toMutResolver)+                                                     SubResolver (..), SubRootRes, mutResolver, resolver, toMutResolver) +-- resolves constant value on any argument+constRes :: Monad m => b -> a -> m b+constRes = const . return+ type IORes = Resolver IO  type IOMutRes e c = MutResolver IO e c -type IOSubRes e c a = SubResolver IO e c a+type IOSubRes e c = SubResolver IO e c
src/Data/Morpheus/Types/GQLType.hs view
@@ -12,6 +12,8 @@  module Data.Morpheus.Types.GQLType   ( GQLType(..)+  , TRUE+  , FALSE   ) where  import           Data.Map                          (Map)@@ -19,32 +21,38 @@ import           Data.Set                          (Set) import           Data.Text                         (Text, intercalate, pack) import           Data.Typeable                     (TyCon, TypeRep, Typeable, splitTyConApp, tyConFingerprint,-                                                    tyConName, typeRep)+                                                    tyConName, typeRep, typeRepTyCon)  -- MORPHEUS import           Data.Morpheus.Kind import           Data.Morpheus.Types.Custom        (MapKind, Pair) import           Data.Morpheus.Types.Internal.Data (DataFingerprint (..))-import           Data.Morpheus.Types.Resolver      (Resolver)+import           Data.Morpheus.Types.Resolver      (Resolver, SubResolver) +type TRUE = 'True++type FALSE = 'False+ resolverCon :: TyCon-resolverCon = fst $ splitTyConApp $ typeRep $ Proxy @(Resolver Maybe)+resolverCon = typeRepTyCon $ typeRep $ Proxy @(Resolver Maybe) +subResCon :: TyCon+subResCon = typeRepTyCon $ typeRep $ Proxy @(SubResolver Maybe)+ -- | replaces typeName (A,B) with Pair_A_B replacePairCon :: TyCon -> TyCon replacePairCon x   | hsPair == x = gqlPair   where-    hsPair = fst $ splitTyConApp $ typeRep $ Proxy @(Int, Int)-    gqlPair = fst $ splitTyConApp $ typeRep $ Proxy @(Pair Int Int)+    hsPair = typeRepTyCon $ typeRep $ Proxy @(Int, Int)+    gqlPair = typeRepTyCon $ typeRep $ Proxy @(Pair Int Int) replacePairCon x = x  -- Ignores Resolver name  from typeName ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon] ignoreResolver (con, _)-  | con == resolverCon = []-ignoreResolver (con, args) =-  con : concatMap (ignoreResolver . splitTyConApp) args+  | con `elem` [resolverCon, subResCon] = []+ignoreResolver (con, args) = con : concatMap (ignoreResolver . splitTyConApp) args  -- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'. --@@ -62,8 +70,11 @@ --  @ class GQLType a where   type KIND a :: GQL_KIND-  description :: Proxy a -> Text-  description _ = ""+  type KIND a = OBJECT+  type CUSTOM a :: Bool+  type CUSTOM a = FALSE+  description :: Proxy a -> Maybe Text+  description _ = Nothing   __typeVisibility :: Proxy a -> Bool   __typeVisibility = const True   __typeName :: Proxy a -> Text@@ -71,18 +82,18 @@     Proxy a -> Text   __typeName _ = intercalate "_" (getName $ Proxy @a)     where-      getName =-        fmap-          (map (pack . tyConName))-          (map replacePairCon . ignoreResolver . splitTyConApp . typeRep)+      getName = fmap (map (pack . tyConName)) (map replacePairCon . ignoreResolver . splitTyConApp . typeRep)   __typeFingerprint :: Proxy a -> DataFingerprint   default __typeFingerprint :: (Typeable a) =>     Proxy a -> DataFingerprint   __typeFingerprint _ = TypeableFingerprint $ conFingerprints (Proxy @a)     where-      conFingerprints =-        fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep)+      conFingerprints = fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep) +instance GQLType () where+  type KIND () = WRAPPER+  type CUSTOM () = 'False+ instance GQLType Int where   type KIND Int = SCALAR   __typeVisibility = const False@@ -120,19 +131,29 @@   __typeName _ = __typeName (Proxy @a)   __typeFingerprint _ = __typeFingerprint (Proxy @a) -instance (Typeable a, Typeable b, GQLType a, GQLType b) =>-         GQLType (Pair a b) where+instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where   type KIND (Pair a b) = OBJECT -instance (Typeable a, Typeable b, Typeable m, GQLType a, GQLType b) =>-         GQLType (MapKind a b m) where+instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where   type KIND (MapKind a b m) = OBJECT+  __typeName _ = __typeName (Proxy @(Map a b))+  __typeFingerprint _ = __typeFingerprint (Proxy @(Map a b))  instance (Typeable k, Typeable v) => GQLType (Map k v) where   type KIND (Map k v) = WRAPPER +instance GQLType a => GQLType (Either s a) where+  type KIND (Either s a) = WRAPPER+  __typeName _ = __typeName (Proxy @a)+  __typeFingerprint _ = __typeFingerprint (Proxy @a)+ instance GQLType a => GQLType (Resolver m a) where   type KIND (Resolver m a) = WRAPPER+  __typeName _ = __typeName (Proxy @a)+  __typeFingerprint _ = __typeFingerprint (Proxy @a)++instance GQLType a => GQLType (SubResolver m e c a) where+  type KIND (SubResolver m e c a) = WRAPPER   __typeName _ = __typeName (Proxy @a)   __typeFingerprint _ = __typeFingerprint (Proxy @a) 
src/Data/Morpheus/Types/ID.hs view
@@ -16,11 +16,9 @@ -- | default GraphQL type, -- parses only 'String' and 'Int' values, -- serialized always as 'String'-newtype ID =-  ID-    { unpackID :: Text-    }-  deriving (Generic)+newtype ID = ID+  { unpackID :: Text+  } deriving (Show, Generic)  instance GQLType ID where   type KIND ID = SCALAR
src/Data/Morpheus/Types/Internal/AST/Operation.hs view
@@ -5,7 +5,6 @@ module Data.Morpheus.Types.Internal.AST.Operation   ( Operation(..)   , Variable(..)-  , OperationKind(..)   , ValidOperation   , RawOperation   , VariableDefinitions@@ -15,7 +14,7 @@ import           Data.Morpheus.Types.Internal.AST.RawSelection (RawSelectionSet) import           Data.Morpheus.Types.Internal.AST.Selection    (Arguments, SelectionSet) import           Data.Morpheus.Types.Internal.Base             (Collection, Key, Position)-import           Data.Morpheus.Types.Internal.Data             (DataTypeWrapper)+import           Data.Morpheus.Types.Internal.Data             (OperationKind, WrapperD) import           Data.Morpheus.Types.Internal.TH               (apply, liftText, liftTextMap) import           Data.Morpheus.Types.Internal.Value            (Value) import           Language.Haskell.TH.Syntax                    (Lift (..))@@ -28,12 +27,6 @@  type RawOperation = Operation VariableDefinitions RawSelectionSet -data OperationKind-  = QUERY-  | MUTATION-  | SUBSCRIPTION-  deriving (Show, Lift)- data Operation args sel = Operation   { operationName      :: Key   , operationKind      :: OperationKind@@ -49,7 +42,7 @@ data Variable a = Variable   { variableType         :: Key   , isVariableRequired   :: Bool-  , variableTypeWrappers :: [DataTypeWrapper]+  , variableTypeWrappers :: [WrapperD]   , variablePosition     :: Position   , variableValue        :: a   } deriving (Show)
src/Data/Morpheus/Types/Internal/Base.hs view
@@ -8,6 +8,7 @@   , Position   , EnhancedKey(..)   , Location(..)+  , Message   , enhanceKeyWithNull   ) where @@ -24,6 +25,7 @@   } deriving (Show, Generic, FromJSON, ToJSON, Lift)  type Key = Text+type Message = Text  type Collection a = [(Key, a)] 
src/Data/Morpheus/Types/Internal/Data.hs view
@@ -1,22 +1,26 @@-{-# LANGUAGE DeriveLift        #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DefaultSignatures     #-}+{-# LANGUAGE DeriveLift            #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeSynonymInstances  #-}  module Data.Morpheus.Types.Internal.Data   ( Key   , DataScalar   , DataEnum   , DataObject-  , DataInputField   , DataArgument-  , DataOutputField-  , DataInputObject-  , DataOutputObject   , DataUnion-  , DataOutputType-  , DataInputType   , DataArguments   , DataField(..)-  , DataType(..)+  , DataTyCon(..)   , DataLeaf(..)   , DataKind(..)   , DataFullType(..)@@ -26,28 +30,67 @@   , DataTypeKind(..)   , DataFingerprint(..)   , RawDataType(..)+  , ResolverKind(..)+  , WrapperD(..)+  , TypeAlias(..)+  , ArgsType(..)   , isTypeDefined   , initTypeLib   , defineType-  , showWrappedType-  , showFullAstType   , isFieldNullable   , allDataTypes   , lookupDataType   , kindOf+  , toNullableField+  , toListField+  , isObject+  , isInput+  , toHSWrappers+  , isNullable+  , toGQLWrapper+  , isWeaker+  , isVisible+  , isSubscription+  , isOutputObject+  , OperationKind(..)   ) where -import           Data.Morpheus.Types.Internal.Value (Value (..))-import           Data.Text                          (Text)-import qualified Data.Text                          as T (concat)+import           Data.Semigroup                     ((<>))+import qualified Data.Text                          as T (pack, unpack) import           GHC.Fingerprint.Type               (Fingerprint)-import           Language.Haskell.TH.Syntax         (Lift)+import           Language.Haskell.TH.Syntax         (Lift (..)) -type Key = Text+-- MORPHEUS+import           Data.Morpheus.Types.Internal.Base  (Key)+import           Data.Morpheus.Types.Internal.TH    (apply, liftText, liftTextMap)+import           Data.Morpheus.Types.Internal.Value (Value (..)) +data OperationKind+  = Query+  | Subscription+  | Mutation+  deriving (Show, Eq, Lift)++isSubscription :: DataTypeKind -> Bool+isSubscription (KindObject (Just Subscription)) = True+isSubscription _                                = False++isOutputObject :: DataTypeKind -> Bool+isOutputObject (KindObject _) = True+isOutputObject _              = False++isObject :: DataTypeKind -> Bool+isObject (KindObject _)  = True+isObject KindInputObject = True+isObject _               = False++isInput :: DataTypeKind -> Bool+isInput KindInputObject = True+isInput _               = False+ data DataTypeKind   = KindScalar-  | KindObject+  | KindObject (Maybe OperationKind)   | KindUnion   | KindEnum   | KindInputObject@@ -56,39 +99,65 @@   | KindInputUnion   deriving (Eq, Show, Lift) +data ResolverKind+  = PlainResolver+  | TypeVarResolver+  | ExternalResolver+  deriving (Show, Eq, Lift)++data WrapperD+  = ListD+  | MaybeD+  deriving (Show, Lift)++isFieldNullable :: DataField -> Bool+isFieldNullable = isNullable . aliasWrappers . fieldType++isNullable :: [WrapperD] -> Bool+isNullable (MaybeD:_) = True+isNullable _          = False++isWeaker :: [WrapperD] -> [WrapperD] -> Bool+isWeaker (MaybeD:xs1) (MaybeD:xs2) = isWeaker xs1 xs2+isWeaker (MaybeD:_) _              = True+isWeaker (_:xs1) (_:xs2)           = isWeaker xs1 xs2+isWeaker _ _                       = False++toGQLWrapper :: [WrapperD] -> [DataTypeWrapper]+toGQLWrapper (MaybeD:(MaybeD:tw)) = toGQLWrapper (MaybeD : tw)+toGQLWrapper (MaybeD:(ListD:tw))  = ListType : toGQLWrapper tw+toGQLWrapper (ListD:tw)           = [NonNullType, ListType] <> toGQLWrapper tw+toGQLWrapper [MaybeD]             = []+toGQLWrapper []                   = [NonNullType]++toHSWrappers :: [DataTypeWrapper] -> [WrapperD]+toHSWrappers (NonNullType:(NonNullType:xs)) = toHSWrappers (NonNullType : xs)+toHSWrappers (NonNullType:(ListType:xs))    = ListD : toHSWrappers xs+toHSWrappers (ListType:xs)                  = [MaybeD, ListD] <> toHSWrappers xs+toHSWrappers []                             = [MaybeD]+toHSWrappers [NonNullType]                  = []+ data DataFingerprint-  = SystemFingerprint Text+  = SystemFingerprint Key   | TypeableFingerprint [Fingerprint]   deriving (Show, Eq, Ord)  newtype DataValidator = DataValidator-  { validateValue :: Value -> Either Text Value+  { validateValue :: Value -> Either Key Value   }  instance Show DataValidator where   show _ = "DataValidator" -type DataScalar = DataType DataValidator--type DataEnum = DataType [Key]--type DataObject a = DataType [(Key, a)]--type DataInputField = DataField ()--type DataArgument = DataInputField--type DataOutputField = DataField [(Key, DataArgument)]--type DataInputObject = DataObject DataInputField+type DataScalar = DataTyCon DataValidator -type DataOutputObject = DataObject DataOutputField+type DataEnum = DataTyCon [Key] -type DataUnion = DataType [DataField ()]+type DataObject = DataTyCon [(Key, DataField)] -type DataOutputType = DataKind DataOutputField+type DataArgument = DataField -type DataInputType = DataKind DataInputField+type DataUnion = DataTyCon [DataField]  type DataArguments = [(Key, DataArgument)] @@ -97,22 +166,43 @@   | NonNullType   deriving (Show, Lift) -data DataField a = DataField-  { fieldArgs         :: a-  , fieldName         :: Text-  , fieldType         :: Text-  , fieldTypeWrappers :: [DataTypeWrapper]-  , fieldHidden       :: Bool+data TypeAlias = TypeAlias+  { aliasTyCon    :: Key+  , aliasArgs     :: Maybe Key+  , aliasWrappers :: [WrapperD]   } deriving (Show) -isFieldNullable :: DataField a -> Bool-isFieldNullable DataField {fieldTypeWrappers = NonNullType:_} = False-isFieldNullable _                                             = True+instance Lift TypeAlias where+  lift TypeAlias {aliasTyCon = x, aliasArgs, aliasWrappers} =+    [|TypeAlias {aliasTyCon = name, aliasArgs = T.pack <$> args, aliasWrappers}|]+    where+      name = T.unpack x+      args = T.unpack <$> aliasArgs -data DataType a = DataType-  { typeName        :: Text+data ArgsType = ArgsType+  { argsTypeName :: Key+  , resKind      :: ResolverKind+  } deriving (Show)++instance Lift ArgsType where+  lift (ArgsType argT kind) = apply 'ArgsType [liftText argT, lift kind]++data DataField = DataField+  { fieldName     :: Key+  , fieldArgs     :: [(Key, DataArgument)]+  , fieldArgsType :: Maybe ArgsType+  , fieldType     :: TypeAlias+  , fieldHidden   :: Bool+  } deriving (Show)++instance Lift DataField where+  lift (DataField name args argsT ft hid) =+    apply 'DataField [liftText name, liftTextMap args, lift argsT, lift ft, lift hid]++data DataTyCon a = DataTyCon+  { typeName        :: Key   , typeFingerprint :: DataFingerprint-  , typeDescription :: Text+  , typeDescription :: Maybe Key   , typeVisibility  :: Bool   , typeData        :: a   } deriving (Show)@@ -123,56 +213,46 @@   | LeafEnum DataEnum   deriving (Show) -data DataKind a+-- DATA KIND+data DataKind   = ScalarKind DataScalar   | EnumKind DataEnum-  | ObjectKind (DataObject a)+  | ObjectKind DataObject   | UnionKind DataUnion   deriving (Show)  data RawDataType   = FinalDataType DataFullType-  | Interface DataOutputObject+  | Interface DataObject   | Implements { implementsInterfaces :: [Key]-               , unImplements         :: DataOutputObject }+               , unImplements         :: DataObject }   deriving (Show)  data DataFullType   = Leaf DataLeaf-  | InputObject DataInputObject-  | OutputObject DataOutputObject+  | InputObject DataObject+  | OutputObject DataObject   | Union DataUnion   | InputUnion DataUnion   deriving (Show)  data DataTypeLib = DataTypeLib-  { leaf         :: [(Text, DataLeaf)]-  , inputObject  :: [(Text, DataInputObject)]-  , object       :: [(Text, DataOutputObject)]-  , union        :: [(Text, DataUnion)]-  , inputUnion   :: [(Text, DataUnion)]-  , query        :: (Text, DataOutputObject)-  , mutation     :: Maybe (Text, DataOutputObject)-  , subscription :: Maybe (Text, DataOutputObject)+  { leaf         :: [(Key, DataLeaf)]+  , inputObject  :: [(Key, DataObject)]+  , object       :: [(Key, DataObject)]+  , union        :: [(Key, DataUnion)]+  , inputUnion   :: [(Key, DataUnion)]+  , query        :: (Key, DataObject)+  , mutation     :: Maybe (Key, DataObject)+  , subscription :: Maybe (Key, DataObject)   } deriving (Show) -showWrappedType :: [DataTypeWrapper] -> Text -> Text-showWrappedType [] type'               = type'-showWrappedType (ListType:xs) type'    = T.concat ["[", showWrappedType xs type', "]"]-showWrappedType (NonNullType:xs) type' = T.concat [showWrappedType xs type', "!"]--showFullAstType :: [DataTypeWrapper] -> DataKind a -> Text-showFullAstType wrappers' (ScalarKind x) = showWrappedType wrappers' (typeName x)-showFullAstType wrappers' (EnumKind x)   = showWrappedType wrappers' (typeName x)-showFullAstType wrappers' (ObjectKind x) = showWrappedType wrappers' (typeName x)-showFullAstType wrappers' (UnionKind x)  = showWrappedType wrappers' (typeName x)--initTypeLib :: (Text, DataOutputObject) -> DataTypeLib-initTypeLib query' =+initTypeLib :: (Key, DataObject) -> DataTypeLib+initTypeLib query =   DataTypeLib     { leaf = []     , inputObject = []-    , query = query'+    , query = query     , object = []     , union = []     , inputUnion = []@@ -180,7 +260,7 @@     , subscription = Nothing     } -allDataTypes :: DataTypeLib -> [(Text, DataFullType)]+allDataTypes :: DataTypeLib -> [(Key, DataFullType)] allDataTypes (DataTypeLib leaf' inputObject' object' union' inputUnion' query' mutation' subscription') =   packType OutputObject query' :   fromMaybeType mutation' ++@@ -190,11 +270,11 @@   map (packType InputUnion) inputUnion' ++ map (packType OutputObject) object' ++ map (packType Union) union'   where     packType f (x, y) = (x, f y)-    fromMaybeType :: Maybe (Text, DataOutputObject) -> [(Text, DataFullType)]+    fromMaybeType :: Maybe (Key, DataObject) -> [(Key, DataFullType)]     fromMaybeType (Just (key', dataType')) = [(key', OutputObject dataType')]     fromMaybeType Nothing                  = [] -lookupDataType :: Text -> DataTypeLib -> Maybe DataFullType+lookupDataType :: Key -> DataTypeLib -> Maybe DataFullType lookupDataType name lib = name `lookup` allDataTypes lib  kindOf :: DataFullType -> DataTypeKind@@ -202,25 +282,40 @@ kindOf (Leaf (CustomScalar _)) = KindScalar kindOf (Leaf (LeafEnum _))     = KindEnum kindOf (InputObject _)         = KindInputObject-kindOf (OutputObject _)        = KindObject+kindOf (OutputObject _)        = KindObject Nothing kindOf (Union _)               = KindUnion kindOf (InputUnion _)          = KindInputUnion -isTypeDefined :: Text -> DataTypeLib -> Maybe DataFingerprint-isTypeDefined name lib = getTypeFingerprint <$> lookupDataType name lib-  where-    getTypeFingerprint :: DataFullType -> DataFingerprint-    getTypeFingerprint (Leaf (BaseScalar dataType'))   = typeFingerprint dataType'-    getTypeFingerprint (Leaf (CustomScalar dataType')) = typeFingerprint dataType'-    getTypeFingerprint (Leaf (LeafEnum dataType'))     = typeFingerprint dataType'-    getTypeFingerprint (InputObject dataType')         = typeFingerprint dataType'-    getTypeFingerprint (OutputObject dataType')        = typeFingerprint dataType'-    getTypeFingerprint (Union dataType')               = typeFingerprint dataType'-    getTypeFingerprint (InputUnion dataType')          = typeFingerprint dataType'+fromDataType :: (DataTyCon () -> v) -> DataFullType -> v+fromDataType f (Leaf (BaseScalar dt))   = f dt {typeData = ()}+fromDataType f (Leaf (CustomScalar dt)) = f dt {typeData = ()}+fromDataType f (Leaf (LeafEnum dt))     = f dt {typeData = ()}+fromDataType f (Union dt)               = f dt {typeData = ()}+fromDataType f (InputObject dt)         = f dt {typeData = ()}+fromDataType f (InputUnion dt)          = f dt {typeData = ()}+fromDataType f (OutputObject dt)        = f dt {typeData = ()} -defineType :: (Text, DataFullType) -> DataTypeLib -> DataTypeLib+isVisible :: DataFullType -> Bool+isVisible = fromDataType typeVisibility++isTypeDefined :: Key -> DataTypeLib -> Maybe DataFingerprint+isTypeDefined name lib = fromDataType typeFingerprint <$> lookupDataType name lib++defineType :: (Key, DataFullType) -> DataTypeLib -> DataTypeLib defineType (key', Leaf type') lib         = lib {leaf = (key', type') : leaf lib} defineType (key', InputObject type') lib  = lib {inputObject = (key', type') : inputObject lib} defineType (key', OutputObject type') lib = lib {object = (key', type') : object lib} defineType (key', Union type') lib        = lib {union = (key', type') : union lib} defineType (key', InputUnion type') lib   = lib {inputUnion = (key', type') : inputUnion lib}++toNullableField :: DataField -> DataField+toNullableField dataField+  | isNullable (aliasWrappers $ fieldType dataField) = dataField+  | otherwise = dataField {fieldType = nullable (fieldType dataField)}+  where+    nullable alias@TypeAlias {aliasWrappers} = alias {aliasWrappers = MaybeD : aliasWrappers}++toListField :: DataField -> DataField+toListField dataField = dataField {fieldType = listW (fieldType dataField)}+  where+    listW alias@TypeAlias {aliasWrappers} = alias {aliasWrappers = ListD : aliasWrappers}
src/Data/Morpheus/Types/Internal/DataD.hs view
@@ -1,38 +1,23 @@ {-# LANGUAGE DeriveLift #-}  module Data.Morpheus.Types.Internal.DataD-  ( FieldD(..)-  , TypeD(..)+  ( TypeD(..)   , ConsD(..)   , QueryD(..)-  , AppD(..)-  , GQLTypeD-  , gqlToHSWrappers+  , GQLTypeD(..)   ) where  import           Language.Haskell.TH.Syntax        (Lift (..))  -- -- MORPHEUS-import           Data.Morpheus.Types.Internal.Data (DataTypeKind, DataTypeWrapper (..))--data AppD a-  = ListD (AppD a)-  | MaybeD (AppD a)-  | ResD String-         String-         (AppD a)-  | BaseD a-  deriving (Show, Lift)--gqlToHSWrappers :: [DataTypeWrapper] -> a -> AppD a-gqlToHSWrappers []                             = MaybeD . BaseD-gqlToHSWrappers [NonNullType]                  = BaseD-gqlToHSWrappers (NonNullType:(ListType:xs))    = ListD . gqlToHSWrappers xs-gqlToHSWrappers (NonNullType:(NonNullType:xs)) = gqlToHSWrappers xs-gqlToHSWrappers (ListType:xs)                  = MaybeD . ListD . gqlToHSWrappers xs+import           Data.Morpheus.Types.Internal.Data (DataField, DataTypeKind) -type GQLTypeD = (TypeD, DataTypeKind, [TypeD])+data GQLTypeD = GQLTypeD+  { typeD     :: TypeD+  , typeKindD :: DataTypeKind+  , typeArgD  :: [TypeD]+  } deriving (Show, Lift)  data QueryD = QueryD   { queryText     :: String@@ -40,11 +25,6 @@   , queryArgTypes :: [TypeD]   } deriving (Show, Lift) -data FieldD = FieldD-  { fieldNameD :: String-  , fieldTypeD :: AppD String-  } deriving (Show, Lift)- data TypeD = TypeD   { tName :: String   , tCons :: [ConsD]@@ -52,5 +32,5 @@  data ConsD = ConsD   { cName   :: String-  , cFields :: [FieldD]+  , cFields :: [DataField]   } deriving (Show, Lift)
src/Data/Morpheus/Types/Internal/Stream.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE DeriveFunctor  #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE TypeFamilies      #-}  module Data.Morpheus.Types.Internal.Stream   ( StreamState(..)@@ -15,29 +17,55 @@   , ResponseStream   , closeStream   , mapS+  , injectEvents+  , initExceptStream+  , GQLStream(..)   ) where -import           Data.Morpheus.Types.IO (GQLResponse)+import           Control.Monad.Trans.Except        (ExceptT (..), runExceptT)+import           Data.Morpheus.Types.Internal.Data (OperationKind (..))+import           Data.Morpheus.Types.IO            (GQLResponse) -data Event e c =-  Event-    { channels :: [e]-    , content  :: c-    }+newtype GQLStream (o :: OperationKind) (m :: * -> *) event a = GQLStream+  { unGQLStream :: StreamT m (CHANNEL o m event a) (RESOLVER o m event a)+  } -data StreamState c v =-  StreamState-    { streamEvents :: [c]-    , streamValue  :: v-    }-  deriving (Functor)+instance Functor m => Functor (GQLStream 'Query m event) where+  fmap f (GQLStream x) = GQLStream (f <$> x) +instance Functor m => Functor (GQLStream 'Mutation m event) where+  fmap f (GQLStream x) = GQLStream (f <$> x)++class STREAM (o :: OperationKind) where+  type RESOLVER o (m :: * -> *) event a :: *+  type CHANNEL o (m :: * -> *) event a :: *++instance STREAM 'Query where+  type CHANNEL 'Query m event a = ()+  type RESOLVER 'Query m event a = a++instance STREAM 'Mutation where+  type CHANNEL 'Mutation m event a = event+  type RESOLVER 'Mutation m event a = a++instance STREAM 'Subscription where+  type CHANNEL 'Subscription m (Event channel content) a = channel+  type RESOLVER 'Subscription m event a = event -> m a++data Event e c = Event+  { channels :: [e]+  , content  :: c+  }++data StreamState c v = StreamState+  { streamEvents :: [c]+  , streamValue  :: v+  } deriving (Functor)+ -- | Monad Transformer that sums all effect Together-newtype StreamT m s a =-  StreamT-    { runStreamT :: m (StreamState s a)-    }-  deriving (Functor)+newtype StreamT m s a = StreamT+  { runStreamT :: m (StreamState s a)+  } deriving (Functor)  instance Monad m => Applicative (StreamT m c) where   pure = StreamT . return . StreamState []@@ -69,7 +97,7 @@  type PublishStream m e c = StreamT m (PubEvent e c) -type ResponseStream m event con a = StreamT m (ResponseEvent m event con) a+type ResponseStream m event con = StreamT m (ResponseEvent m event con)  -- Helper Functions toTuple :: StreamState s a -> ([s], a)@@ -83,3 +111,9 @@   StreamT $ do     state <- ma     return $ state {streamEvents = map func (streamEvents state)}++injectEvents :: Functor m => [event] -> ExceptT e m a -> ExceptT e (StreamT m event) a+injectEvents states = ExceptT . StreamT . fmap (StreamState states) . runExceptT++initExceptStream :: Applicative m => [event] -> a -> ExceptT e (StreamT m event) a+initExceptStream events = ExceptT . StreamT . pure . StreamState events . Right
src/Data/Morpheus/Types/Internal/TH.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TemplateHaskell #-}  module Data.Morpheus.Types.Internal.TH where +import           Data.Text                  (Text, pack, unpack) import           Language.Haskell.TH import           Language.Haskell.TH.Syntax-import           Data.Text                  (Text, pack, unpack) - liftText :: Text -> ExpQ liftText x = appE (varE 'pack) (lift (unpack x)) @@ -18,3 +17,18 @@  apply :: Name -> [Q Exp] -> Q Exp apply n = foldl appE (conE n)++applyT :: Name -> [Q Type] -> Q Type+applyT name = foldl appT (conT name)++typeT :: Name -> [String] -> Q Type+typeT name li = applyT name (map (varT . mkName) li)++instanceHeadT :: Name -> String -> [String] -> Q Type+instanceHeadT cName iType tArgs = applyT cName [applyT (mkName iType) (map (varT . mkName) tArgs)]++instanceFunD :: Name -> [String] -> Q Exp -> Q Dec+instanceFunD name args body = funD name [clause (map (varP . mkName) args) (normalB body) []]++instanceHeadMultiT :: Name -> Q Type -> [Q Type] -> Q Type+instanceHeadMultiT className iType li = applyT className (iType : li)
src/Data/Morpheus/Types/Internal/Validation.hs view
@@ -32,9 +32,9 @@   , locations :: [Location]   } deriving (Show, Generic, FromJSON, ToJSON) -type Validation a = Either GQLErrors a+type Validation = Either GQLErrors -type SchemaValidation a = Validation a+type SchemaValidation = Validation  type ResolveT = ExceptT GQLErrors 
src/Data/Morpheus/Types/Internal/Value.hs view
@@ -1,11 +1,16 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE DeriveLift        #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE DeriveLift          #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TupleSections       #-}  module Data.Morpheus.Types.Internal.Value   ( Value(..)   , ScalarValue(..)+  , Object+  , GQLValue(..)   , replaceValue   , decodeScientific   , convertToJSONName@@ -13,8 +18,8 @@   ) where  import qualified Data.Aeson                      as A (FromJSON (..), ToJSON (..), Value (..), object, pairs, (.=))+import           Data.Function                   ((&)) import qualified Data.HashMap.Strict             as M (toList)-import           Data.Morpheus.Types.Internal.TH (apply, liftText, liftTextMap) import           Data.Scientific                 (Scientific, floatingOrInteger) import           Data.Semigroup                  ((<>)) import           Data.Text                       (Text)@@ -24,6 +29,9 @@ import           Language.Haskell.TH import           Language.Haskell.TH.Syntax +-- MORPHEUS+import           Data.Morpheus.Types.Internal.TH (apply, liftText, liftTextMap)+ isReserved :: Text -> Bool isReserved "case"     = True isReserved "class"    = True@@ -97,8 +105,10 @@   lift (Scalar n)  = apply 'Scalar [lift n]   lift Null        = varE 'Null +type Object = [(Text, Value)]+ data Value-  = Object [(Text, Value)]+  = Object Object   | List [Value]   | Enum Text   | Scalar ScalarValue@@ -115,9 +125,6 @@     where       encodeField (key, value) = convertToJSONName key A..= value -replace :: (a, A.Value) -> (a, Value)-replace (key, val) = (key, replaceValue val)- decodeScientific :: Scientific -> ScalarValue decodeScientific v =   case floatingOrInteger v of@@ -125,12 +132,64 @@     Right int  -> Int int  replaceValue :: A.Value -> Value-replaceValue (A.Bool v)   = Scalar $ Boolean v+replaceValue (A.Bool v) = gqlBoolean v replaceValue (A.Number v) = Scalar $ decodeScientific v-replaceValue (A.String v) = Scalar $ String v-replaceValue (A.Object v) = Object $ map replace (M.toList v)-replaceValue (A.Array li) = List (map replaceValue (V.toList li))-replaceValue A.Null       = Null+replaceValue (A.String v) = gqlString v+replaceValue (A.Object v) = gqlObject $ map replace (M.toList v)+  where+    replace :: (a, A.Value) -> (a, Value)+    replace (key, val) = (key, replaceValue val)+replaceValue (A.Array li) = gqlList (map replaceValue (V.toList li))+replaceValue A.Null = gqlNull  instance A.FromJSON Value where   parseJSON = pure . replaceValue++-- DEFAULT VALUES+class GQLValue a where+  gqlNull :: a+  gqlScalar :: ScalarValue -> a+  gqlBoolean :: Bool -> a+  gqlString :: Text -> a+  gqlList :: [a] -> a+  gqlObject :: [(Text, a)] -> a++-- build GQL Values for Subscription Resolver+instance GQLValue Value where+  gqlNull = Null+  gqlScalar = Scalar+  gqlBoolean = Scalar . Boolean+  gqlString = Scalar . String+  gqlList = List+  gqlObject = Object++instance Monad m => GQLValue (m Value) where+  gqlNull = pure gqlNull+  gqlScalar = pure . gqlScalar+  gqlBoolean = pure . gqlBoolean+  gqlString = pure . gqlString+  -----------------------------------------+  -- listValue :: [m Value] -> m Value+  gqlList = fmap gqlList . sequence+  -----------------------------------------+  -- objectValue :: [(Text, m Value )] -> m Value+  gqlObject = fmap gqlObject . traverse keyVal+    where+      keyVal :: Monad m => (Text, m Value) -> m (Text, Value)+      keyVal (key, valFunc) = (key, ) <$> valFunc++-- build GQL Values for Subscription Resolver+instance Monad m => GQLValue (args -> m Value) where+  gqlNull = const gqlNull+  gqlScalar = const . gqlScalar+  gqlBoolean = pure . gqlBoolean+  gqlString = const . gqlString+  ----------------------------------------+   -- listValue :: [args -> m Value] -> ( args -> m Value )+  gqlList res args = gqlList <$> traverse (args &) res+  ----------------------------------------+  -- objectValue :: [(Text, args -> m Value )] -> ( args -> m Value )+  gqlObject res args = gqlObject <$> traverse keyVal res+    where+      keyVal :: Monad m => (Text, args -> m Value) -> m (Text, Value)+      keyVal (key, valFunc) = (key, ) <$> valFunc args
src/Data/Morpheus/Types/Resolver.hs view
@@ -12,40 +12,74 @@   ( Pure   , Resolver   , MutResolver-  , SubResolver+  , SubResolver(..)   , ResolveT   , SubResolveT   , MutResolveT   , SubRootRes   , Event(..)   , GQLRootResolver(..)+  , UnSubResolver   , resolver   , mutResolver   , toMutResolver+  , GQLFail(..)+  , ResponseT   ) where  import           Control.Monad.Trans.Except              (ExceptT (..), runExceptT)+import           Data.Text                               (pack, unpack)  -- MORPHEUS ---import           Data.Morpheus.Types.Internal.Stream     (Event (..), PublishStream, StreamState (..), StreamT (..),-                                                          SubscribeStream)+import           Data.Morpheus.Types.Internal.Base       (Message)+import           Data.Morpheus.Types.Internal.Stream     (Event (..), PublishStream, ResponseStream, StreamState (..),+                                                          StreamT (..), SubscribeStream) import           Data.Morpheus.Types.Internal.Validation (ResolveT) --- SubResolver m (Event [c1, c2] d) a+class Monad m =>+      GQLFail (t :: (* -> *) -> * -> *) m+  where+  gqlFail :: Monad m => Message -> t m a+  toSuccess :: Monad m => (Message -> b) -> (a -> b) -> t m a -> t m b++instance Monad m => GQLFail Resolver m where+  gqlFail = ExceptT . pure . Left . unpack+  toSuccess fFail fSuc (ExceptT value) = ExceptT $ pure . mapCases <$> value+    where+      mapCases (Right x) = fSuc x+      mapCases (Left x)  = fFail $ pack $ show x+ -----------------------------------------------------------------------------------------type MutResolveT m e c a = ResolveT (PublishStream m e c) a+{--+newtype SubResolveT m e c a = SubResolveT+  { unSubResolveT :: ResolveT (SubscribeStream m e) (Event e c -> ResolveT m a)+  } +newtype MutResolveT m e c a = MutResolveT+  { unMutResolveT :: ResolveT (PublishStream m e c) a+  }+-}+data SubResolver m e c a = SubResolver+  { subChannels :: [e]+  , subResolver :: Event e c -> Resolver m a+  }++type family UnSubResolver (a :: * -> *) :: (* -> *)++type instance UnSubResolver (SubResolver m e c) = Resolver m+ ------------------------------------------------------------------- type Resolver = ExceptT String -type MutResolver m e c = Resolver (PublishStream m e c)+type ResponseT m e c = ResolveT (ResponseStream m e c) -type SubResolver m e c a = Event e (Event e c -> Resolver m a)+type MutResolveT m e c = ResolveT (PublishStream m e c) -type SubResolveT m e c a-   = ResolveT (SubscribeStream m e) (Event e c -> ResolveT m a)+type SubResolveT m e c a = ResolveT (SubscribeStream m e) (Event e c -> ResolveT m a) +type MutResolver m e c = Resolver (PublishStream m e c)+ type SubRootRes m e sub = Resolver (SubscribeStream m e) sub  -------------------------------------------------------------------@@ -57,15 +91,10 @@ resolver = ExceptT  toMutResolver :: Monad m => [Event e c] -> Resolver m a -> MutResolver m e c a-toMutResolver channels =-  ExceptT . StreamT . fmap (StreamState channels) . runExceptT+toMutResolver channels = ExceptT . StreamT . fmap (StreamState channels) . runExceptT  -- | GraphQL Resolver for mutation or subscription resolver , adds effect to normal resolver-mutResolver ::-     Monad m-  => [Event e c]-  -> (StreamT m (Event e c)) (Either String a)-  -> MutResolver m e c a+mutResolver :: Monad m => [Event e c] -> (StreamT m (Event e c)) (Either String a) -> MutResolver m e c a mutResolver channels = ExceptT . StreamT . fmap effectPlus . runStreamT   where     effectPlus state = state {streamEvents = channels ++ streamEvents state}@@ -74,9 +103,8 @@ -- --  'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional, --  if your schema does not supports __mutation__ or __subscription__ , you acn use __()__ for it.-data GQLRootResolver m e c query mut sub =-  GQLRootResolver-    { queryResolver        :: Resolver m query-    , mutationResolver     :: Resolver (PublishStream m e c) mut-    , subscriptionResolver :: SubRootRes m e sub-    }+data GQLRootResolver m e c query mut sub = GQLRootResolver+  { queryResolver        :: Resolver m query+  , mutationResolver     :: Resolver (PublishStream m e c) mut+  , subscriptionResolver :: SubRootRes m e sub+  }
src/Data/Morpheus/Validation/Document/Validation.hs view
@@ -9,12 +9,10 @@ -- -- Morpheus import           Data.Morpheus.Error.Document.Interface  (ImplementsError (..), partialImplements, unknownInterface)-import           Data.Morpheus.Types.Internal.Base       (Location (..))-import           Data.Morpheus.Types.Internal.Data       (DataField (..), DataFullType (..), DataOutputField,-                                                          DataOutputObject, DataType (..), Key, RawDataType (..),-                                                          showWrappedType)+import           Data.Morpheus.Rendering.RenderGQL       (RenderGQL (..))+import           Data.Morpheus.Types.Internal.Data       (DataField (..), DataFullType (..), DataObject, DataTyCon (..),+                                                          Key, RawDataType (..), TypeAlias (..), isWeaker, isWeaker) import           Data.Morpheus.Types.Internal.Validation (Validation)-import           Data.Morpheus.Validation.Internal.Utils (isEqOrStricter)  validatePartialDocument :: [(Key, RawDataType)] -> Validation [(Key, DataFullType)] validatePartialDocument lib = catMaybes <$> traverse validateType lib@@ -26,28 +24,29 @@     -----------------------------------     asTuple name x = Just (name, x)     ------------------------------------    mustImplement :: DataOutputObject -> [Key] -> Validation DataFullType+    mustImplement :: DataObject -> [Key] -> Validation DataFullType     mustImplement object interfaceKey = do       interface <- traverse getInterfaceByKey interfaceKey       case concatMap (mustBeSubset object) interface of         []     -> pure $ OutputObject object-        errors -> Left $ partialImplements (typeName object)  errors+        errors -> Left $ partialImplements (typeName object) errors     --------------------------------    mustBeSubset :: DataOutputObject -> DataOutputObject -> [(Key, Key, ImplementsError)]-    mustBeSubset DataType {typeData = objFields} DataType {typeName, typeData = interfaceFields} =+    mustBeSubset :: DataObject -> DataObject -> [(Key, Key, ImplementsError)]+    mustBeSubset DataTyCon {typeData = objFields} DataTyCon {typeName, typeData = interfaceFields} =       concatMap checkField interfaceFields       where-        checkField :: (Key, DataOutputField) -> [(Key, Key, ImplementsError)]-        checkField (key, DataField {fieldType = interfaceTypeName, fieldTypeWrappers = interfaceWrappers}) =+        checkField :: (Key, DataField) -> [(Key, Key, ImplementsError)]+        checkField (key, DataField {fieldType = interfaceT@TypeAlias { aliasTyCon = interfaceTypeName+                                                                     , aliasWrappers = interfaceWrappers+                                                                     }}) =           case lookup key objFields of-            Just DataField {fieldType, fieldTypeWrappers}-              | fieldType == interfaceTypeName && isEqOrStricter fieldTypeWrappers interfaceWrappers -> []-              | otherwise -> [(typeName, key, UnexpectedType {expectedType, foundType})]-              where expectedType = showWrappedType interfaceWrappers interfaceTypeName-                    foundType = showWrappedType fieldTypeWrappers fieldType+            Just DataField {fieldType = objT@TypeAlias {aliasTyCon, aliasWrappers}}+              | aliasTyCon == interfaceTypeName && not (isWeaker aliasWrappers interfaceWrappers) -> []+              | otherwise ->+                [(typeName, key, UnexpectedType {expectedType = render interfaceT, foundType = render objT})]             Nothing -> [(typeName, key, UndefinedField)]     --------------------------------    getInterfaceByKey :: Key -> Validation DataOutputObject+    getInterfaceByKey :: Key -> Validation DataObject     getInterfaceByKey key =       case lookup key lib of         Just (Interface x) -> pure x
src/Data/Morpheus/Validation/Internal/Utils.hs view
@@ -6,15 +6,13 @@   , lookupField   , checkNameCollision   , checkForUnknownKeys-  , isEqOrStricter   , VALIDATION_MODE(..)   ) where  import           Data.List                               ((\\)) import           Data.Morpheus.Error.Variable            (unknownType) import           Data.Morpheus.Types.Internal.Base       (EnhancedKey (..), Key, Position, enhanceKeyWithNull)-import           Data.Morpheus.Types.Internal.Data       (DataInputType, DataKind (..), DataLeaf (..), DataOutputObject,-                                                          DataTypeLib (..), DataTypeWrapper (..))+import           Data.Morpheus.Types.Internal.Data       (DataKind (..), DataLeaf (..), DataObject, DataTypeLib (..)) import           Data.Morpheus.Types.Internal.Validation (Validation) import qualified Data.Set                                as S import           Data.Text                               (Text)@@ -38,7 +36,7 @@     Nothing    -> Left error'     Just field -> pure field -getInputType :: Text -> DataTypeLib -> GenError error DataInputType+getInputType :: Text -> DataTypeLib -> GenError error DataKind getInputType typeName' lib error' =   case lookup typeName' (inputObject lib) of     Just x -> pure (ObjectKind x)@@ -52,7 +50,7 @@             Just (CustomScalar x) -> pure (ScalarKind x)             Just (LeafEnum x)     -> pure (EnumKind x) -existsObjectType :: Position -> Text -> DataTypeLib -> Validation DataOutputObject+existsObjectType :: Position -> Text -> DataTypeLib -> Validation DataObject existsObjectType position' typeName' lib = lookupType error' (object lib) typeName'   where     error' = unknownType typeName' position'@@ -77,10 +75,3 @@   case filter (not . elementOfKeys keys') enhancedKeys' of     []           -> pure enhancedKeys'     unknownKeys' -> Left $ errorGenerator' unknownKeys'--isEqOrStricter :: [DataTypeWrapper] -> [DataTypeWrapper] -> Bool-isEqOrStricter [] []                               = True-isEqOrStricter (NonNullType:xs1) (NonNullType:xs2) = isEqOrStricter xs1 xs2-isEqOrStricter (NonNullType:xs1) xs2               = isEqOrStricter xs1 xs2-isEqOrStricter (ListType:xs1) (ListType:xs2)       = isEqOrStricter xs1 xs2-isEqOrStricter _ _                                 = False
src/Data/Morpheus/Validation/Query/Arguments.hs view
@@ -10,21 +10,20 @@ import           Data.Morpheus.Error.Input                     (InputValidation, inputErrorMessage) import           Data.Morpheus.Error.Internal                  (internalUnknownTypeMessage) import           Data.Morpheus.Error.Variable                  (incompatibleVariableType, undefinedVariable)+import           Data.Morpheus.Rendering.RenderGQL             (RenderGQL (..)) import           Data.Morpheus.Types.Internal.AST.Operation    (ValidVariables, Variable (..)) import           Data.Morpheus.Types.Internal.AST.RawSelection (RawArgument (..), RawArguments, Reference (..)) import           Data.Morpheus.Types.Internal.AST.Selection    (Argument (..), ArgumentOrigin (..), Arguments) import           Data.Morpheus.Types.Internal.Base             (EnhancedKey (..), Position)-import           Data.Morpheus.Types.Internal.Data             (DataArgument, DataField (..), DataInputField,-                                                                DataOutputField, DataTypeLib, isFieldNullable,-                                                                showWrappedType)+import           Data.Morpheus.Types.Internal.Data             (DataArgument, DataField (..), DataField, DataTypeLib,+                                                                TypeAlias (..), isFieldNullable, isWeaker) import           Data.Morpheus.Types.Internal.Validation       (Validation) import           Data.Morpheus.Types.Internal.Value            (Value (Null))-import           Data.Morpheus.Validation.Internal.Utils       (checkForUnknownKeys, checkNameCollision, getInputType,-                                                                isEqOrStricter)+import           Data.Morpheus.Validation.Internal.Utils       (checkForUnknownKeys, checkNameCollision, getInputType) import           Data.Morpheus.Validation.Query.Input.Object   (validateInputValue) import           Data.Text                                     (Text) -resolveArgumentVariables :: Text -> ValidVariables -> DataOutputField -> RawArguments -> Validation Arguments+resolveArgumentVariables :: Text -> ValidVariables -> DataField -> RawArguments -> Validation Arguments resolveArgumentVariables operatorName variables DataField {fieldName, fieldArgs} = mapM resolveVariable   where     resolveVariable :: (Text, RawArgument) -> Validation (Text, Argument)@@ -40,55 +39,51 @@             Just Variable {variableValue, variableType, variableTypeWrappers} ->               case lookup key fieldArgs of                 Nothing -> Left $ unknownArguments fieldName [EnhancedKey key referencePosition]-                Just DataField {fieldType, fieldTypeWrappers} ->-                  if variableType == fieldType && isEqOrStricter variableTypeWrappers fieldTypeWrappers+                Just DataField {fieldType = fieldT@TypeAlias {aliasTyCon, aliasWrappers}} ->+                  if variableType == aliasTyCon && not (isWeaker variableTypeWrappers aliasWrappers)                     then return variableValue                     else Left $ incompatibleVariableType referenceName varSignature fieldSignature referencePosition-                  where varSignature = showWrappedType variableTypeWrappers variableType-                        fieldSignature = showWrappedType fieldTypeWrappers fieldType--handleInputError :: Text -> Position -> InputValidation a -> Validation ()-handleInputError key position' (Left error') = Left $ argumentGotInvalidValue key (inputErrorMessage error') position'-handleInputError _ _ _                       = pure ()--validateArgumentValue :: DataTypeLib -> DataField a -> (Text, Argument) -> Validation (Text, Argument)-validateArgumentValue lib DataField {fieldType, fieldTypeWrappers} arg@(key, Argument {argumentValue, argumentPosition}) =-  getInputType fieldType lib (internalUnknownTypeMessage fieldType) >>= checkType >> pure arg-  where-    checkType type' =-      handleInputError key argumentPosition (validateInputValue lib [] fieldTypeWrappers type' (key, argumentValue))+                  where varSignature = renderWrapped variableType variableTypeWrappers+                        fieldSignature = render fieldT  validateArgument :: DataTypeLib -> Position -> Arguments -> (Text, DataArgument) -> Validation (Text, Argument)-validateArgument types argumentPosition requestArgs (key, arg) =+validateArgument lib fieldPosition requestArgs (key, argType@DataField {fieldType = TypeAlias { aliasTyCon+                                                                                              , aliasWrappers+                                                                                              }}) =   case lookup key requestArgs of     Nothing                                            -> handleNullable     Just argument@Argument {argumentOrigin = VARIABLE} -> pure (key, argument) -- Variables are already checked in Variable Validation     Just Argument {argumentValue = Null}               -> handleNullable-    Just argument                                      -> validateArgumentValue types arg (key, argument)+    Just argument                                      -> validateArgumentValue argument   where     handleNullable-      | isFieldNullable arg = pure (key, Argument {argumentValue = Null, argumentOrigin = INLINE, argumentPosition})-      | otherwise = Left $ undefinedArgument (EnhancedKey key argumentPosition)--checkForUnknownArguments :: (Text, DataOutputField) -> Arguments -> Validation [(Text, DataInputField)]-checkForUnknownArguments (key, DataField {fieldArgs}) args =-  checkForUnknownKeys enhancedKeys fieldKeys argError >> checkNameCollision enhancedKeys argumentNameCollision >>-  pure fieldArgs-  where-    argError = unknownArguments key-    enhancedKeys = map argToKey args-    argToKey (key', Argument {argumentPosition}) = EnhancedKey key' argumentPosition-    fieldKeys = map fst fieldArgs+      | isFieldNullable argType =+        pure (key, Argument {argumentValue = Null, argumentOrigin = INLINE, argumentPosition = fieldPosition})+      | otherwise = Left $ undefinedArgument (EnhancedKey key fieldPosition)+    -------------------------------------------------------------------------+    validateArgumentValue :: Argument -> Validation (Text, Argument)+    validateArgumentValue arg@Argument {argumentValue, argumentPosition} =+      getInputType aliasTyCon lib (internalUnknownTypeMessage aliasTyCon) >>= checkType >> pure (key, arg)+      where+        checkType type' = handleInputError (validateInputValue lib [] aliasWrappers type' (key, argumentValue))+        ---------+        handleInputError :: InputValidation a -> Validation ()+        handleInputError (Left err) = Left $ argumentGotInvalidValue key (inputErrorMessage err) argumentPosition+        handleInputError _          = pure ()  validateArguments ::-     DataTypeLib-  -> Text-  -> ValidVariables-  -> (Text, DataOutputField)-  -> Position-  -> RawArguments-  -> Validation Arguments-validateArguments typeLib operatorName variables inputs pos rawArgs = do-  args <- resolveArgumentVariables operatorName variables (snd inputs) rawArgs-  dataArgs <- checkForUnknownArguments inputs args+     DataTypeLib -> Text -> ValidVariables -> (Text, DataField) -> Position -> RawArguments -> Validation Arguments+validateArguments typeLib operatorName variables (key, field@DataField {fieldArgs}) pos rawArgs = do+  args <- resolveArgumentVariables operatorName variables field rawArgs+  dataArgs <- checkForUnknownArguments args   mapM (validateArgument typeLib pos args) dataArgs+  where+    checkForUnknownArguments :: Arguments -> Validation [(Text, DataField)]+    checkForUnknownArguments args =+      checkForUnknownKeys enhancedKeys fieldKeys argError >> checkNameCollision enhancedKeys argumentNameCollision >>+      pure fieldArgs+      where+        argError = unknownArguments key+        enhancedKeys = map argToKey args+        argToKey (key', Argument {argumentPosition}) = EnhancedKey key' argumentPosition+        fieldKeys = map fst fieldArgs
src/Data/Morpheus/Validation/Query/Input/Object.hs view
@@ -5,63 +5,61 @@   ( validateInputValue   ) where -import           Data.Morpheus.Error.Input                  (InputError (..), InputValidation, Prop (..))-import           Data.Morpheus.Types.Internal.Data          (DataField (..), DataInputType, DataKind (..),-                                                             DataType (..), DataTypeLib (..), DataTypeWrapper (..),-                                                             DataValidator (..), showFullAstType)-import           Data.Morpheus.Types.Internal.Value         (Value (..))-import           Data.Morpheus.Validation.Query.Input.Enum  (validateEnum)-import           Data.Morpheus.Validation.Internal.Utils (getInputType, lookupField)-import           Data.Text                                  (Text)+import           Data.Morpheus.Error.Input                 (InputError (..), InputValidation, Prop (..))+import           Data.Morpheus.Rendering.RenderGQL         (renderWrapped)+import           Data.Morpheus.Types.Internal.Data         (DataField (..), DataKind (..), DataTyCon (..),+                                                            DataTypeLib (..), DataValidator (..), TypeAlias (..),+                                                            WrapperD (..), isNullable)+import           Data.Morpheus.Types.Internal.Value        (Value (..))+import           Data.Morpheus.Validation.Internal.Utils   (getInputType, lookupField)+import           Data.Morpheus.Validation.Query.Input.Enum (validateEnum)+import           Data.Text                                 (Text)  typeMismatch :: Value -> Text -> [Prop] -> InputError typeMismatch jsType expected' path' = UnexpectedType path' expected' jsType Nothing  -- Validate Variable Argument or all Possible input Values-validateInputValue ::-     DataTypeLib -> [Prop] -> [DataTypeWrapper] -> DataInputType -> (Text, Value) -> InputValidation Value-validateInputValue lib' prop' = validate+validateInputValue :: DataTypeLib -> [Prop] -> [WrapperD] -> DataKind -> (Text, Value) -> InputValidation Value+validateInputValue lib prop' = validate   where-    throwError :: [DataTypeWrapper] -> DataInputType -> Value -> InputValidation Value-    throwError wrappers' type' value' = Left $ UnexpectedType prop' (showFullAstType wrappers' type') value' Nothing-    {-- VALIDATION --}-    {-- 1. VALIDATE WRAPPERS -}-    validate :: [DataTypeWrapper] -> DataInputType -> (Text, Value) -> InputValidation Value-    -- throw error on not nullable type if value = null-    validate (NonNullType:wrappers') type' (_, Null) = throwError wrappers' type' Null-    -- resolves nullable value as null-    validate _ _ (_, Null) = return Null-    -- ignores NonNUllTypes if value /= null-    validate (NonNullType:wrappers') type' value' = validateInputValue lib' prop' wrappers' type' value'-    {-- VALIDATE LIST -}-    validate (ListType:wrappers') type' (key', List list') = List <$> mapM validateElement list'+    throwError :: [WrapperD] -> DataKind -> Value -> InputValidation Value+    throwError wrappers type' value' = Left $ UnexpectedType prop' (renderWrapped type' wrappers) value' Nothing+    -- VALIDATION+    validate :: [WrapperD] -> DataKind -> (Text, Value) -> InputValidation Value+    -- Validate Null. value = null ?+    validate wrappers tName (_, Null)+      | isNullable wrappers = return Null+      | otherwise = throwError wrappers tName Null+    -- Validate LIST+    validate (MaybeD:wrappers) type' value' = validateInputValue lib prop' wrappers type' value'+    validate (ListD:wrappers) type' (key', List list') = List <$> mapM validateElement list'       where-        validateElement element' = validateInputValue lib' prop' wrappers' type' (key', element')+        validateElement element' = validateInputValue lib prop' wrappers type' (key', element')     {-- 2. VALIDATE TYPES, all wrappers are already Processed --}     {-- VALIDATE OBJECT--}-    validate [] (ObjectKind DataType {typeData = parentFields'}) (_, Object fields) =+    validate [] (ObjectKind DataTyCon {typeData = parentFields'}) (_, Object fields) =       Object <$> mapM validateField fields       where-        validateField (_name, value') = do-          (type', currentProp') <- validationData value'-          wrappers' <- fieldTypeWrappers <$> getField-          value'' <- validateInputValue lib' currentProp' wrappers' type' (_name, value')+        validateField (_name, value) = do+          (type', currentProp') <- validationData value+          wrappers' <- aliasWrappers . fieldType <$> getField+          value'' <- validateInputValue lib currentProp' wrappers' type' (_name, value)           return (_name, value'')           where             validationData x = do-              fieldTypeName' <- fieldType <$> getField+              fieldTypeName' <- aliasTyCon . fieldType <$> getField               let currentProp = prop' ++ [Prop _name fieldTypeName']-              type' <- getInputType fieldTypeName' lib' (typeMismatch x fieldTypeName' currentProp)+              type' <- getInputType fieldTypeName' lib (typeMismatch x fieldTypeName' currentProp)               return (type', currentProp)             getField = lookupField _name parentFields' (UnknownField prop' _name)     -- VALIDATE INPUT UNION     -- TODO: Validate Union-    validate [] (UnionKind DataType {typeData}) (_, Object fields) = return (Object fields)+    validate [] (UnionKind DataTyCon {typeData}) (_, Object fields) = return (Object fields)     {-- VALIDATE SCALAR --}-    validate [] (EnumKind DataType {typeData = tags', typeName = name'}) (_, value') =+    validate [] (EnumKind DataTyCon {typeData = tags', typeName = name'}) (_, value') =       validateEnum (UnexpectedType prop' name' value' Nothing) tags' value'     {-- VALIDATE ENUM --}-    validate [] (ScalarKind DataType {typeName = name', typeData = DataValidator {validateValue = validator'}}) (_, value') =+    validate [] (ScalarKind DataTyCon {typeName = name', typeData = DataValidator {validateValue = validator'}}) (_, value') =       case validator' value' of         Right _           -> return value'         Left ""           -> Left $ UnexpectedType prop' name' value' Nothing
src/Data/Morpheus/Validation/Query/Selection.hs view
@@ -16,8 +16,9 @@                                                                  RawSelection' (..), RawSelectionSet) import           Data.Morpheus.Types.Internal.AST.Selection     (Selection (..), SelectionRec (..), SelectionSet) import           Data.Morpheus.Types.Internal.Base              (EnhancedKey (..))-import           Data.Morpheus.Types.Internal.Data              (DataField (..), DataFullType (..), DataOutputObject,-                                                                 DataType (..), DataTypeLib (..), allDataTypes)+import           Data.Morpheus.Types.Internal.Data              (DataField (..), DataFullType (..), DataObject,+                                                                 DataTyCon (..), DataTypeLib (..), TypeAlias (..),+                                                                 allDataTypes) import           Data.Morpheus.Types.Internal.Validation        (Validation) import           Data.Morpheus.Validation.Internal.Utils        (checkNameCollision, lookupType) import           Data.Morpheus.Validation.Query.Arguments       (validateArguments)@@ -26,15 +27,15 @@                                                                  lookupUnionTypes) import           Data.Text                                      (Text) -checkDuplicatesOn :: DataOutputObject -> SelectionSet -> Validation SelectionSet-checkDuplicatesOn DataType {typeName = name'} keys = checkNameCollision enhancedKeys selError >> pure keys+checkDuplicatesOn :: DataObject -> SelectionSet -> Validation SelectionSet+checkDuplicatesOn DataTyCon {typeName = name'} keys = checkNameCollision enhancedKeys selError >> pure keys   where     selError = duplicateQuerySelections name'     enhancedKeys = map selToKey keys     selToKey (key', Selection {selectionPosition = position'}) = EnhancedKey key' position'  clusterUnionSelection ::-     FragmentLib -> Text -> [DataOutputObject] -> (Text, RawSelection) -> Validation ([Fragment], SelectionSet)+     FragmentLib -> Text -> [DataObject] -> (Text, RawSelection) -> Validation ([Fragment], SelectionSet) clusterUnionSelection fragments type' possibleTypes' = splitFrag   where     packFragment fragment = return ([fragment], [])@@ -55,11 +56,11 @@     splitFrag (_, InlineFragment fragment') =       castFragmentType Nothing (fragmentPosition fragment') typeNames fragment' >>= packFragment -categorizeTypes :: [DataOutputObject] -> [Fragment] -> [(DataOutputObject, [Fragment])]+categorizeTypes :: [DataObject] -> [Fragment] -> [(DataObject, [Fragment])] categorizeTypes types fragments = filter notEmpty $ map categorizeType types   where     notEmpty = (0 /=) . length . snd-    categorizeType :: DataOutputObject -> (DataOutputObject, [Fragment])+    categorizeType :: DataObject -> (DataObject, [Fragment])     categorizeType datatype = (datatype, filter matches fragments)       where         matches fragment = fragmentType fragment == typeName datatype@@ -79,16 +80,10 @@  -}  validateSelectionSet ::-     DataTypeLib-  -> FragmentLib-  -> Text-  -> ValidVariables-  -> DataOutputObject-  -> RawSelectionSet-  -> Validation SelectionSet+     DataTypeLib -> FragmentLib -> Text -> ValidVariables -> DataObject -> RawSelectionSet -> Validation SelectionSet validateSelectionSet lib fragments' operatorName variables = __validate   where-    __validate dataType'@DataType {typeName = typeName'} selectionSet' =+    __validate dataType'@DataTyCon {typeName = typeName'} selectionSet' =       concat <$> mapM validateSelection selectionSet' >>= checkDuplicatesOn dataType'       where         validateFragment Fragment {fragmentSelection = selection'} = __validate dataType' selection'@@ -109,9 +104,9 @@           -- check field Type existence  -----           fieldDataType <-             lookupType-              (unknownType (fieldType selectionField) rawSelectionPosition)+              (unknownType (aliasTyCon $fieldType selectionField) rawSelectionPosition)               (allDataTypes lib)-              (fieldType selectionField)+              (aliasTyCon $ fieldType selectionField)           return (selectionField, fieldDataType, arguments)         -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet         --@@ -128,30 +123,30 @@         validateSelection (key', RawSelectionSet fullRawSelection'@RawSelection' { rawSelectionRec = rawSelectors                                                                                  , rawSelectionPosition = position'                                                                                  }) = do-          (dataField', dataType, arguments) <- getValidationData key' fullRawSelection'+          (dataField, dataType, arguments) <- getValidationData key' fullRawSelection'           case dataType of             Union _ -> do               (categories, __typename) <- clusterTypes               mapM (validateCluster __typename) categories >>= returnSelection arguments . UnionSelection               where clusterTypes = do-                      unionTypes <- lookupUnionTypes position' key' lib dataField'+                      unionTypes <- lookupUnionTypes position' key' lib dataField                       (spreads, __typename) <-                         flatTuple <$> mapM (clusterUnionSelection fragments' typeName' unionTypes) rawSelectors                       return (categorizeTypes unionTypes spreads, __typename)                     --                     --    second arguments will be added to every selection cluster-                    validateCluster :: SelectionSet -> (DataOutputObject, [Fragment]) -> Validation (Text, SelectionSet)+                    validateCluster :: SelectionSet -> (DataObject, [Fragment]) -> Validation (Text, SelectionSet)                     validateCluster sysSelection' (type', frags') = do                       selection' <- __validate type' (concatMap fragmentSelection frags')                       return (typeName type', sysSelection' ++ selection')             OutputObject _ -> do-              fieldType' <- lookupFieldAsSelectionSet position' key' lib dataField'+              fieldType' <- lookupFieldAsSelectionSet position' key' lib dataField               __validate fieldType' rawSelectors >>= returnSelection arguments . SelectionSet                  -- DataFullType                        --   = Leaf DataLeaf                        --   | InputObject DataInputObject                        --   | InputUnion DataUnion-            _ -> Left $ hasNoSubfields key' (fieldType dataField') position'+            _ -> Left $ hasNoSubfields key' (aliasTyCon $fieldType dataField) position'           where             returnSelection arguments' selection' =               pure@@ -159,20 +154,21 @@                   , Selection                       {selectionArguments = arguments', selectionRec = selection', selectionPosition = position'})                 ]-        validateSelection (key', RawSelectionField fullRawSelection'@RawSelection' {rawSelectionPosition}) = do-          (dataField, datatype, arguments') <- getValidationData key' fullRawSelection'+        validateSelection (key, RawSelectionField fullRawSelection'@RawSelection' {rawSelectionPosition}) = do+          (dataField, datatype, arguments) <- getValidationData key fullRawSelection'           isLeaf datatype dataField           pure-            [ ( key'+            [ ( key               , Selection-                  { selectionArguments = arguments'+                  { selectionArguments = arguments                   , selectionRec = SelectionField                   , selectionPosition = rawSelectionPosition                   })             ]           where-            isLeaf (Leaf _) _              = Right ()-            isLeaf _ DataField {fieldType} = Left $ subfieldsNotSelected key' fieldType rawSelectionPosition+            isLeaf (Leaf _) _ = Right ()+            isLeaf _ DataField {fieldType = TypeAlias {aliasTyCon}} =+              Left $ subfieldsNotSelected key aliasTyCon rawSelectionPosition         validateSelection (_, Spread reference') = resolveSpread fragments' [typeName'] reference' >>= validateFragment         validateSelection (_, InlineFragment fragment') =           castFragmentType Nothing (fragmentPosition fragment') [typeName'] fragment' >>= validateFragment
src/Data/Morpheus/Validation/Query/Utils/Selection.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE NamedFieldPuns #-}+ module Data.Morpheus.Validation.Query.Utils.Selection   ( lookupFieldAsSelectionSet   , lookupSelectionField@@ -6,24 +8,25 @@  import           Data.Morpheus.Error.Selection           (cannotQueryField, hasNoSubfields) import           Data.Morpheus.Types.Internal.Base       (Position)-import           Data.Morpheus.Types.Internal.Data       (DataField (..), DataOutputField, DataOutputObject,-                                                          DataType (..), DataTypeLib (..))+import           Data.Morpheus.Types.Internal.Data       (DataField (..), DataObject, DataTyCon (..), DataTypeLib (..),+                                                          TypeAlias (..)) import           Data.Morpheus.Types.Internal.Validation (Validation) import           Data.Morpheus.Validation.Internal.Utils (lookupField, lookupType) import           Data.Text                               (Text) -lookupUnionTypes :: Position -> Text -> DataTypeLib -> DataOutputField -> Validation [DataOutputObject]-lookupUnionTypes position' key' lib' DataField {fieldType = type'} =-  lookupType error' (union lib') type' >>= mapM (lookupType error' (object lib') . fieldType) . typeData+lookupUnionTypes :: Position -> Text -> DataTypeLib -> DataField -> Validation [DataObject]+lookupUnionTypes position' key' lib DataField {fieldType = TypeAlias {aliasTyCon = type'}} =+  lookupType error' (union lib) type' >>= mapM (lookupType error' (object lib) . aliasTyCon . fieldType) . typeData   where     error' = hasNoSubfields key' type' position' -lookupFieldAsSelectionSet :: Position -> Text -> DataTypeLib -> DataOutputField -> Validation DataOutputObject-lookupFieldAsSelectionSet position' key' lib' DataField {fieldType = type'} = lookupType error' (object lib') type'+lookupFieldAsSelectionSet :: Position -> Text -> DataTypeLib -> DataField -> Validation DataObject+lookupFieldAsSelectionSet position key' lib DataField {fieldType = TypeAlias {aliasTyCon = type'}} =+  lookupType error' (object lib) type'   where-    error' = hasNoSubfields key' type' position'+    error' = hasNoSubfields key' type' position -lookupSelectionField :: Position -> Text -> DataOutputObject -> Validation DataOutputField-lookupSelectionField position' key' DataType {typeData = fields', typeName = name'} = lookupField key' fields' error'+lookupSelectionField :: Position -> Text -> DataObject -> Validation DataField+lookupSelectionField position' key' DataTyCon {typeData = fields', typeName = name'} = lookupField key' fields' error'   where     error' = cannotQueryField key' name' position'
src/Data/Morpheus/Validation/Query/Validation.hs view
@@ -10,9 +10,8 @@ import           Data.Map                                   (fromList) import           Data.Morpheus.Error.Mutation               (mutationIsNotDefined) import           Data.Morpheus.Error.Subscription           (subscriptionIsNotDefined)-import           Data.Morpheus.Types.Internal.AST.Operation (Operation (..), OperationKind (..), RawOperation,-                                                             ValidOperation)-import           Data.Morpheus.Types.Internal.Data          (DataOutputObject, DataTypeLib (..))+import           Data.Morpheus.Types.Internal.AST.Operation (Operation (..), RawOperation, ValidOperation)+import           Data.Morpheus.Types.Internal.Data          (DataObject, DataTypeLib (..), OperationKind (..)) import           Data.Morpheus.Types.Internal.Validation    (Validation) import           Data.Morpheus.Types.Types                  (GQLQueryRoot (..)) import           Data.Morpheus.Validation.Internal.Utils    (VALIDATION_MODE)@@ -20,13 +19,13 @@ import           Data.Morpheus.Validation.Query.Selection   (validateSelectionSet) import           Data.Morpheus.Validation.Query.Variable    (resolveOperationVariables) -getOperationDataType :: RawOperation -> DataTypeLib -> Validation DataOutputObject-getOperationDataType Operation {operationKind = QUERY} lib = pure $ snd $ query lib-getOperationDataType Operation {operationKind = MUTATION, operationPosition} lib =+getOperationDataType :: RawOperation -> DataTypeLib -> Validation DataObject+getOperationDataType Operation {operationKind = Query} lib = pure $ snd $ query lib+getOperationDataType Operation {operationKind = Mutation, operationPosition} lib =   case mutation lib of     Just (_, mutation') -> pure mutation'     Nothing             -> Left $ mutationIsNotDefined operationPosition-getOperationDataType Operation {operationKind = SUBSCRIPTION, operationPosition} lib =+getOperationDataType Operation {operationKind = Subscription, operationPosition} lib =   case subscription lib of     Just (_, subscription') -> pure subscription'     Nothing                 -> Left $ subscriptionIsNotDefined operationPosition
src/Data/Morpheus/Validation/Query/Variable.hs view
@@ -16,7 +16,7 @@                                                                 RawSelection (..), RawSelection' (..), RawSelectionSet,                                                                 Reference (..)) import           Data.Morpheus.Types.Internal.Base             (EnhancedKey (..), Position)-import           Data.Morpheus.Types.Internal.Data             (DataInputType, DataTypeLib)+import           Data.Morpheus.Types.Internal.Data             (DataKind, DataTypeLib) import           Data.Morpheus.Types.Internal.Validation       (Validation) import           Data.Morpheus.Types.Internal.Value            (Value (..)) import           Data.Morpheus.Types.Types                     (Variables)@@ -26,7 +26,7 @@ import           Data.Semigroup                                ((<>)) import           Data.Text                                     (Text) -getVariableType :: Text -> Position -> DataTypeLib -> Validation DataInputType+getVariableType :: Text -> Position -> DataTypeLib -> Validation DataKind getVariableType type' position' lib' = getInputType type' lib' error'   where     error' = unknownType type' position'
test/Feature/Holistic/API.gql view
@@ -1,5 +1,3 @@-scalar TestScalar- enum TestEnum {   EnumA   EnumB@@ -15,6 +13,11 @@   fieldNestedInputObject: [NestedInputObject]! } +input Coordinates {+  latitude: TestScalar!+  longitude: Int!+}+ type Address {   city: String!   street(@@ -24,21 +27,25 @@   houseNumber: Int! } +union TestUnion = User | Address+ type User {-  name(id: ID!): String!+  name: String!   email: String!-  address: Address-  testEnum: TestEnum+  address(coordinates: Coordinates!, comment: String): Address!+  office(zipCode: [Int!], cityID: TestEnum!): Address!+  friend: User } -union TestUnion = User | Address- type Query {   user: User!-  myUnion: TestUnion!-  fieldID: ID!+  testUnion: TestUnion }  type Mutation {-  createUser: User!+  createUser(userID: String!, userName: String!): User!+}++type Subscription {+  newUser: User! }
test/Feature/Holistic/API.hs view
@@ -1,32 +1,30 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}  module Feature.Holistic.API   ( api   ) where -import           Data.Morpheus       (interpreter)-import           Data.Morpheus.Kind  (ENUM, INPUT_OBJECT, OBJECT, SCALAR, UNION)-import           Data.Morpheus.Types (Event (..), GQLRequest, GQLResponse, GQLRootResolver (..), GQLScalar (..),-                                      GQLType (..), ID (..), IORes, IOSubRes, ScalarValue (..))-import           Data.Text           (Text)-import           GHC.Generics        (Generic)--data TestEnum-  = EnumA-  | EnumB-  | EnumC-  deriving (Generic)--instance GQLType TestEnum where-  type KIND TestEnum = ENUM+import           Data.Morpheus          (interpreter)+import           Data.Morpheus.Document (importGQLDocument)+import           Data.Morpheus.Kind     (SCALAR)+import           Data.Morpheus.Types    (GQLRequest, GQLResponse, GQLRootResolver (..), GQLScalar (..), GQLType (..),+                                         ID (..), IOMutRes, IORes, IOSubRes, ScalarValue (..), SubResolver (..))+import           Data.Text              (Text)+import           GHC.Generics           (Generic)  data TestScalar =   TestScalar Int              Int-  deriving (Generic)+  deriving (Show, Generic)  instance GQLType TestScalar where   type KIND TestScalar = SCALAR@@ -35,106 +33,37 @@   parseValue _ = pure (TestScalar 1 0)   serialize (TestScalar x y) = Int (x * 100 + y) -newtype NestedInputObject = NestedInputObject-  { fieldTestID :: ID-  } deriving (Generic)--instance GQLType NestedInputObject where-  type KIND NestedInputObject = INPUT_OBJECT--data TestInputObject = TestInputObject-  { fieldTestScalar        :: TestScalar-  , fieldNestedInputObject :: [Maybe NestedInputObject]-  } deriving (Generic)--instance GQLType TestInputObject where-  type KIND TestInputObject = INPUT_OBJECT--data StreetArgs = StreetArgs-  { argInputObject :: TestInputObject-  , argMaybeString :: Maybe Text-  } deriving (Generic)--data Address = Address-  { city        :: Text-  , street      :: StreetArgs -> IORes (Maybe [Maybe [[[Text]]]])-  , houseNumber :: Int-  } deriving (Generic)--instance GQLType Address where-  type KIND Address = OBJECT--data TestUnion-  = UnionA User-  | UnionB Address-  deriving (Generic)--instance GQLType TestUnion where-  type KIND TestUnion = UNION--data Coordinates = Coordinates-  { latitude  :: TestScalar-  , longitude :: Int-  } deriving (Generic)--instance GQLType Coordinates where-  type KIND Coordinates = INPUT_OBJECT--data AddressArgs = AddressArgs-  { coordinates :: Coordinates-  , comment     :: Maybe Text-  } deriving (Generic)--data OfficeArgs = OfficeArgs-  { zipCode :: Maybe [Int]-  , cityID  :: TestEnum-  } deriving (Generic)--data User = User-  { name    :: Text-  , email   :: Text-  , address :: AddressArgs -> IORes Address-  , office  :: OfficeArgs -> IORes Address-  , friend  :: () -> IORes (Maybe User)-  } deriving (Generic)--instance GQLType User where-  type KIND User = OBJECT-  description = const "Custom Description for Client Defined User Type"--data Query = Query-  { user      :: () -> IORes User-  , testUnion :: Maybe TestUnion-  } deriving (Generic)--newtype Mutation = Mutation-  { createUser :: AddressArgs -> IORes User-  } deriving (Generic)- data EVENT =   EVENT   deriving (Show, Eq) -newtype Subscription = Subscription-  { newUser :: AddressArgs -> IOSubRes EVENT () User-  } deriving (Generic)--resolveAddress :: a -> IORes Address-resolveAddress _ = return Address {city = "", houseNumber = 0, street = const $ return Nothing}+importGQLDocument "test/Feature/Holistic/API.gql" -resolveUser :: a -> IORes User-resolveUser _ =-  return $-  User-    {name = "testName", email = "", address = resolveAddress, office = resolveAddress, friend = const $ return Nothing}+resolveValue :: Monad m => b -> a -> m b+resolveValue = const . return -rootResolver :: GQLRootResolver IO EVENT () Query Mutation Subscription+rootResolver ::+     GQLRootResolver IO EVENT () (Query IORes) (Mutation (IOMutRes EVENT ())) (Subscription (IOSubRes EVENT ())) rootResolver =   GQLRootResolver-    { queryResolver = return Query {user = resolveUser, testUnion = Nothing}-    , mutationResolver = return Mutation {createUser = resolveUser}-    , subscriptionResolver = return Subscription {newUser = const $ Event [EVENT] resolveUser}+    { queryResolver = return Query {user, testUnion = const $ return Nothing}+    , mutationResolver = return Mutation {createUser = user}+    , subscriptionResolver =+        return Subscription {newUser = const SubResolver {subChannels = [EVENT], subResolver = user}}     }+  where+    user _ =+      return $+      User+        { name = resolveValue "testName"+        , email = resolveValue ""+        , address = resolveAddress+        , office = resolveAddress+        , friend = resolveValue Nothing+        }+      where+        resolveAddress _ =+          return Address {city = resolveValue "", houseNumber = resolveValue 0, street = resolveValue Nothing}  api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/Input/Enum/API.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric  #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies   #-}@@ -56,7 +57,7 @@   { test  :: TestArgs Level -> IORes Level   , test2 :: TestArgs TwoCon -> IORes TwoCon   , test3 :: TestArgs ThreeCon -> IORes ThreeCon-  } deriving (Generic)+  } deriving (Generic, GQLType)  rootResolver :: GQLRootResolver IO () () Query () () rootResolver =
test/Feature/InputType/API.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -33,7 +34,7 @@  newtype Query = Query   { q1 :: A-  } deriving (Generic)+  } deriving (Generic, GQLType)  rootResolver :: GQLRootResolver IO () () Query () () rootResolver =
test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json view
@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "Variable \"$v1\" got invalid value;  Expected type \"String\" found null.",+      "message": "Variable \"$v1\" got invalid value;  Expected type \"String!\" found null.",       "locations": [         {           "line": 1,
test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json view
@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "Variable \"$v1\" got invalid value;  Expected type \"[Int!]\" found null.",+      "message": "Variable \"$v1\" got invalid value;  Expected type \"[Int!]!\" found null.",       "locations": [         {           "line": 1,
test/Feature/Schema/API.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -25,7 +26,7 @@ data Query = Query   { a1 :: A   , a2 :: A2.A-  } deriving (Generic)+  } deriving (Generic, GQLType)  rootResolver :: GQLRootResolver IO () () Query () () rootResolver =
test/Feature/UnionType/API.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -48,7 +49,7 @@ data Query = Query   { union :: () -> IORes [AOrB]   , fc    :: C-  } deriving (Generic)+  } deriving (Generic, GQLType)  resolveUnion :: () -> IORes [AOrB] resolveUnion _ = return [A' A {aText = "at", aInt = 1}, B' B {bText = "bt", bInt = 2}]
test/Feature/WrappedTypeName/API.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -9,8 +10,8 @@  import           Data.Morpheus       (interpreter) import           Data.Morpheus.Kind  (OBJECT)-import           Data.Morpheus.Types (Event (..), GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IOMutRes,-                                      IORes, IOSubRes)+import           Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IOMutRes, IORes,+                                      IOSubRes, SubResolver (..)) import           Data.Text           (Text) import           Data.Typeable       (Typeable) import           GHC.Generics        (Generic)@@ -35,13 +36,13 @@   { a1 :: WA IORes   , a2 :: Maybe (Wrapped Int Int)   , a3 :: Maybe (Wrapped (Wrapped Text Int) Text)-  } deriving (Generic)+  } deriving (Generic, GQLType)  data Mutation = Mutation   { mut1 :: Maybe (WA (IOMutRes EVENT ()))   , mut2 :: Maybe (Wrapped Int Int)   , mut3 :: Maybe (Wrapped (Wrapped Text Int) Text)-  } deriving (Generic)+  } deriving (Generic, GQLType)  data EVENT =   EVENT@@ -51,7 +52,7 @@   { sub1 :: () -> IOSubRes EVENT () (Maybe (WA IORes))   , sub2 :: () -> IOSubRes EVENT () (Maybe (Wrapped Int Int))   , sub3 :: () -> IOSubRes EVENT () (Maybe (Wrapped (Wrapped Text Int) Text))-  } deriving (Generic)+  } deriving (Generic, GQLType)  rootResolver :: GQLRootResolver IO EVENT () Query Mutation Subscription rootResolver =@@ -61,9 +62,9 @@     , subscriptionResolver =         return           Subscription-            { sub1 = const $ Event [EVENT] (const $ return Nothing)-            , sub2 = const $ Event [EVENT] (const $ return Nothing)-            , sub3 = const $ Event [EVENT] (const $ return Nothing)+            { sub1 = const SubResolver {subChannels = [EVENT], subResolver = const $ return Nothing}+            , sub2 = const SubResolver {subChannels = [EVENT], subResolver = const $ return Nothing}+            , sub3 = const SubResolver {subChannels = [EVENT], subResolver = const $ return Nothing}             }     } 
test/Lib.hs view
@@ -12,7 +12,6 @@ import qualified Data.ByteString.Lazy       as L (readFile) import           Data.ByteString.Lazy.Char8 (ByteString) import           Data.Maybe                 (fromMaybe)-import           Data.Morpheus.Types        (GQLResponse (..)) import           Data.Text                  (Text, unpack)  path :: Text -> String