packages feed

morpheus-graphql 0.1.1 → 0.2.0

raw patch · 168 files changed

+6260/−2616 lines, 168 filesdep +attoparsecdep +filepathdep +lensdep ~aesondep ~bytestringdep ~mtlnew-component:exe:morpheus

Dependencies added: attoparsec, filepath, lens, optparse-applicative, template-haskell, utf8-string

Dependency ranges changed: aeson, bytestring, mtl, text

Files

+ CLI/Main.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE NamedFieldPuns #-}++module Main+  ( main+  ) where++import qualified Data.ByteString.Lazy   as L (readFile, writeFile)+import           Data.Semigroup         ((<>))+import           Data.Version           (showVersion)+import           Options.Applicative    (Parser, command, customExecParser, fullDesc, help, helper, info, long, metavar,+                                         prefs, progDesc, short, showHelpOnError, strArgument, subparser, switch)+import qualified Options.Applicative    as OA+import           Paths_morpheus_graphql (version)+import           System.FilePath.Posix  (takeBaseName)++-- MORPHEUS+import           Data.Morpheus.Document (toMorpheusHaskellAPi)++morpheusVersion :: String+morpheusVersion = showVersion version++main :: IO ()+main = defaultParser >>= buildHaskellApi+  where+    buildHaskellApi Options {optionCommand} = executeCommand optionCommand+      where+        executeCommand About = putStrLn $ "Morpheus GraphQL CLI, version " <> morpheusVersion+        executeCommand Build {source, target} =+          toMorpheusHaskellAPi (takeBaseName target) <$> L.readFile source >>= saveDocument+          where+            saveDocument (Left errors) = print errors+            saveDocument (Right doc)   = L.writeFile target doc++data Command+  = Build { source :: FilePath+          , target :: FilePath }+  | About+  deriving (Show)++data Options = Options+  { optionVerbose :: Bool+  , optionCommand :: Command+  } deriving (Show)++data Behavior = Behavior+  { bName  :: String+  , bValue :: Parser Command+  , bDesc  :: String+  }++defaultParser :: IO Options+defaultParser = customExecParser (prefs showHelpOnError) (info (helper <*> optionParser) morpheusDescription)+  where+    morpheusDescription = fullDesc <> progDesc "Morpheus GraphQL CLI - haskell Api Generator"+    -----------------------------------------------------+    optionParser :: OA.Parser Options+    optionParser = Options <$> versionParser <*> commandParser+      where+        versionParser = switch (long "version" <> short 'v' <> help "show Version number")+        ----------------------------------------------------------------------------------------------+        commandParser = subparser $ foldr ((<>) . produceCommand) mempty commands+          where+            pathParser label = strArgument $ metavar label <> help (label <> " file")+            produceCommand Behavior {bName, bValue, bDesc} =+              command bName (info (helper <*> bValue) (fullDesc <> progDesc bDesc))+            commands =+              [ Behavior+                  { bName = "build"+                  , bValue = pure Build <*> pathParser "Source.gql" <*> pathParser "Target.hs"+                  , bDesc = "builds haskell API from  from GhraphQL schema \"*.gql\"  "+                  }+              , Behavior {bName = "about", bValue = pure About, bDesc = "api information"}+              ]
+ changelog.md view
@@ -0,0 +1,214 @@+## [0.2.0] - \*.08.2019++### Added++- Parser Supports GraphQL comments+- Enhanced Subscription: mutation can trigger subscription with arguments+- Experimental Support of Input Unions+- GraphQL schema generating with: `Data.Morpheus.Document.toGraphQLDocument`+- Generating dummy Morpheus Api from `schema.gql`:++  ```+  morpheus build schema/mythology.gql src/MythologyApi.hs+  ```++  [details](https://github.com/morpheusgraphql/morpheus-graphql/issues/184)++- `convertToJSONName` & `convertToHaskellName` has been extended to support all Haskell 2010 reserved identities. [details](https://github.com/morpheusgraphql/morpheus-graphql/issues/207)++- `GraphQL Client` with Template haskell QuasiQuotes (Experimental, Not fully Implemented)++  ```haskell+  defineQuery+    [gql|+      query GetHero ($byRealm: Realm)+        {+          deity (realm:$byRealm) {+            power+            fullName+          }+        }+    |]+  ```++  will Generate:++  - response type `GetHero`, `Deity` with `Lens` Instances+  - input types: `GetHeroArgs` , `Realm`+  - instance for `Fetch` typeClass++  so that++  ```haskell+    fetchHero :: Args GetHero -> m (Either String GetHero)+    fetchHero = fetch jsonRes args+        where+          args = GetHeroArgs {byRealm = Just Realm {owner = "Zeus", surface = Just 10}}+          jsonRes :: ByteString -> m ByteString+          jsonRes = <fetch query from server>+  ```++  resolves well typed response `GetHero`.++- Ability to define `GQLSchema` with GraphQL syntax ,+  so that with this schema++  ```haskell++  [gqlDocument|+    type Query {+      deity (uid: Text! ) : Deity!+    }++    type Deity {+      name  : Text!+      power : Text+    }+  |]++  rootResolver :: GQLRootResolver IO () () Query () ()+  rootResolver =+    GQLRootResolver {queryResolver = return Query {deity}, mutationResolver = pure (), subscriptionResolver = pure ()}+    where+      deity DeityArgs {uid} = pure Deity {name, power}+        where+          name _ = pure "Morpheus"+          power _ = pure (Just "Shapeshifting")+  ```++  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++### Fixed:++- Parser supports enums inside input Object+- fulfilled fragment Validation (added: unusedFragment,nameConflict)+- correct decoding of Enums with more than 3 constructor #201++### Changed++- WebSocket subProtocol changed from `graphql-subscriptions` to `graphql-ws`++- type familiy `KIND` is moved into typeClasses `GQLType`, so you should replace++  ```haskell+  type instance KIND Deity = OBJECT++  instance GQLType Deity where+    description  = const "Custom Description for Client Defined User Type"++  data Deity = Deity { fullName :: Text } deriving (Generic)+  ```++  with++  ```haskell+  instance GQLType Deity where+  type KIND Deity = OBJECT+  description = const "Custom Description for Client Defined User Type"++  data Deity = Deity { fullName :: Text } deriving (Generic)+  ```++- Duplicated variable names in Http requests are validated using `Aeson`'s `jsonNoDup` function. So the following request will+  result in a parsing error++  ```+  {"query":"...",+  "variables":{"email":"foo@mail.net", "email":"bar@mail.net",...}}+  ```++## [0.1.1] - 1.07.2019++### Fixed:++- () as Subscription or Mutation does not defines Operator without fields++## [0.1.0] - 30.06.2019++thanks for contributing to: @krisajenkins, @hovind, @vmchale, @msvbg++### Added++- support for Union Types: `type instance KIND <type> = UNION`+- support of haskell Types: `Map`, `Set`, and Pair `(a,b)`+- GraphQL Resolver supports custom Monad+- add `Interpreter` class with instances:++  - `ByteString -> m ByteString` and Lazy `ByteString`, where `m` is resolver monad+  - `Text -> m Text` and Lazy `Text`, where `m` is resolver monad+  - `GQLRequest -> m GQLResponse` , When you using it inside another Component that have Manual `ToJSON` deriving,+    you have to ensure that `GQLResponse` will be encoded with `toEncoding`, and not with `toJSON`.++- Schema Validation:++  - Name Collision++- support of Parsing input values: `Objects`,`Arrays`+- support scalar type: `ID`+- scalar Types are validated by `GQLScalar` instance function `parseValue`+- TypeFamily `KIND` with:++  - `SCALAR`+  - `OBJECT`,+  - `ENUM`+  - `INPUT_OBJECT`+  - `UNION`++- inline Fragments+- GraphQL [Aliases](https://graphql.org/learn/queries/#aliases)+- Subscriptions: `GQLSubscription`++  - `a -> EffectM b` operation: is resolver that contains side effect in `EffectM`.+    is used for Mutation and Subscribe communication+  - `gqlEffectResolver ["CHANNEL_ID"]`: packs as effect Resolver.+    if mutation and subscription resolver have same channel then+    every call of mutation will trigger subscription resolver+  - `GQLState`: shared state between `http` and `websocket` server+  - `gqlSocketApp` :converts `interpreter` to `websocket` application+  - `graphql-subscriptions`: `Apollo GraphQL` subProtocol++- language:+  - Query supports : `__type(name:"type")`+  - On every Object can be selected : `__typename`++### Changed++- `GQLRootResolver`, `GQLType(..)` , `GQLScalar(..)`+  are moved in `Data.Morpheus.Types`+- `GQLRoot { query, mutation, subscription }` to `GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver}`+- `interpreter`: can be used in `http` and `websocket` server+- `GQLKind` renamed as `GQLType`+- types can be derived just with `(Generic,GQLType)`+- haskell record field `type'` will generate GQL Object field `type`+- public API (all other modules are hidden):+  - Data.Morpheus+  - Data.Morpheus.Kind+  - Data.Morpheus.Types+  - Data.Morpheus.Execution.Subscription++### Fixed:++- parser can read fields with digits like: a1 , \_1+- you can use Wrapped type and Wrapped Primitive Types issue #136:+  - wrapped TypesNames will be separated with "\_" : typeName(Either A B) -> "Either_A_B"+- introspection:+  - argument supports `Non-Null` and `List`+  - every field has correct kind++### Removed++- `GQLArgs`: you can derive arguments just with `Generic` without `GQLArgs`+- `GQLObject`: replaced with instance `type instance KIND <Type> = OBJECT`+- `GQLEnum`: replaced with instance `type instance KIND <Type> = ENUM`+- `GQLInput`: replaced with instance `type instance KIND <Type> = INPUT_OBJECT`+- `Typeable` : with new deriving it is not required anymore+- `Wrapper`: with TypeFamilies there is no need for `Wrapper`+- `a ::-> b` is Replaced by `a -> ResM b` where `ResM` is alias for `Resolver IO a`+- `GQLMutation` , `GQLQuery` : with new deriving it is not required anymore+- `Resolver` constructor replaced by functions:+  - `gqlResolver` : packs `m Either String a` to `Resolver m a`+  - `gqlEffectResolver`: resolver constructor for effectedResolver+  - `liftEffectResolver`: lifts normal resolver to Effect Resolver.
examples/Deprecated/API.hs view
@@ -1,79 +1,116 @@-{-# LANGUAGE DeriveAnyClass    #-}+{-# 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)+import           Data.Text           (Text, pack) import           Data.Typeable       (Typeable) import           GHC.Generics        (Generic)  -- MORPHEUS-import           Data.Morpheus.Kind  (ENUM, INPUT_OBJECT, KIND, OBJECT, SCALAR, UNION)-import           Data.Morpheus.Types (EffectM, GQLRootResolver (..), GQLScalar (..), GQLType (..), ID, ResM, Resolver,-                                      ScalarValue (..), gqlEffectResolver, gqlResolver)+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) -type instance KIND CityID = ENUM+newtype Cat = Cat+  { catName :: Text+  } deriving (Show, Generic) -type instance KIND Euro = SCALAR+instance GQLType Cat where+  type KIND Cat = INPUT_OBJECT -type instance KIND UID = INPUT_OBJECT+newtype Dog = Dog+  { dogName :: Text+  } deriving (Show, Generic) -type instance KIND Coordinates = INPUT_OBJECT+instance GQLType Dog where+  type KIND Dog = INPUT_OBJECT -type instance KIND Address = OBJECT+newtype Bird = Bird+  { birdName :: Text+  } deriving (Show, Generic) -type instance KIND (User res) = OBJECT+instance GQLType Bird where+  type KIND Bird = INPUT_OBJECT -type instance KIND (MyUnion res) = UNION+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, GQLType)+  deriving (Generic) +instance Typeable a => GQLType (MyUnion a) where+  type KIND (MyUnion a) = UNION+ data CityID   = Paris   | BLN   | HH-  deriving (Generic, GQLType)+  deriving (Generic) +instance GQLType CityID where+  type KIND CityID = ENUM+ data Euro =   Euro Int        Int-  deriving (Generic, GQLType)+  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) -newtype UID = UID-  { uid :: Text-  } deriving (Show, Generic, GQLType)- data Coordinates = Coordinates   { latitude  :: Euro-  , longitude :: [Maybe [[UID]]]+  , 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, GQLType)+  } deriving (Generic) +instance GQLType Address where+  type KIND Address = OBJECT+ data AddressArgs = AddressArgs   { coordinates :: Coordinates   , comment     :: Maybe Text@@ -94,13 +131,15 @@   } deriving (Generic)  instance Typeable a => GQLType (User a) where+  type KIND (User a) = OBJECT   description _ = "Custom Description for Client Defined User Type" -type instance KIND (A a) = OBJECT+instance Typeable a => GQLType (A a) where+  type KIND (A a) = OBJECT  newtype A a = A   { wrappedA :: a-  } deriving (Generic, GQLType)+  } deriving (Generic)  fetchAddress :: Monad m => Euro -> m (Either String Address) fetchAddress _ = return $ Right $ Address " " "" 0@@ -119,11 +158,11 @@     }   where     unionAddress = Address {city = "Hamburg", street = "Street", houseNumber = 20}-    -- Office-    resolveOffice OfficeArgs {cityID = Paris} = gqlResolver $ fetchAddress (Euro 1 1)-    resolveOffice OfficeArgs {cityID = BLN}   = gqlResolver $ fetchAddress (Euro 1 2)-    resolveOffice OfficeArgs {cityID = HH}    = gqlResolver $ fetchAddress (Euro 1 3)-    resolveAddress = gqlResolver $ fetchAddress (Euro 1 0)+  -- 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"@@ -134,48 +173,69 @@         , myUnion = const $ return $ ADDRESS unionAddress         } -createUserMutation :: a -> EffectM (User EffectM)-createUserMutation _ = gqlEffectResolver ["UPDATE_USER"] fetchUser--newUserSubscription :: a -> EffectM (User EffectM)-newUserSubscription _ = gqlEffectResolver ["UPDATE_USER"] fetchUser--createAddressMutation :: a -> EffectM Address-createAddressMutation _ = gqlEffectResolver ["UPDATE_ADDRESS"] (fetchAddress (Euro 1 0))+newtype AnimalArgs = AnimalArgs+  { animal :: Animal+  } deriving (Show, Generic) -newAddressSubscription :: a -> EffectM Address-newAddressSubscription _ = gqlEffectResolver ["UPDATE_ADDRESS"] $ fetchAddress (Euro 1 0)+setAnimalResolver :: AnimalArgs -> IORes Text+setAnimalResolver AnimalArgs {animal} = return $ pack $ show animal  data Query = Query-  { user       :: () -> ResM (User ResM)+  { 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    :: () -> EffectM (User EffectM)-  , createAddress :: () -> EffectM Address+  { createUser    :: () -> MutRes (User MutRes)+  , createAddress :: () -> MutRes Address   } deriving (Generic)  data Subscription = Subscription-  { newUser    :: () -> EffectM (User EffectM)-  , newAddress :: () -> EffectM Address+  { newAddress :: () -> SubRes Address+  , newUser    :: () -> SubRes (User IORes)   } deriving (Generic) -gqlRoot :: GQLRootResolver IO Query Mutation Subscription+gqlRoot :: GQLRootResolver IO Channel Content Query Mutation Subscription gqlRoot =   GQLRootResolver     { queryResolver =         return           Query-            { user = const $ gqlResolver fetchUser+            { 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 {createUser = createUserMutation, createAddress = createAddressMutation}-    , subscriptionResolver = return Subscription {newUser = newUserSubscription, newAddress = newAddressSubscription}+    , 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/Main.hs view
@@ -1,38 +1,105 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}  module Main   ( main   ) where  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           Deprecated.API                 (gqlRoot)+import           Data.Morpheus.Types            (ScalarValue (..))+import           Deprecated.API                 (Channel, Content, gqlRoot) import           Mythology.API                  (mythologyApi)+import           TH.API                         (thApi)+ 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           Web.Scotty                     (body, file, get, post, raw, scottyApp) -{--const ws = new WebSocket('ws://localhost:3000/');-ws.send(JSON.stringify({"query":"query GetUser{user{name}}"}))-ws.send(JSON.stringify({"query":"mutation CreateUser{ createUser{name} }"}))-ws.send(JSON.stringify({"query":"subscription ShowNewUser{ newUser{name} }"}))--}+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!)+      {+        user {+           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   Warp.runSettings settings $ WaiWs.websocketsOr defaultConnectionOptions (wsApp state) httpApp   where     settings = Warp.setPort 3000 Warp.defaultSettings-    wsApp = gqlSocketApp (interpreter gqlRoot)-    httpServer :: GQLState -> IO Wai.Application+    wsApp = gqlSocketApp gqlRoot+    httpServer :: GQLState IO Channel Content -> IO Wai.Application     httpServer state =       scottyApp $ do         post "/" $ raw =<< (liftIO . interpreter gqlRoot state =<< body)         get "/" $ file "examples/index.html"+        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)+        get "/th" $ file "examples/index.html"
examples/Mythology/API.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RankNTypes    #-}-{-# LANGUAGE TypeOperators #-}  module Mythology.API   ( mythologyApi@@ -9,13 +7,13 @@ import qualified Data.ByteString.Lazy.Char8 as B  import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Types        (GQLRootResolver (..), ResM, gqlResolver)+import           Data.Morpheus.Types        (GQLRootResolver (..), IORes, resolver) import           Data.Text                  (Text) import           GHC.Generics               (Generic) import           Mythology.Character.Deity  (Deity (..), dbDeity)  newtype Query = Query-  { deity :: DeityArgs -> ResM Deity+  { deity :: DeityArgs -> IORes Deity   } deriving (Generic)  data DeityArgs = DeityArgs@@ -23,10 +21,10 @@   , mythology :: Maybe Text -- Optional Argument   } deriving (Generic) -resolveDeity :: DeityArgs -> ResM Deity-resolveDeity args = gqlResolver $ dbDeity (name args) (mythology args)+resolveDeity :: DeityArgs -> IORes Deity+resolveDeity args = resolver $ dbDeity (name args) (mythology args) -rootResolver :: GQLRootResolver IO Query () ()+rootResolver :: GQLRootResolver IO () () Query () () rootResolver =   GQLRootResolver     { queryResolver = return Query {deity = resolveDeity}
examples/Mythology/Character/Deity.hs view
@@ -8,22 +8,21 @@   , dbDeity   ) where -import           Data.Morpheus.Kind     (KIND, OBJECT)+import           Data.Morpheus.Kind     (OBJECT) import           Data.Morpheus.Types    (GQLType (..)) import           Data.Text              (Text) import           GHC.Generics           (Generic) import           Mythology.Place.Places (Realm (..)) -type instance KIND Deity = OBJECT--instance GQLType Deity where-  description _ = "Custom Description for Client Defined User Type"- data Deity = Deity   { fullName :: Text -- Non-Nullable Field   , power    :: Maybe Text -- Nullable Field   , realm    :: Realm   } deriving (Generic)++instance GQLType Deity where+  type KIND Deity = OBJECT+  description _ = "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/Mythology/Character/Human.hs view
@@ -1,21 +1,21 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric  #-}-{-# LANGUAGE TypeFamilies   #-}-{-# LANGUAGE TypeOperators  #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies  #-}+{-# LANGUAGE TypeOperators #-}  module Mythology.Character.Human   ( Human(..)   ) where -import           Data.Morpheus.Kind     (KIND, OBJECT)-import           Data.Morpheus.Types    (GQLType)+import           Data.Morpheus.Kind     (OBJECT)+import           Data.Morpheus.Types    (GQLType (..)) import           Data.Text              (Text) import           GHC.Generics           (Generic) import           Mythology.Place.Places (City (..)) -type instance KIND Human = OBJECT- data Human = Human   { name :: Text   , home :: City-  } deriving (Generic, GQLType)+  } deriving (Generic)++instance GQLType Human where+  type KIND Human = OBJECT
examples/Mythology/Place/Places.hs view
@@ -7,21 +7,20 @@   , City(..)   ) where -import           Data.Morpheus.Kind  (ENUM, KIND)-import           Data.Morpheus.Types (GQLType)+import           Data.Morpheus.Kind  (ENUM)+import           Data.Morpheus.Types (GQLType (..)) import           GHC.Generics        (Generic) -type instance KIND Realm = ENUM- data Realm   = MountOlympus   | Sky   | Sea   | Underworld   | Dream-  deriving (Generic, GQLType)+  deriving (Generic) -type instance KIND City = ENUM+instance GQLType Realm where+  type KIND Realm = ENUM  data City   = Athens@@ -30,3 +29,6 @@   | Ithaca   | Sparta   | Troy++instance GQLType City where+  type KIND City = ENUM
+ examples/TH/API.hs view
@@ -0,0 +1,95 @@+{-# 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 (..), 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!+  }++  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!]]!+  }++  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
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TypeFamilies      #-}++module TH.Simple+  ( mythologyApi+  ) where++import qualified Data.ByteString.Lazy.Char8 as B++import           Data.Morpheus              (interpreter)+import           Data.Morpheus.Document     (gqlDocument)+import           Data.Morpheus.Types        (GQLRootResolver (..), IORes)+import           Data.Text                  (Text)++[gqlDocument|++  type Query {+    deity (uid: Text! ) : Deity!+  }++  type Deity {+    name : Text!+    power    : Text+  }++|]++rootResolver :: GQLRootResolver IO () () Query () ()+rootResolver =+  GQLRootResolver {queryResolver = return Query {deity}, mutationResolver = pure (), subscriptionResolver = pure ()}+  where+    deity DeityArgs {uid} = pure Deity {name, power}+      where+        name _ = pure "Morpheus"+        power _ = pure (Just "Shapeshifting")++mythologyApi :: B.ByteString -> IO B.ByteString+mythologyApi = interpreter rootResolver
morpheus-graphql.cabal view
@@ -2,14 +2,14 @@ -- -- see: https://github.com/sol/hpack ----- hash: fe81f2e1d1a7d86ae0559141dda5d0e6bc1749b212b11ce0ba37b9f020b58e48+-- hash: 35f695de21554f250ad8651a2887d5541f953f6e939c8c85d233123317609512  name:           morpheus-graphql-version:        0.1.1+version:        0.2.0 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql-homepage:       https://github.com/nalchevanidze/morpheus-graphql#readme+homepage:       https://morpheusgraphql.com bug-reports:    https://github.com/nalchevanidze/morpheus-graphql/issues author:         Daviti Nalchevanidze maintainer:     d.nalchevanidze@gmail.com@@ -18,6 +18,8 @@ license-file:   LICENSE build-type:     Simple cabal-version:  >= 1.10+extra-source-files:+    changelog.md data-files:     test/Feature/Holistic/API.gql     test/Feature/Holistic/arguments/nameConflict/query.gql@@ -35,8 +37,12 @@     test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json     test/Feature/Holistic/fragment/loopingFragment/query.gql     test/Feature/Holistic/fragment/loopingFragment/response.json+    test/Feature/Holistic/fragment/nameCollision/query.gql+    test/Feature/Holistic/fragment/nameCollision/response.json     test/Feature/Holistic/fragment/unknownTargetType/query.gql     test/Feature/Holistic/fragment/unknownTargetType/response.json+    test/Feature/Holistic/fragment/unusedFragment/query.gql+    test/Feature/Holistic/fragment/unusedFragment/response.json     test/Feature/Holistic/introspection/defaultTypes/Boolean/query.gql     test/Feature/Holistic/introspection/defaultTypes/Boolean/response.json     test/Feature/Holistic/introspection/defaultTypes/Float/query.gql@@ -75,6 +81,8 @@     test/Feature/Holistic/introspection/schemaTypes/__TypeKind/response.json     test/Feature/Holistic/parsing/complex/query.gql     test/Feature/Holistic/parsing/complex/response.json+    test/Feature/Holistic/parsing/duplicatedFields/query.gql+    test/Feature/Holistic/parsing/duplicatedFields/response.json     test/Feature/Holistic/parsing/extraCommas/query.gql     test/Feature/Holistic/parsing/extraCommas/response.json     test/Feature/Holistic/parsing/generousSpaces/query.gql@@ -102,6 +110,27 @@     test/Feature/Holistic/selection/nameConflict/response.json     test/Feature/Holistic/selection/unknownField/query.gql     test/Feature/Holistic/selection/unknownField/response.json+    test/Feature/Input/Enum/cases.json+    test/Feature/Input/Enum/decode2Con/query.gql+    test/Feature/Input/Enum/decode2Con/response.json+    test/Feature/Input/Enum/decode3Con/query.gql+    test/Feature/Input/Enum/decode3Con/response.json+    test/Feature/Input/Enum/decodeInvalidValue/query.gql+    test/Feature/Input/Enum/decodeInvalidValue/response.json+    test/Feature/Input/Enum/decodeMany/con0/query.gql+    test/Feature/Input/Enum/decodeMany/con0/response.json+    test/Feature/Input/Enum/decodeMany/con1/query.gql+    test/Feature/Input/Enum/decodeMany/con1/response.json+    test/Feature/Input/Enum/decodeMany/con2/query.gql+    test/Feature/Input/Enum/decodeMany/con2/response.json+    test/Feature/Input/Enum/decodeMany/con3/query.gql+    test/Feature/Input/Enum/decodeMany/con3/response.json+    test/Feature/Input/Enum/decodeMany/con4/query.gql+    test/Feature/Input/Enum/decodeMany/con4/response.json+    test/Feature/Input/Enum/decodeMany/con5/query.gql+    test/Feature/Input/Enum/decodeMany/con5/response.json+    test/Feature/Input/Enum/decodeMany/con6/query.gql+    test/Feature/Input/Enum/decodeMany/con6/response.json     test/Feature/InputType/cases.json     test/Feature/InputType/variables/incompatibleType/equalType/query.gql     test/Feature/InputType/variables/incompatibleType/equalType/response.json@@ -185,56 +214,82 @@       Data.Morpheus.Kind       Data.Morpheus.Types       Data.Morpheus.Server+      Data.Morpheus.Document+      Data.Morpheus.Client   other-modules:       Data.Morpheus.Error.Arguments+      Data.Morpheus.Error.Client.Client       Data.Morpheus.Error.Fragment       Data.Morpheus.Error.Input       Data.Morpheus.Error.Internal       Data.Morpheus.Error.Mutation       Data.Morpheus.Error.Schema       Data.Morpheus.Error.Selection-      Data.Morpheus.Error.Spread       Data.Morpheus.Error.Subscription       Data.Morpheus.Error.Utils       Data.Morpheus.Error.Variable-      Data.Morpheus.Interpreter-      Data.Morpheus.Parser.Arguments-      Data.Morpheus.Parser.Body-      Data.Morpheus.Parser.Fragment-      Data.Morpheus.Parser.Internal-      Data.Morpheus.Parser.Operator-      Data.Morpheus.Parser.Parser-      Data.Morpheus.Parser.Primitive-      Data.Morpheus.Parser.Terms-      Data.Morpheus.Parser.Value-      Data.Morpheus.Resolve.Decode-      Data.Morpheus.Resolve.Encode-      Data.Morpheus.Resolve.Generics.EnumRep-      Data.Morpheus.Resolve.Generics.TypeRep-      Data.Morpheus.Resolve.Introspect-      Data.Morpheus.Resolve.Operator-      Data.Morpheus.Resolve.Resolve+      Data.Morpheus.Execution.Client.Aeson+      Data.Morpheus.Execution.Client.Build+      Data.Morpheus.Execution.Client.Compile+      Data.Morpheus.Execution.Client.Fetch+      Data.Morpheus.Execution.Client.Selection+      Data.Morpheus.Execution.Document.Compile+      Data.Morpheus.Execution.Document.Convert+      Data.Morpheus.Execution.Document.Declare+      Data.Morpheus.Execution.Document.GQLType+      Data.Morpheus.Execution.Internal.Declare+      Data.Morpheus.Execution.Internal.Utils+      Data.Morpheus.Execution.Server.Decode+      Data.Morpheus.Execution.Server.Encode+      Data.Morpheus.Execution.Server.Generics.EnumRep+      Data.Morpheus.Execution.Server.Interpreter+      Data.Morpheus.Execution.Server.Introspect+      Data.Morpheus.Execution.Server.Resolve+      Data.Morpheus.Execution.Subscription.Apollo+      Data.Morpheus.Execution.Subscription.ClientRegister+      Data.Morpheus.Parsing.Client.ParseMeta+      Data.Morpheus.Parsing.Client.Parser+      Data.Morpheus.Parsing.Document.DataType+      Data.Morpheus.Parsing.Document.Parse+      Data.Morpheus.Parsing.Document.Parser+      Data.Morpheus.Parsing.Internal.Create+      Data.Morpheus.Parsing.Internal.Internal+      Data.Morpheus.Parsing.Internal.Terms+      Data.Morpheus.Parsing.JSONSchema.Parse+      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.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.Schema.Schema       Data.Morpheus.Schema.SchemaAPI       Data.Morpheus.Schema.Type       Data.Morpheus.Schema.TypeKind-      Data.Morpheus.Server.Apollo-      Data.Morpheus.Server.ClientRegister       Data.Morpheus.Types.Custom       Data.Morpheus.Types.GQLScalar       Data.Morpheus.Types.GQLType       Data.Morpheus.Types.ID-      Data.Morpheus.Types.Internal.AST.Operator+      Data.Morpheus.Types.Internal.AST.Operation       Data.Morpheus.Types.Internal.AST.RawSelection       Data.Morpheus.Types.Internal.AST.Selection       Data.Morpheus.Types.Internal.Base       Data.Morpheus.Types.Internal.Data+      Data.Morpheus.Types.Internal.DataD+      Data.Morpheus.Types.Internal.Stream+      Data.Morpheus.Types.Internal.TH       Data.Morpheus.Types.Internal.Validation       Data.Morpheus.Types.Internal.Value       Data.Morpheus.Types.Internal.WebSocket@@ -246,7 +301,6 @@       Data.Morpheus.Validation.Input.Enum       Data.Morpheus.Validation.Input.Object       Data.Morpheus.Validation.Selection-      Data.Morpheus.Validation.Spread       Data.Morpheus.Validation.Utils.Selection       Data.Morpheus.Validation.Utils.Utils       Data.Morpheus.Validation.Validation@@ -257,15 +311,19 @@   ghc-options: -Wall   build-depends:       aeson >=1.0 && <=1.5+    , attoparsec >=0.13.2 && <0.14     , base >=4.7 && <5     , bytestring >=0.10.4 && <0.11     , containers >=0.4.2.1 && <0.7+    , lens     , megaparsec >=7.0.0 && <8.0     , mtl >=2.0 && <=2.2.2     , scientific >=0.3.6.2 && <0.4+    , template-haskell     , text >=1.2.3.0 && <1.3     , transformers >=0.3.0.0 && <0.6     , unordered-containers >=0.2.8.0 && <0.3+    , utf8-string >=1.0.1 && <1.1     , uuid >=1.0 && <=1.4     , vector >=0.12.0.1 && <0.13     , wai-websockets >=1.0 && <=3.5@@ -282,23 +340,29 @@       Mythology.Character.Deity       Mythology.Character.Human       Mythology.Place.Places+      TH.API+      TH.Simple       Paths_morpheus_graphql   hs-source-dirs:       examples   ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall   build-depends:       aeson+    , attoparsec >=0.13.2 && <0.14     , base >=4.7 && <5     , bytestring     , containers >=0.4.2.1 && <0.7+    , lens     , megaparsec >=7.0.0 && <8.0     , morpheus-graphql     , mtl     , scientific >=0.3.6.2 && <0.4     , scotty+    , template-haskell     , text     , transformers >=0.3.0.0 && <0.6     , unordered-containers >=0.2.8.0 && <0.3+    , utf8-string >=1.0.1 && <1.1     , uuid >=1.0 && <=1.4     , vector >=0.12.0.1 && <0.13     , wai@@ -307,11 +371,43 @@     , websockets >=0.11.0 && <=0.12.5.3   default-language: Haskell2010 +executable morpheus+  main-is: Main.hs+  other-modules:+      Paths_morpheus_graphql+  hs-source-dirs:+      CLI+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      aeson+    , attoparsec >=0.13.2 && <0.14+    , base >=4.7 && <5+    , bytestring+    , containers >=0.4.2.1 && <0.7+    , filepath >=1.1 && <1.5+    , lens+    , megaparsec >=7.0.0 && <8.0+    , morpheus-graphql+    , mtl+    , optparse-applicative >=0.12 && <0.15+    , scientific >=0.3.6.2 && <0.4+    , template-haskell+    , text+    , transformers >=0.3.0.0 && <0.6+    , unordered-containers >=0.2.8.0 && <0.3+    , utf8-string >=1.0.1 && <1.1+    , uuid >=1.0 && <=1.4+    , vector >=0.12.0.1 && <0.13+    , wai-websockets >=1.0 && <=3.5+    , websockets >=0.11.0 && <=0.12.5.3+  default-language: Haskell2010+ test-suite morpheus-test   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:       Feature.Holistic.API+      Feature.Input.Enum.API       Feature.InputType.API       Feature.Schema.A2       Feature.Schema.API@@ -325,18 +421,22 @@   ghc-options: -Wall   build-depends:       aeson+    , attoparsec >=0.13.2 && <0.14     , base >=4.7 && <5     , bytestring >=0.10.4 && <0.11     , containers >=0.4.2.1 && <0.7+    , lens     , megaparsec >=7.0.0 && <8.0     , morpheus-graphql     , mtl >=2.0 && <=2.2.2     , scientific >=0.3.6.2 && <0.4     , tasty     , tasty-hunit+    , template-haskell     , text >=1.2.3.0 && <1.3     , transformers >=0.3.0.0 && <0.6     , unordered-containers >=0.2.8.0 && <0.3+    , utf8-string >=1.0.1 && <1.1     , uuid >=1.0 && <=1.4     , vector >=0.12.0.1 && <0.13     , wai-websockets >=1.0 && <=3.5
src/Data/Morpheus.hs view
@@ -3,4 +3,4 @@   ( Interpreter(..)   ) where -import           Data.Morpheus.Interpreter (Interpreter (..))+import           Data.Morpheus.Execution.Server.Interpreter (Interpreter (..))
+ src/Data/Morpheus/Client.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Client+  ( gql+  , Fetch(..)+  , defineQuery+  , defineByDocument+  , defineByDocumentFile+  , defineByIntrospection+  , defineByIntrospectionFile+  ) where++import           Data.ByteString.Lazy                    (ByteString)+import qualified Data.ByteString.Lazy                    as L (readFile)+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote++-- MORPHEUS+import           Data.Morpheus.Execution.Client.Build    (defineQuery)+import           Data.Morpheus.Execution.Client.Compile  (compileSyntax)+import           Data.Morpheus.Execution.Client.Fetch    (Fetch (..))+import           Data.Morpheus.Parsing.Document.Parse    (parseFullGQLDocument)+import           Data.Morpheus.Parsing.JSONSchema.Parse  (decodeIntrospection)+import           Data.Morpheus.Types.Internal.Data       (DataTypeLib)+import           Data.Morpheus.Types.Internal.Validation (Validation)+import           Data.Morpheus.Types.Types               (GQLQueryRoot)++gql :: QuasiQuoter+gql =+  QuasiQuoter+    { quoteExp = compileSyntax+    , quotePat = notHandled "Patterns"+    , quoteType = notHandled "Types"+    , quoteDec = notHandled "Declarations"+    }+  where+    notHandled things = error $ things ++ " are not supported by the GraphQL QuasiQuoter"++defineByDocumentFile :: String -> (GQLQueryRoot, String) -> Q [Dec]+defineByDocumentFile = defineByDocument . L.readFile++defineByIntrospectionFile :: String -> (GQLQueryRoot, String) -> Q [Dec]+defineByIntrospectionFile = defineByIntrospection . L.readFile++--+--+-- TODO: Define By API+-- Validates By Server API+--+defineByDocument :: IO ByteString -> (GQLQueryRoot, String) -> Q [Dec]+defineByDocument doc = defineQuery (schemaByDocument doc)++schemaByDocument :: IO ByteString -> IO (Validation DataTypeLib)+schemaByDocument documentGQL = parseFullGQLDocument <$> documentGQL++defineByIntrospection :: IO ByteString -> (GQLQueryRoot, String) -> Q [Dec]+defineByIntrospection json = defineQuery (decodeIntrospection <$> json)
+ src/Data/Morpheus/Document.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns   #-}++module Data.Morpheus.Document+  ( toGraphQLDocument+  , toMorpheusHaskellAPi+  , gqlDocument+  ) where++import           Data.ByteString.Lazy.Char8               (ByteString, pack)+import           Language.Haskell.TH.Quote++--+-- MORPHEUS+import           Data.Morpheus.Execution.Document.Compile (compileDec, compileExp)+import           Data.Morpheus.Execution.Server.Resolve   (RootResCon, fullSchema)+import           Data.Morpheus.Parsing.Document.Parse     (parseGraphQLDocument)+import           Data.Morpheus.Rendering.GQL              (renderGraphQLDocument)+import           Data.Morpheus.Rendering.Haskell.Render   (renderHaskellDocument)+import           Data.Morpheus.Types                      (GQLRootResolver)++-- | Generates schema.gql file from 'GQLRootResolver'+toGraphQLDocument :: RootResCon m e c query mut sub => proxy (GQLRootResolver m e c query mut sub) -> ByteString+toGraphQLDocument x =+  case fullSchema x of+    Left errors -> pack (show errors)+    Right lib   -> renderGraphQLDocument lib++toMorpheusHaskellAPi :: String -> ByteString -> Either ByteString ByteString+toMorpheusHaskellAPi moduleName doc =+  case parseGraphQLDocument doc of+    Left errors -> Left $ pack (show errors)+    Right lib   -> Right $ renderHaskellDocument moduleName lib++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"
src/Data/Morpheus/Error/Arguments.hs view
@@ -8,7 +8,7 @@   ) where  import           Data.Morpheus.Error.Utils               (errorMessage)-import           Data.Morpheus.Types.Internal.Base       (Position, EnhancedKey (..))+import           Data.Morpheus.Types.Internal.Base       (EnhancedKey (..), Position) import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors) import           Data.Text                               (Text) import qualified Data.Text                               as T (concat)@@ -28,21 +28,27 @@   - date(name: "name") -> "Unknown argument \"name\" on field \"date\" of type \"Experience\"." -} argumentGotInvalidValue :: Text -> Text -> Position -> GQLErrors-argumentGotInvalidValue key' inputMessage' position' = errorMessage position' text+argumentGotInvalidValue key' inputMessage' position' =+  errorMessage position' text   where     text = T.concat ["Argument ", key', " got invalid value ;", inputMessage']  unknownArguments :: Text -> [EnhancedKey] -> GQLErrors unknownArguments fieldName = map keyToError   where-    keyToError (EnhancedKey argName pos) = GQLError {desc = toMessage argName, positions = [pos]}-    toMessage argName = T.concat ["Unknown Argument \"", argName, "\" on Field \"", fieldName, "\"."]+    keyToError (EnhancedKey argName pos) =+      GQLError {desc = toMessage argName, positions = [pos]}+    toMessage argName =+      T.concat+        ["Unknown Argument \"", argName, "\" on Field \"", fieldName, "\"."]  argumentNameCollision :: [EnhancedKey] -> GQLErrors argumentNameCollision = map keyToError   where-    keyToError (EnhancedKey argName pos) = GQLError {desc = toMessage argName, positions = [pos]}-    toMessage argName = T.concat ["There can Be only One Argument Named \"", argName, "\""]+    keyToError (EnhancedKey argName pos) =+      GQLError {desc = toMessage argName, positions = [pos]}+    toMessage argName =+      T.concat ["There can Be only One Argument Named \"", argName, "\""]  undefinedArgument :: EnhancedKey -> GQLErrors undefinedArgument (EnhancedKey key' position') = errorMessage position' text
+ src/Data/Morpheus/Error/Client/Client.hs view
@@ -0,0 +1,11 @@+module Data.Morpheus.Error.Client.Client+  ( renderGQLErrors+  ) where++import           Data.Aeson                              (encode)+import           Data.ByteString.Lazy.Char8              (unpack)+import           Data.Morpheus.Error.Utils               (renderErrors)+import           Data.Morpheus.Types.Internal.Validation (GQLErrors)++renderGQLErrors :: GQLErrors -> String+renderGQLErrors = unpack . encode . renderErrors
src/Data/Morpheus/Error/Fragment.hs view
@@ -1,16 +1,23 @@+{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Error.Fragment   ( cannotSpreadWithinItself+  , unusedFragment+  , unknownFragment+  , cannotBeSpreadOnType+  , fragmentNameCollision   ) where --- import Data.Morpheus.Error.Utils (errorMessage)-import           Data.Morpheus.Types.Internal.Base       (EnhancedKey (..))-import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)---- import Data.Morpheus.Types.Internal.Base (MetaInfo(..))+import           Data.Semigroup                          ((<>))+import           Data.Text                               (Text) import qualified Data.Text                               as T +-- MORPHEUS+import           Data.Morpheus.Error.Utils               (errorMessage)+import           Data.Morpheus.Types.Internal.Base       (EnhancedKey (..), Position)+import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)+ {-   FRAGMENT:     type Experience {@@ -22,8 +29,27 @@     fragment H on D {...}  ->  "Unknown type \"D\"."     {...H} -> "Unknown fragment \"H\"." -}+fragmentNameCollision :: [EnhancedKey] -> GQLErrors+fragmentNameCollision = map toError+  where+    toError EnhancedKey {uid, location} =+      GQLError+        { desc = "There can be only one fragment named \"" <> uid <> "\"."+        , positions = [location]+        }++unusedFragment :: [EnhancedKey] -> GQLErrors+unusedFragment = map toError+  where+    toError EnhancedKey {uid, location} =+      GQLError+        { desc = "Fragment \"" <> uid <> "\" is never used."+        , positions = [location]+        }+ cannotSpreadWithinItself :: [EnhancedKey] -> GQLErrors-cannotSpreadWithinItself fragments = [GQLError {desc = text, positions = map location fragments}]+cannotSpreadWithinItself fragments =+  [GQLError {desc = text, positions = map location fragments}]   where     text =       T.concat@@ -33,3 +59,27 @@         , T.intercalate "," (map uid fragments)         , "."         ]++-- {...H} -> "Unknown fragment \"H\"."+unknownFragment :: Text -> Position -> GQLErrors+unknownFragment key' position' = errorMessage position' text+  where+    text = T.concat ["Unknown Fragment \"", key', "\"."]++-- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."+cannotBeSpreadOnType :: Maybe Text -> Text -> Position -> Text -> GQLErrors+cannotBeSpreadOnType key' type' position' selectionType' =+  errorMessage position' text+  where+    text =+      T.concat+        [ "Fragment"+        , getName key'+        , " cannot be spread here as objects of type \""+        , selectionType'+        , "\" can never be of type \""+        , type'+        , "\"."+        ]+    getName (Just x') = T.concat [" \"", x', "\""]+    getName Nothing   = ""
src/Data/Morpheus/Error/Input.hs view
@@ -16,24 +16,21 @@ type InputValidation a = Either InputError a  data InputError-  = UnexpectedType [Prop]-                   Text-                   Value-                   (Maybe Text)-  | UndefinedField [Prop]-                   Text-  | UnknownField [Prop]-                 Text+  = UnexpectedType [Prop] Text Value (Maybe Text)+  | UndefinedField [Prop] Text+  | UnknownField [Prop] Text -data Prop = Prop-  { propKey  :: Text-  , propType :: Text-  }+data Prop =+  Prop+    { propKey  :: Text+    , propType :: Text+    }  inputErrorMessage :: InputError -> Text-inputErrorMessage (UnexpectedType path type' value errorMessage) = expectedTypeAFoundB path type' value errorMessage-inputErrorMessage (UndefinedField path' field')                  = undefinedField path' field'-inputErrorMessage (UnknownField path' field')                    = unknownField path' field'+inputErrorMessage (UnexpectedType path type' value errorMessage) =+  expectedTypeAFoundB path type' value errorMessage+inputErrorMessage (UndefinedField path' field') = undefinedField path' field'+inputErrorMessage (UnknownField path' field') = unknownField path' field'  pathToText :: [Prop] -> Text pathToText []    = ""@@ -41,7 +38,14 @@  expectedTypeAFoundB :: [Prop] -> Text -> Value -> Maybe Text -> Text expectedTypeAFoundB path' expected found Nothing =-  T.concat [pathToText path', " Expected type \"", expected, "\" found ", T.pack (unpack $ encode found), "."]+  T.concat+    [ pathToText path'+    , " Expected type \""+    , expected+    , "\" found "+    , T.pack (unpack $ encode found)+    , "."+    ] expectedTypeAFoundB path' expected found (Just errorMessage) =   T.concat     [ pathToText path'@@ -55,7 +59,9 @@     ]  undefinedField :: [Prop] -> Text -> Text-undefinedField path' field' = T.concat [pathToText path', " Undefined Field \"", field', "\"."]+undefinedField path' field' =+  T.concat [pathToText path', " Undefined Field \"", field', "\"."]  unknownField :: [Prop] -> Text -> Text-unknownField path' field' = T.concat [pathToText path', " Unknown Field \"", field', "\"."]+unknownField path' field' =+  T.concat [pathToText path', " Unknown Field \"", field', "\"."]
src/Data/Morpheus/Error/Internal.hs view
@@ -20,11 +20,14 @@ internalError x = Left $ globalErrorMessage $ T.concat ["INTERNAL ERROR: ", x]  internalErrorT :: Monad m => Text -> ResolveT m b-internalErrorT x = failResolveT $ globalErrorMessage $ T.concat ["INTERNAL ERROR: ", x]+internalErrorT x =+  failResolveT $ globalErrorMessage $ T.concat ["INTERNAL ERROR: ", x]  -- if type did not not found, but was defined by Schema internalUnknownTypeMessage :: Text -> GQLErrors-internalUnknownTypeMessage x = globalErrorMessage $ T.concat ["type did not not found, but was defined by Schema", x]+internalUnknownTypeMessage x =+  globalErrorMessage $+  T.concat ["type did not not found, but was defined by Schema", x]  -- if arguments is already validated but has not found required argument internalArgumentError :: Text -> Either GQLErrors b@@ -32,4 +35,5 @@  -- if value is already validated but value has different type internalTypeMismatch :: Text -> Value -> Either GQLErrors b-internalTypeMismatch text jsType = internalError $ T.concat ["Type mismatch ", text, T.pack $ show jsType]+internalTypeMismatch text jsType =+  internalError $ T.concat ["Type mismatch ", text, T.pack $ show jsType]
src/Data/Morpheus/Error/Mutation.hs view
@@ -9,4 +9,5 @@ import           Data.Morpheus.Types.Internal.Validation (GQLErrors)  mutationIsNotDefined :: Position -> GQLErrors-mutationIsNotDefined position' = errorMessage position' "Schema is not configured for mutations."+mutationIsNotDefined position' =+  errorMessage position' "Schema is not configured for mutations."
src/Data/Morpheus/Error/Schema.hs view
@@ -11,8 +11,11 @@ import           Data.Text                               (Text)  schemaValidationError :: Text -> GQLErrors-schemaValidationError error' = globalErrorMessage $ "Schema Validation Error, " <> error'+schemaValidationError error' =+  globalErrorMessage $ "Schema Validation Error, " <> error'  nameCollisionError :: Text -> GQLErrors nameCollisionError name =-  schemaValidationError $ "Name collision: \"" <> name <> "\" is used for different dataTypes in two separate modules"+  schemaValidationError $+  "Name collision: \"" <> name <>+  "\" is used for different dataTypes in two separate modules"
src/Data/Morpheus/Error/Selection.hs view
@@ -23,21 +23,44 @@ 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/Error/Spread.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Spread-  ( unknownFragment-  , cannotBeSpreadOnType-  ) where--import           Data.Morpheus.Error.Utils               (errorMessage)-import           Data.Morpheus.Types.Internal.Base       (Position)-import           Data.Morpheus.Types.Internal.Validation (GQLErrors)-import           Data.Text                               (Text)-import qualified Data.Text                               as T---- {...H} -> "Unknown fragment \"H\"."-unknownFragment :: Text -> Position -> GQLErrors-unknownFragment key' position' = errorMessage position' text-  where-    text = T.concat ["Unknown Fragment \"", key', "\"."]---- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."-cannotBeSpreadOnType :: Maybe Text -> Text -> Position -> Text -> GQLErrors-cannotBeSpreadOnType key' type' position' selectionType' = errorMessage position' text-  where-    text =-      T.concat-        [ "Fragment"-        , getName key'-        , " cannot be spread here as objects of type \""-        , selectionType'-        , "\" can never be of type \""-        , type'-        , "\"."-        ]-    getName (Just x') = T.concat [" \"", x', "\""]-    getName Nothing   = ""
src/Data/Morpheus/Error/Subscription.hs view
@@ -9,4 +9,5 @@ import           Data.Morpheus.Types.Internal.Validation (GQLErrors)  subscriptionIsNotDefined :: Position -> GQLErrors-subscriptionIsNotDefined position' = errorMessage position' "Schema is not configured for subscriptions."+subscriptionIsNotDefined position' =+  errorMessage position' "Schema is not configured for subscriptions."
src/Data/Morpheus/Error/Utils.hs view
@@ -5,11 +5,12 @@   , globalErrorMessage   , renderErrors   , badRequestError+  , toLocation   ) where  import           Data.ByteString.Lazy.Char8              (ByteString, pack) import           Data.Morpheus.Types.Internal.Base       (Position)-import           Data.Morpheus.Types.Internal.Validation (ErrorLocation (..), GQLError (..), GQLErrors, JSONError (..))+import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors, JSONError (..), Location (..)) import           Data.Text                               (Text) import           Text.Megaparsec                         (SourcePos (SourcePos), sourceColumn, sourceLine, unPos) @@ -23,11 +24,10 @@ renderErrors = map renderError  renderError :: GQLError -> JSONError-renderError GQLError {desc, positions} = JSONError {message = desc, locations = map toErrorLocation positions}+renderError GQLError {desc, positions} = JSONError {message = desc, locations = positions} -toErrorLocation :: Position -> ErrorLocation-toErrorLocation SourcePos {sourceLine, sourceColumn} =-  ErrorLocation {line = unPos sourceLine, column = unPos sourceColumn}+toLocation :: SourcePos -> Location+toLocation SourcePos {sourceLine, sourceColumn} = Location {line = unPos sourceLine, column = unPos sourceColumn}  badRequestError :: String -> ByteString badRequestError aesonError' = pack $ "Bad Request. Could not decode Request body: " ++ aesonError'
src/Data/Morpheus/Error/Variable.hs view
@@ -18,10 +18,12 @@  -- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"." incompatibleVariableType :: Text -> Text -> Text -> Position -> GQLErrors-incompatibleVariableType variableName variableType argType argPosition = errorMessage argPosition text+incompatibleVariableType variableName variableType argType argPosition =+  errorMessage argPosition text   where     text =-      "Variable \"$" <> variableName <> "\" of type \"" <> variableType <> "\" used in position expecting type \"" <>+      "Variable \"$" <> variableName <> "\" of type \"" <> variableType <>+      "\" used in position expecting type \"" <>       argType <>       "\"." @@ -29,15 +31,25 @@ unusedVariables :: Text -> [EnhancedKey] -> GQLErrors unusedVariables operator' = map keyToError   where-    keyToError (EnhancedKey key' position') = GQLError {desc = text key', positions = [position']}-    text key' = T.concat ["Variable \"$", key', "\" is never used in operation \"", operator', "\"."]+    keyToError (EnhancedKey key' position') =+      GQLError {desc = text key', positions = [position']}+    text key' =+      T.concat+        [ "Variable \"$"+        , key'+        , "\" is never used in operation \""+        , operator'+        , "\"."+        ]  -- type mismatch -- { "v": 1  }        "Variable \"$v\" got invalid value 1; Expected type LANGUAGE." variableGotInvalidValue :: Text -> Text -> Position -> GQLErrors-variableGotInvalidValue name' inputMessage' position' = errorMessage position' text+variableGotInvalidValue name' inputMessage' position' =+  errorMessage position' text   where-    text = T.concat ["Variable \"$", name', "\" got invalid value; ", inputMessage']+    text =+      T.concat ["Variable \"$", name', "\" got invalid value; ", inputMessage']  unknownType :: Text -> Position -> GQLErrors unknownType type' position' = errorMessage position' text@@ -47,9 +59,23 @@ undefinedVariable :: Text -> Position -> Text -> GQLErrors undefinedVariable operation' position' key' = errorMessage position' text   where-    text = T.concat ["Variable \"", key', "\" is not defined by operation \"", operation', "\"."]+    text =+      T.concat+        [ "Variable \""+        , key'+        , "\" is not defined by operation \""+        , operation'+        , "\"."+        ]  uninitializedVariable :: Position -> Text -> Text -> GQLErrors uninitializedVariable position' type' key' = errorMessage position' text   where-    text = T.concat ["Variable \"$", key', "\" of required type \"", type', "!\" was not provided."]+    text =+      T.concat+        [ "Variable \"$"+        , key'+        , "\" of required type \""+        , type'+        , "!\" was not provided."+        ]
+ src/Data/Morpheus/Execution/Client/Aeson.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE LambdaCase              #-}+{-# LANGUAGE NamedFieldPuns          #-}+{-# LANGUAGE OverloadedStrings       #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TemplateHaskell         #-}+{-# LANGUAGE TypeApplications        #-}+{-# LANGUAGE TypeFamilies            #-}++module Data.Morpheus.Execution.Client.Aeson+  ( deriveFromJSON+  , takeValueType+  ) where++import           Data.Aeson+import           Data.Aeson.Types+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 (..))++deriveFromJSON :: TypeD -> Q Dec+deriveFromJSON TypeD {tCons = []} = fail "Type Should Have at least one Constructor"+deriveFromJSON TypeD {tName, tCons = [cons]} = defineFromJSON tName aesonObject cons+deriveFromJSON typeD@TypeD {tName, tCons}+  | isEnum tCons = defineFromJSON tName aesonEnum tCons+  | otherwise = defineFromJSON tName aesonUnionObject typeD++aesonObject :: ConsD -> ExpQ+aesonObject con@ConsD {cName} = appE [|withObject cName|] (lamE [varP (mkName "o")] (aesonObjectBody con))++aesonObjectBody :: ConsD -> ExpQ+aesonObjectBody ConsD {cName, cFields} = handleFields cFields+  where+    consName = mkName cName+    handleFields [] = fail $ "No Empty Object"+    handleFields fields = startExp fields+    ----------------------------------------------------------------------------------+         -- Optional Field+      where+        defField FieldD {fieldNameD, fieldTypeD = MaybeD _} = [|o .:? fieldNameD|]+        -- Required Field+        defField FieldD {fieldNameD}                        = [|o .: fieldNameD|]+            -------------------------------------------------------------------+        startExp fNames = uInfixE (conE consName) (varE '(<$>)) (applyFields fNames)+          where+            applyFields []     = fail "No Empty fields"+            applyFields [x]    = defField x+            applyFields (x:xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs)++aesonUnionObject :: TypeD -> ExpQ+aesonUnionObject TypeD {tCons} = appE (varE $ 'takeValueType) (lamCaseE ((map buildMatch tCons) <> [elseCaseEXP]))+  where+    buildMatch cons@ConsD {cName} = match pattern body []+      where+        pattern = tupP [litP (stringL cName), varP $ mkName "o"]+        body = normalB (aesonObjectBody cons)++takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a+takeValueType f (Object hMap) =+  case H.lookup "__typename" hMap of+    Nothing         -> fail "key \"__typename\" not found on object"+    Just (String x) -> pure (unpack x, hMap) >>= f+    Just val        -> fail $ "key \"__typename\" should be string but found: " <> show val+takeValueType _ _ = fail $ "expected Object"++defineFromJSON :: String -> (t -> ExpQ) -> t -> DecQ+defineFromJSON tName func inp =+  instanceD (cxt []) (appT (conT ''FromJSON) (conT $ mkName tName)) [parseJSONExp func inp]+  where+    parseJSONExp :: (t -> ExpQ) -> t -> DecQ+    parseJSONExp parseJ cFields = funD 'parseJSON [clause [] (normalB $ parseJ cFields) []]++isEnum :: [ConsD] -> Bool+isEnum = not . isEmpty . filter (isEmpty . cFields)+  where+    isEmpty = (0 ==) . length++aesonEnum :: [ConsD] -> ExpQ+aesonEnum cons = lamCaseE handlers+  where+    handlers = (map buildMatch cons) <> [elseCaseEXP]+      where+        buildMatch ConsD {cName} = match pattern body []+          where+            pattern = litP $ stringL cName+            body = normalB $ appE (varE 'pure) (conE $ mkName cName)++elseCaseEXP :: MatchQ+elseCaseEXP = match (varP varName) body []+  where+    varName = mkName "invalidValue"+    body =+      normalB $+      appE+        (varE $ mkName "fail")+        (uInfixE (appE (varE 'show) (varE varName)) (varE '(<>)) (stringE $ " is Not Valid Union Constructor"))
+ src/Data/Morpheus/Execution/Client/Build.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}++module Data.Morpheus.Execution.Client.Build+  ( defineQuery+  ) where++import           Control.Lens                             (declareLenses)+import           Data.Aeson                               (ToJSON)+import           Data.Semigroup                           ((<>))+import           Language.Haskell.TH++--+-- MORPHEUS+import           Data.Morpheus.Error.Client.Client        (renderGQLErrors)+import           Data.Morpheus.Execution.Client.Aeson     (deriveFromJSON)+import           Data.Morpheus.Execution.Client.Compile   (validateWith)+import           Data.Morpheus.Execution.Client.Fetch     (deriveFetch)+import           Data.Morpheus.Execution.Internal.Declare (declareType)+import           Data.Morpheus.Types.Internal.Data        (DataTypeLib)+import           Data.Morpheus.Types.Internal.DataD       (QueryD (..), TypeD (..))+import           Data.Morpheus.Types.Internal.Validation  (Validation)+import           Data.Morpheus.Types.Types                (GQLQueryRoot (..))++queryArgumentType :: [TypeD] -> (Type, Q [Dec])+queryArgumentType [] = (ConT $ mkName "()", pure [])+queryArgumentType (rootType@TypeD {tName}:xs) = (ConT $ mkName tName, types)+  where+    types = pure $ map (declareType [''Show, ''ToJSON]) (rootType : xs)++defineJSONType :: TypeD -> Q [Dec]+defineJSONType datatype = do+  record <- declareLenses (pure [declareType [''Show] datatype])+  toJson <- pure <$> deriveFromJSON datatype+  pure $ record <> toJson++defineOperationType :: (Type, Q [Dec]) -> String -> TypeD -> Q [Dec]+defineOperationType (argType, argumentTypes) query datatype = do+  rootType <- defineJSONType datatype+  typeClassFetch <- deriveFetch argType (tName datatype) query+  args <- argumentTypes+  pure $ rootType <> typeClassFetch <> args++defineQueryD :: QueryD -> Q [Dec]+defineQueryD QueryD {queryTypes = rootType:subTypes, queryText, queryArgTypes} = do+  rootDecs <- defineOperationType (queryArgumentType queryArgTypes) queryText rootType+  subTypeDecs <- concat <$> mapM defineJSONType subTypes+  return $ rootDecs ++ subTypeDecs+defineQueryD QueryD {queryTypes = []} = return []++defineQuery :: IO (Validation DataTypeLib) -> (GQLQueryRoot, String) -> Q [Dec]+defineQuery ioSchema queryRoot = do+  schema <- runIO ioSchema+  case schema >>= (`validateWith` queryRoot) of+    Left errors  -> fail (renderGQLErrors errors)+    Right queryD -> defineQueryD queryD
+ src/Data/Morpheus/Execution/Client/Compile.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Execution.Client.Compile+  ( compileSyntax+  , validateWith+  ) where++import qualified Data.Text                                  as T (pack)+import           Language.Haskell.TH++import           Data.Morpheus.Error.Client.Client          (renderGQLErrors)++import           Data.Morpheus.Execution.Client.Selection   (operationTypes)+import           Data.Morpheus.Parsing.Request.Parser       (parseGQL)+import qualified Data.Morpheus.Types.Internal.AST.Operation as O (Operation (..))+import           Data.Morpheus.Types.Internal.Data          (DataTypeLib)+import           Data.Morpheus.Types.IO                     (GQLRequest (..))+--+--  Morpheus+import           Data.Morpheus.Types.Internal.DataD         (QueryD (..))+import           Data.Morpheus.Types.Internal.Validation    (Validation)+import           Data.Morpheus.Types.Types                  (GQLQueryRoot (..))+import           Data.Morpheus.Validation.Utils.Utils       (VALIDATION_MODE (..))+import           Data.Morpheus.Validation.Validation        (validateRequest)++compileSyntax :: String -> Q Exp+compileSyntax queryText =+  case parseGQL request of+    Left errors -> fail (renderGQLErrors errors)+    Right root  -> [|(root, queryText)|]+  where+    request = GQLRequest {query = T.pack queryText, operationName = Nothing, variables = Nothing}++validateWith :: DataTypeLib -> (GQLQueryRoot, String) -> Validation QueryD+validateWith schema (rawRequest@GQLQueryRoot {operation}, queryText) = do+  validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest+  (queryArgTypes, queryTypes) <- operationTypes schema (O.operationArgs operation) validOperation+  return QueryD {queryText, queryTypes, queryArgTypes}
+ src/Data/Morpheus/Execution/Client/Fetch.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE OverloadedStrings       #-}+{-# LANGUAGE QuasiQuotes             #-}+{-# LANGUAGE TemplateHaskell         #-}+{-# LANGUAGE TypeFamilies            #-}++module Data.Morpheus.Execution.Client.Fetch+  ( Fetch(..)+  , deriveFetch+  ) where++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 (..))++class Fetch a where+  type Args a :: *+  __fetch ::+       (Monad m, Show a, ToJSON (Args a), FromJSON a)+    => String+    -> String+    -> (ByteString -> m ByteString)+    -> Args a+    -> m (Either String a)+  __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+  where+    methods =+      [ funD (mkName "fetch") [clause [] (normalB [|__fetch query typeName|]) []]+      , pure $ TySynInstD ''Args (TySynEqn [ConT $ mkName typeName] argDatatype)+      ]
+ src/Data/Morpheus/Execution/Client/Selection.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}++module Data.Morpheus.Execution.Client.Selection+  ( operationTypes+  ) where++import           Data.Semigroup                             ((<>))+import           Data.Text                                  (Text, unpack)++--+-- MORPHEUS+import           Data.Morpheus.Error.Internal               (internalUnknownTypeMessage)+import           Data.Morpheus.Types.Internal.AST.Operation (Operation (..), ValidOperation, Variable (..),+                                                             VariableDefinitions)+import           Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..))+import           Data.Morpheus.Types.Internal.Data          (DataField (..), DataFullType (..), DataLeaf (..),+                                                             DataType (..), DataTypeLib (..), DataTypeWrapper,+                                                             allDataTypes)+import           Data.Morpheus.Types.Internal.DataD         (ConsD (..), FieldD (..), TypeD (..), gqlToHSWrappers)+import           Data.Morpheus.Types.Internal.Validation    (GQLErrors, Validation)+import           Data.Morpheus.Validation.Utils.Utils       (lookupType)++compileError :: Text -> GQLErrors+compileError x = internalUnknownTypeMessage $ " \"" <> x <> "\" ;"++operationTypes :: DataTypeLib -> VariableDefinitions -> ValidOperation -> Validation ([TypeD], [TypeD])+operationTypes lib variables = genOperation+  where+    queryDataType = OutputObject $ snd $ query lib+    -----------------------------------------------------+    typeByField :: Text -> DataFullType -> Validation DataFullType+    typeByField key datatype = fst <$> fieldDataType datatype key+    ------------------------------------------------------+    fieldDataType :: DataFullType -> Text -> Validation (DataFullType, [DataTypeWrapper])+    fieldDataType (OutputObject DataType {typeData}) key =+      case lookup key typeData of+        Just DataField {fieldTypeWrappers, fieldType} -> trans <$> getType lib fieldType+          where trans x = (x, fieldTypeWrappers)+        Nothing -> Left (compileError key)+    fieldDataType _ key = Left (compileError key)+    -----------------------------------------------------+    genOperation Operation {operationName, operationSelection} = do+      argTypes <- rootArguments (operationName <> "Args")+      queryTypes <- genRecordType operationName queryDataType operationSelection+      pure (argTypes, queryTypes)+    -------------------------------------------{--}+    genInputType :: Text -> Validation [TypeD]+    genInputType name = getType lib name >>= subTypes+      where+        subTypes (InputObject DataType {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+            ----------------------------------------------------------------+            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)+        subTypes (Leaf x) = buildLeaf x+        subTypes _ = pure []+    -------------------------------------------+    rootArguments :: Text -> Validation [TypeD]+    rootArguments name = do+      types <- concat <$> mapM (genInputType . variableType . snd) variables+      pure $ typeD : types+      where+        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)+    -------------------------------------------+    getCon name dataType selectionSet = do+      cFields <- genFields dataType selectionSet+      subTypes <- newFieldTypes dataType selectionSet+      pure (ConsD {cName = unpack name, cFields}, subTypes)+      ---------------------------------------------------------------------------------------------+      where+        genFields datatype = mapM typeNameFromField+          where+            typeNameFromField :: (Text, Selection) -> Validation FieldD+            typeNameFromField (key, _) = FieldD (unpack key) <$> wrType+              where+                wrType = do+                  (newType, wrappers) <- fieldDataType datatype key+                  pure $ gqlToHSWrappers wrappers (unpack $ typeFrom newType)+    --------------------------------------------+    genRecordType name dataType selectionSet = do+      (con, subTypes) <- getCon name dataType selectionSet+      pure $ TypeD {tName = unpack name, tCons = [con]} : subTypes+    ------------------------------------------------------------------------------------------------------------+    newFieldTypes parentType = fmap concat <$> mapM validateSelection+      where+        validateSelection :: (Text, Selection) -> Validation [TypeD]+        validateSelection (key, Selection {selectionRec = SelectionSet selectionSet}) = do+          datatype <- key `typeByField` parentType+          genRecordType (typeFrom datatype) datatype selectionSet+        validateSelection (key, Selection {selectionRec = SelectionField}) =+          key `typeByField` parentType >>= buildSelField+          where+            buildSelField (Leaf x) = buildLeaf x+            buildSelField _        = Left $ compileError "Invalid schema Expected scalar"+        validateSelection (key, Selection {selectionRec = UnionSelection unionSelections}) = do+          unionTypeName <- typeFrom <$> key `typeByField` parentType+          (tCons, subTypes) <- unzip <$> mapM getUnionType unionSelections+          pure $ TypeD {tName = unpack unionTypeName, tCons} : concat subTypes+          where+            getUnionType (typeKey, selSet) = do+              conDatatype <- getType lib typeKey+              getCon typeKey conDatatype selSet+        validateSelection _ = pure []++buildLeaf :: DataLeaf -> Validation [TypeD]+buildLeaf (LeafEnum DataType {typeName, typeData}) =+  pure [TypeD {tName = unpack typeName, tCons = map enumOption typeData}]+  where+    enumOption name = ConsD {cName = unpack name, cFields = []}+buildLeaf _ = pure []++getType :: DataTypeLib -> Text -> Validation DataFullType+getType lib typename = lookupType (compileError typename) (allDataTypes lib) typename++isPrimitive :: Text -> Bool+isPrimitive "Boolean" = True+isPrimitive "Int"     = True+isPrimitive "Float"   = True+isPrimitive "String"  = True+isPrimitive "ID"      = True+isPrimitive _         = False++typeFrom :: DataFullType -> Text+typeFrom (Leaf (BaseScalar x)) = typeName x+typeFrom (Leaf (CustomScalar DataType {typeName}))+  | isPrimitive typeName = typeName+  | otherwise = "ScalarValue"+typeFrom (Leaf (LeafEnum x)) = typeName x+typeFrom (InputObject x) = typeName x+typeFrom (OutputObject x) = typeName x+typeFrom (Union x) = typeName x+typeFrom (InputUnion x) = typeName x
+ src/Data/Morpheus/Execution/Document/Compile.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Execution.Document.Compile+  ( compileExp+  , compileDec+  ) where++import qualified Data.Text                                as T (pack)+import           Language.Haskell.TH++--+--  Morpheus+import           Data.Morpheus.Error.Client.Client        (renderGQLErrors)+import           Data.Morpheus.Execution.Document.Convert (renderTHTypes)+import           Data.Morpheus.Execution.Document.Declare (declareTypes)+import           Data.Morpheus.Parsing.Document.Parser    (parseTypes)++compileExp :: String -> Q Exp+compileExp documentTXT =+  case parseTypes (T.pack documentTXT) >>= renderTHTypes of+    Left errors -> fail (renderGQLErrors errors)+    Right root  -> [|root|]++compileDec :: String -> Q [Dec]+compileDec documentTXT =+  case parseTypes (T.pack documentTXT) >>= renderTHTypes of+    Left errors -> fail (renderGQLErrors errors)+    Right root  -> declareTypes root
+ src/Data/Morpheus/Execution/Document/Convert.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}++module Data.Morpheus.Execution.Document.Convert+  ( renderTHTypes+  ) where++import           Data.Semigroup                          ((<>))+import           Data.Text                               (Text, 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.Validation (Validation)++renderTHTypes :: [(Text, DataFullType)] -> Validation [GQLTypeD]+renderTHTypes = traverse renderTHType++renderTHType :: (Text, DataFullType) -> Validation GQLTypeD+renderTHType (_, x) = genType x+  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, [])+      where+        unionCon DataField {fieldType} =+          ConsD {cName, cFields = [FieldD {fieldNameD = "un" <> cName, fieldTypeD = BaseD utName}]}+          where+            cName = unpack typeName <> utName+            utName = unpack fieldType+    ------------------------------------------------------------------------------------------------------------
+ src/Data/Morpheus/Execution/Document/Declare.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Execution.Document.Declare+  ( declareTypes+  ) where++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)++declareTypes :: [GQLTypeD] -> Q [Dec]+declareTypes = fmap concat . traverse declareGQLType++declareGQLType :: GQLTypeD -> Q [Dec]+declareGQLType gqlType@(typeD, _, argTypes) = do+  let types = map (declareType []) (typeD : argTypes)+  typeClasses <- deriveGQLType gqlType+  pure $ types <> typeClasses
+ src/Data/Morpheus/Execution/Document/GQLType.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TemplateHaskell   #-}++module Data.Morpheus.Execution.Document.GQLType+  ( deriveGQLType+  ) where++import           Language.Haskell.TH++import           Data.Morpheus.Kind                 (ENUM, INPUT_OBJECT, INPUT_UNION, OBJECT, SCALAR, UNION, WRAPPER)++--+-- MORPHEUS+import           Data.Morpheus.Types.GQLType        (GQLType (..))+import           Data.Morpheus.Types.Internal.Data  (DataTypeKind (..))+import           Data.Morpheus.Types.Internal.DataD (GQLTypeD, TypeD (..))++deriveGQLType :: GQLTypeD -> Q [Dec]+deriveGQLType (TypeD {tName}, gqlKind, _) =+  pure <$> instanceD (cxt []) (appT (conT ''GQLType) (conT $ mkName tName)) methods+  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
+ src/Data/Morpheus/Execution/Internal/Declare.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeApplications      #-}++module Data.Morpheus.Execution.Internal.Declare+  ( declareType+  ) where++import           Language.Haskell.TH++--+-- MORPHEUS+import           Data.Morpheus.Types.Internal.DataD (AppD (..), ConsD (..), FieldD (..), TypeD (..))+import           GHC.Generics                       (Generic)++type FUNC = (->)++--+--+declareType :: [Name] -> TypeD -> Dec+declareType derivingList TypeD {tName, tCons} =+  DataD [] (mkName tName) [] Nothing (map cons tCons) $ map derive (''Generic : derivingList)+  where+    defBang = Bang NoSourceUnpackedness NoSourceStrictness+    derive className = DerivClause Nothing [ConT className]+    cons ConsD {cName, cFields} = RecC (mkName cName) (map genField cFields)+      where+        genField FieldD {fieldNameD, fieldTypeD} = (mkName fieldNameD, defBang, genFieldT fieldTypeD)+          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+              where+                argType = ConT $ mkName arg+                arrowType = ConT ''FUNC+                resultType = AppT (ConT $ mkName mon) (genFieldT td)
+ src/Data/Morpheus/Execution/Internal/Utils.hs view
@@ -0,0 +1,19 @@+module Data.Morpheus.Execution.Internal.Utils+  ( capital+  , nonCapital+  , nameSpaceWith+  ) where++import           Data.Char      (toLower, toUpper)+import           Data.Semigroup ((<>))++nameSpaceWith :: String -> String -> String+nameSpaceWith nSpace name = nonCapital nSpace <> capital name++nonCapital :: String -> String+nonCapital []     = []+nonCapital (x:xs) = toLower x : xs++capital :: String -> String+capital []     = []+capital (x:xs) = toUpper x : xs
+ src/Data/Morpheus/Execution/Server/Decode.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++module Data.Morpheus.Execution.Server.Decode+  ( ArgumentsConstraint+  , decodeArguments+  ) where++import           Data.Proxy                                      (Proxy (..))+import           Data.Semigroup                                  ((<>))+import           Data.Text                                       (Text, pack)+import           GHC.Generics++-- MORPHEUS+import           Data.Morpheus.Error.Internal                    (internalArgumentError, internalTypeMismatch)+import           Data.Morpheus.Execution.Server.Generics.EnumRep (EnumRep (..))+import           Data.Morpheus.Kind                              (ENUM, GQL_KIND, INPUT_OBJECT, INPUT_UNION, SCALAR,+                                                                  WRAPPER)+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.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++instance DecodeInputObject f => DecodeInputObject (M1 C c f) where+  decodeObject = fmap M1 . decodeObject++instance (DecodeInputObject f, DecodeInputObject g) =>+         DecodeInputObject (f :*: g) where+  decodeObject gql = (:*:) <$> decodeObject gql <*> decodeObject gql++instance (Decode a (KIND a)) => DecodeInputObject (K1 i a) where+  decodeObject = fmap K1 . decode++decode ::+     forall a. Decode a (KIND a)+  => Value+  -> Validation a+decode = __decode (Proxy @(KIND a))++-- | Decode GraphQL query arguments and input values+class Decode a (b :: GQL_KIND) where+  __decode :: Proxy b -> Value -> Validation a++--+-- SCALAR+--+instance (GQLScalar a) => Decode a SCALAR where+  __decode _ 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++--+-- 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++--+-- 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++--+-- WRAPPERS: Maybe, List+--+instance Decode a (KIND a) => Decode (Maybe a) WRAPPER where+  __decode _ Null = pure Nothing+  __decode _ x    = Just <$> decode x++instance Decode a (KIND a) => Decode [a] WRAPPER where+  __decode _ (List li) = mapM decode li+  __decode _ isType    = internalTypeMismatch "List" isType
+ src/Data/Morpheus/Execution/Server/Encode.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++module Data.Morpheus.Execution.Server.Encode+  ( EncodeCon+  , EncodeMutCon+  , EncodeSubCon+  , encodeQuery+  , encodeMut+  , encodeSub+  ) where++import           Control.Monad                                   ((>=>))+import           Control.Monad.Trans.Except+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           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.Execution.Server.Generics.EnumRep (EnumRep (..))+import           Data.Morpheus.Kind                              (ENUM, GQL_KIND, OBJECT, SCALAR, UNION, WRAPPER)+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.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.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))++type EncodeMutCon m event con mut+   = EncodeCon (PublishStream m event con) mut Value++type EncodeSubCon m event con sub+   = EncodeCon (SubscribeStream m event) sub (Event event con -> ResolveT m Value)++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))++encodeMut :: (Monad m, EncodeCon m a Value) => EncodeOperator m a Value+encodeMut = encodeOperator resolveBySelection++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++---------------------------------------------------------+--+--  OBJECT+-- | Derives resolvers by object fields+class ObjectFieldResolvers f o where+  objectFieldResolvers :: f a -> [(Text, (Text, Selection) -> o)]++instance ObjectFieldResolvers U1 res where+  objectFieldResolvers _ = []++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)]++instance ObjectFieldResolvers f res => ObjectFieldResolvers (M1 D c f) res where+  objectFieldResolvers (M1 src) = objectFieldResolvers src++instance ObjectFieldResolvers f res => ObjectFieldResolvers (M1 C c f) res where+  objectFieldResolvers (M1 src) = objectFieldResolvers src++instance (ObjectFieldResolvers f res, ObjectFieldResolvers g res) =>+         ObjectFieldResolvers (f :*: g) res where+  objectFieldResolvers (a :*: b) =+    objectFieldResolvers a ++ objectFieldResolvers b++--+-- UNION+--+class UnionResolvers f result where+  unionResolvers :: f a -> (Text, (Text, Selection) -> result)++instance UnionResolvers f res => UnionResolvers (M1 S s f) res where+  unionResolvers (M1 x) = unionResolvers x++instance UnionResolvers f res => UnionResolvers (M1 D c f) res where+  unionResolvers (M1 x) = unionResolvers x++instance UnionResolvers f res => UnionResolvers (M1 C c f) res where+  unionResolvers (M1 x) = unionResolvers x++instance (UnionResolvers a res, UnionResolvers b res) =>+         UnionResolvers (a :+: b) res where+  unionResolvers (L1 x) = unionResolvers x+  unionResolvers (R1 x) = unionResolvers x++type ObjectConstraint a m+   = ( Monad m+     , Generic a+     , GQLType a+     , ObjectFieldResolvers (Rep a) (ResolveT m Value))++type UnionConstraint a m+   = (Monad m, Generic a, GQLType a, UnionResolvers (Rep a) (ResolveT m Value))++type EnumConstraint a = (Generic a, EnumRep (Rep a))++newtype WithGQLKind a (b :: GQL_KIND) =+  WithGQLKind+    { resolverValue :: a+    }++type GQLKindOf a = WithGQLKind a (KIND a)++encode ::+     forall a result. Encoder a (KIND a) result+  => a+  -> (Text, Selection)+  -> result+encode resolver = __encode (WithGQLKind resolver :: GQLKindOf a)++class Encoder a kind result where+  __encode :: WithGQLKind a kind -> (Text, Selection) -> result++type ResValue m = (ResolveT m Value)++--+-- SCALAR+--+instance (GQLScalar a, Monad m) => Encoder a SCALAR (ResValue m) where+  __encode = pure . pure . Scalar . serialize . resolverValue++--+-- ENUM+--+instance (EnumConstraint a, Monad m) => Encoder a ENUM (ResValue m) where+  __encode = pure . pure . Scalar . String . encodeRep . from . resolverValue++--+--  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++-- | 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"++instance (GQLType a, Encoder a (KIND a) result) =>+         UnionResolvers (K1 s a) result where+  unionResolvers (K1 src) = (__typeName (Proxy @a), encode src)++--+--  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++-- 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)++-- 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 (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)++--+-- 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++--+-- 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])++--+--  Tuple+--+instance Encoder (Pair k v) OBJECT (ResValue m) =>+         Encoder (k, v) WRAPPER (ResValue m) where+  __encode (WithGQLKind (key, value)) = encode (Pair key value)++--+--  Set+--+instance Encoder [a] WRAPPER result => Encoder (Set a) WRAPPER result where+  __encode (WithGQLKind dataSet) = encode (S.toList dataSet)++--+--  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))++----- HELPERS ----------------------------+type ResolveSel result+   = SelectionSet -> [(Text, (Text, Selection) -> result)] -> result++resolverToResolveT ::+     Monad m => Position -> Text -> Resolver m a -> ResolveT m a+resolverToResolveT pos name = ExceptT . toResolveM+  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++encodeResolver ::+     (Monad m, Encoder a (KIND a) (ResValue m))+  => (Text, Selection)+  -> Resolver m a+  -> ResValue m+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++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)+  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+--------------------------------------------
+ src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Data.Morpheus.Execution.Server.Generics.EnumRep+  ( EnumRep(..)+  ) where++import           Data.Proxy                              (Proxy (..))+import           Data.Semigroup                          ((<>))+import           Data.Text                               (Text, pack)+import           GHC.Generics++-- MORPHEUS+import           Data.Morpheus.Error.Internal            (internalError)+import           Data.Morpheus.Types.Internal.Validation (Validation)++class EnumRep f where+  encodeRep :: f a -> Text+  decodeEnum :: Text -> Validation (f a)+  enumTags :: Proxy f -> [Text]++instance (Datatype c, EnumRep f) => EnumRep (M1 D c f) where+  encodeRep (M1 src) = encodeRep src+  decodeEnum = fmap M1 . decodeEnum+  enumTags _ = enumTags (Proxy @f)++instance (Constructor c) => EnumRep (M1 C c U1) where+  encodeRep m@(M1 _) = pack $ conName m+  decodeEnum _ = pure $ M1 U1+  enumTags _ = [pack $ conName (undefined :: (M1 C c U1 x))]++instance (EnumRep a, EnumRep b) => EnumRep (a :+: b) where+  encodeRep (L1 x) = encodeRep x+  encodeRep (R1 x) = encodeRep x+  decodeEnum name+    | name `elem` enumTags (Proxy @a) = L1 <$> decodeEnum name+    | name `elem` enumTags (Proxy @b) = R1 <$> decodeEnum name+    | otherwise =+      internalError ("Constructor \"" <> name <> "\" could not find in Union")+  enumTags _ = enumTags (Proxy @a) ++ enumTags (Proxy @b)
+ src/Data/Morpheus/Execution/Server/Interpreter.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}++module Data.Morpheus.Execution.Server.Interpreter+  ( Interpreter(..)+  ) where++import           Data.Aeson                                          (encode)+import           Data.ByteString                                     (ByteString)+import qualified Data.ByteString.Lazy.Char8                          as LB (ByteString, fromStrict, toStrict)+import           Data.Text                                           (Text)+import qualified Data.Text.Lazy                                      as LT (Text, fromStrict, toStrict)+import           Data.Text.Lazy.Encoding                             (decodeUtf8, encodeUtf8)++-- MORPHEUS+import           Data.Morpheus.Execution.Server.Resolve              (RootResCon, byteStringIO, statefulResolver,+                                                                      statelessResolver, streamResolver)+import           Data.Morpheus.Execution.Subscription.ClientRegister (GQLState)+import           Data.Morpheus.Types.Internal.Stream                 (ResponseStream)+import           Data.Morpheus.Types.IO                              (GQLRequest, GQLResponse)+import           Data.Morpheus.Types.Resolver                        (GQLRootResolver (..))++-- | main query processor and resolver+--  possible versions of interpreter+--+-- 1. with effect and state: where 'GQLState' is State Monad of subscriptions+--+--     @+--      k :: GQLState -> a -> IO a+--     @+--+-- 2. without effect and state: stateless query processor without any effect,+--    if you don't need any subscription use this one , is simple and fast+--+--     @+--       k :: a -> IO a+--       -- or+--       k :: GQLRequest -> IO GQLResponse+--     @+class Interpreter k m e c where+  interpreter ::+       Monad m+    => (RootResCon m e c que mut sub) =>+         GQLRootResolver m e c que mut sub -> k++{-+  simple HTTP stateless Interpreter without side effects+-}+type StateLess m a = a -> m a++instance Interpreter (GQLRequest -> m GQLResponse) m e c where+  interpreter = statelessResolver++instance Interpreter (StateLess m LB.ByteString) m e c where+  interpreter root = byteStringIO (statelessResolver root)++instance Interpreter (StateLess m LT.Text) m e c where+  interpreter root request =+    decodeUtf8 <$> interpreter root (encodeUtf8 request)++instance Interpreter (StateLess m ByteString) m e c where+  interpreter root request =+    LB.toStrict <$> interpreter root (LB.fromStrict request)++instance Interpreter (StateLess m Text) m e c where+  interpreter root request =+    LT.toStrict <$> interpreter root (LT.fromStrict request)++{-+   HTTP Interpreter with state and side effects, every mutation will+   trigger subscriptions in  shared `GQLState`+-}+type WSPub m e c a = GQLState m e c -> a -> m a++instance Interpreter (WSPub IO e c LB.ByteString) IO e c where+  interpreter root state =+    statefulResolver state (byteStringIO (streamResolver root))++instance Interpreter (WSPub IO e c LT.Text) IO e c where+  interpreter root state request =+    decodeUtf8 <$> interpreter root state (encodeUtf8 request)++instance Interpreter (WSPub IO e c ByteString) IO e c where+  interpreter root state request =+    LB.toStrict <$> interpreter root state (LB.fromStrict request)++instance Interpreter (WSPub IO e c Text) IO e c where+  interpreter root state request =+    LT.toStrict <$> interpreter root state (LT.fromStrict request)++{-+   WebSocket Interpreter without state and side effects, mutations and subscription will return Actions+   that will be executed in WebSocket server+-}+type WSSub m e c a = a -> ResponseStream m e c a++instance Interpreter (GQLRequest -> ResponseStream m e c LB.ByteString) m e c where+  interpreter root request = encode <$> streamResolver root request++instance Interpreter (WSSub m e c LB.ByteString) m e c where+  interpreter root = byteStringIO (streamResolver root)++instance Interpreter (WSSub m e c LT.Text) m e c where+  interpreter root request =+    decodeUtf8 <$> interpreter root (encodeUtf8 request)++instance Interpreter (WSSub m e c ByteString) m e c where+  interpreter root request =+    LB.toStrict <$> interpreter root (LB.fromStrict request)++instance Interpreter (WSSub m e c Text) m e c where+  interpreter root request =+    LT.toStrict <$> interpreter root (LT.fromStrict request)
+ src/Data/Morpheus/Execution/Server/Introspect.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++module Data.Morpheus.Execution.Server.Introspect+  ( introspectOutputType+  , TypeUpdater+  , ObjectRep(..)+  , resolveTypes+  ) where++import           Control.Monad                                   (foldM)+import           Data.Function                                   ((&))+import           Data.Map                                        (Map)+import           Data.Proxy                                      (Proxy (..))+import           Data.Semigroup                                  ((<>))+import           Data.Set                                        (Set)+import           Data.Text                                       (Text, pack)+import           GHC.Generics++-- 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.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)+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 InputOf t = Context t (KIND t) InputType++type OutputOf t = Context t (KIND t) OutputType++introspectOutputType ::+     forall a. Introspect a (KIND a) OutputType+  => Proxy a+  -> TypeUpdater+introspectOutputType _ = introspect (Context :: OutputOf 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++buildField :: GQLType a => Proxy a -> t -> Text -> DataField t+buildField proxy fieldArgs fieldName =+  DataField+    { fieldName+    , fieldArgs+    , fieldTypeWrappers = [NonNullType]+    , fieldType = __typeName proxy+    , fieldHidden = False+    }++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+    }++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)++-- |   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++type OutputConstraint a = Introspect a (KIND a) DataArguments++--+-- 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)++--+-- 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)++--+-- OBJECTS , INPUT_OBJECT+--+instance InputObjectConstraint a => Introspect a INPUT_OBJECT InputType where+  __field _ = buildField (Proxy @a) ()+  introspect _ = updateLib (InputObject . buildType fields') stack' (Proxy @a)+    where+      (fields', stack') = unzip $ objectFieldTypes (Proxy @(Rep a))++instance ObjectConstraint a => Introspect a OBJECT OutputType where+  __field _ = buildField (Proxy @a) []+  introspect _ =+    updateLib+      (OutputObject . buildType (__typename : fields'))+      stack'+      (Proxy @a)+    where+      __typename =+        ( "__typename"+        , DataField+            { fieldName = "__typename"+            , fieldArgs = []+            , fieldTypeWrappers = []+            , fieldType = "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)++--+-- 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)+    where+      (fields, stack) =+        unzip $ possibleTypes (Proxy @(Rep a)) (Proxy @OutputType)++--+-- 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)+    where+      (fields, stack) =+        unzip $ possibleTypes (Proxy @(Rep a)) (Proxy @InputType)+      -- for every input Union 'User' adds enum type of possible TypeNames 'UserTags'+      tagsEnumType :: TypeUpdater+      tagsEnumType x =+        pure $ defineType (enumTypeName, Leaf $ LeafEnum tagsEnum) x+        where+          tagsEnum =+            DataType+              { typeName = enumTypeName+              -- has same fingerprint as object because it depends on it+              , typeFingerprint = __typeFingerprint (Proxy @a)+              , typeVisibility = __typeVisibility (Proxy @a)+              , typeDescription = ""+              , typeData = map fieldName fields+              }+      enumTypeName = __typeName (Proxy @a) <> "Tags"+      fieldTag =+        DataField+          { fieldName = "tag"+          , fieldArgs = ()+          , fieldTypeWrappers = [NonNullType]+          , fieldType = enumTypeName+          , fieldHidden = False+          }++--+-- WRAPPER : Maybe, LIST , Resolver+--+maybeField :: DataField f -> DataField f+maybeField field@DataField {fieldTypeWrappers = NonNullType:xs} =+  field {fieldTypeWrappers = xs}+maybeField field = field++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)++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)++--+-- 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 Introspect [a] WRAPPER f => Introspect (Set a) WRAPPER f where+  __field _ = __field (Context :: Context [a] WRAPPER f)+  introspect _ = introspect (Context :: Context [a] WRAPPER f)++-- | introspection Does not care about resolving monad, some fake monad just for mocking+type MockRes = (Resolver Maybe)++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)++-- |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))++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 (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)]+    where+      args :: [((Text, DataInputField), TypeUpdater)]+      args = objectFieldTypes (Proxy @(Rep a))
+ src/Data/Morpheus/Execution/Server/Resolve.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Morpheus.Execution.Server.Resolve+  ( statelessResolver+  , byteStringIO+  , streamResolver+  , statefulResolver+  , RootResCon+  , fullSchema+  ) where++import qualified Codec.Binary.UTF8.String                            as UTF8+import           Control.Monad.Trans.Except                          (ExceptT (..), runExceptT)+import           Data.Aeson                                          (Result (..), encode, fromJSON)+import           Data.Aeson.Parser                                   (jsonNoDup)+import           Data.Attoparsec.ByteString                          (parseOnly)+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++-- 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.Subscription.ClientRegister (GQLState, publishUpdates)+import           Data.Morpheus.Parsing.Request.Parser                (parseGQL)+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.Internal.Stream                 (Event (..), ResponseEvent (..), ResponseStream,+                                                                      StreamState (..), StreamT (..), closeStream, mapS)+import           Data.Morpheus.Types.Internal.Validation             (SchemaValidation)+import           Data.Morpheus.Types.Internal.Value                  (Value (..))+import           Data.Morpheus.Types.IO                              (GQLRequest (..), GQLResponse (..))+import           Data.Morpheus.Types.Resolver                        (GQLRootResolver (..))+import           Data.Morpheus.Validation.Utils.Utils                (VALIDATION_MODE (..))+import           Data.Morpheus.Validation.Validation                 (validateRequest)++type EventCon event = Eq event++type IntroCon a = (Generic a, ObjectRep (Rep a) DataArguments)++type RootResCon m event cont query mutation subscription+   = ( EventCon event+      -- Introspection+     , IntroCon query+     , IntroCon mutation+     , IntroCon subscription+     -- Resolving+     , EncodeCon m query Value+     , EncodeMutCon m event cont mutation+     , EncodeSubCon m event cont subscription)++decodeNoDup :: L.ByteString -> Result GQLRequest+decodeNoDup bs =+  case parseOnly jsonNoDup (S.pack . UTF8.encode $ L.unpack bs) of+    Left e  -> Error e+    Right v -> fromJSON v++byteStringIO :: Monad m => (GQLRequest -> m GQLResponse) -> L.ByteString -> m L.ByteString+byteStringIO resolver request =+  case decodeNoDup request of+    Error aesonError' -> return $ badRequestError aesonError'+    Success req       -> encode <$> resolver req++statelessResolver ::+     (Monad m, RootResCon m s cont query mut sub)+  => GQLRootResolver m s cont query mut sub+  -> GQLRequest+  -> m GQLResponse+statelessResolver root = fmap snd . closeStream . streamResolver root++streamResolver ::+     (Monad m, RootResCon m s cont query mut sub)+  => GQLRootResolver m s cont query mut sub+  -> GQLRequest+  -> ResponseStream m s cont GQLResponse+streamResolver root@GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver} request =+  renderResponse <$> runExceptT (ExceptT (pure validRequest) >>= ExceptT . 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)+    ----------------------------------------------------------+    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)+      where+        handleActions (_, Left gqlError) = StreamState [] (Left gqlError)+        handleActions (channels, Right subResolver) =+          StreamState [Subscribe $ Event (concat channels) handleRes] (Right Null)+          where+            handleRes event = renderResponse <$> runExceptT (subResolver event)++statefulResolver ::+     EventCon s+  => GQLState IO s cont+  -> (L.ByteString -> ResponseStream IO s cont L.ByteString)+  -> L.ByteString+  -> IO L.ByteString+statefulResolver state streamApi request = do+  (actions, value) <- closeStream (streamApi request)+  mapM_ execute actions+  pure value+  where+    execute (Publish updates) = publishUpdates state updates+    execute Subscribe {}      = pure ()++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+fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema+  where+    querySchema = resolveTypes (initTypeLib (operatorType (hiddenRootFields ++ fields) "Query")) (defaultTypes : types)+      where+        (fields, types) = unzip $ objectFieldTypes (Proxy :: Proxy (Rep query))+    ------------------------------+    mutationSchema lib = resolveTypes (lib {mutation = maybeOperator fields "Mutation"}) types+      where+        (fields, types) = unzip $ objectFieldTypes (Proxy :: Proxy (Rep 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])+    maybeOperator []     = const Nothing+    maybeOperator fields = Just . operatorType fields+    -- operatorType :: [a] -> Text -> (Text, DataType [a])+    operatorType typeData typeName =+      ( typeName+      , DataType+          { typeData+          , typeVisibility = True+          , typeName+          , typeFingerprint = SystemFingerprint typeName+          , typeDescription = ""+          })
+ src/Data/Morpheus/Execution/Subscription/Apollo.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Execution.Subscription.Apollo+  ( SubAction(..)+  , apolloFormat+  , acceptApolloSubProtocol+  , toApolloResponse+  ) where++import           Data.Aeson                 (FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, pairs,+                                             withObject, (.:), (.:?), (.=))+import           Data.ByteString.Lazy.Char8 (ByteString)+import           Data.Morpheus.Types        (GQLRequest (..))+import           Data.Morpheus.Types.IO     (GQLResponse)+import           Data.Semigroup             ((<>))+import           Data.Text                  (Text)+import           GHC.Generics               (Generic)+import           Network.WebSockets         (AcceptRequest (..), RequestHead, getRequestSubprotocols)++type ApolloID = Text++data ApolloSubscription payload =+  ApolloSubscription+    { apolloId      :: Maybe ApolloID+    , apolloType    :: Text+    , apolloPayload :: Maybe payload+    }+  deriving (Show, Generic)++instance FromJSON a => FromJSON (ApolloSubscription a) where+  parseJSON = withObject "ApolloSubscription" objectParser+    where+      objectParser o =+        ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload"++data RequestPayload =+  RequestPayload+    { payloadOperationName :: Maybe Text+    , payloadQuery         :: Maybe Text+    , payloadVariables     :: Maybe Value+    }+  deriving (Show, Generic)++instance FromJSON RequestPayload where+  parseJSON = withObject "ApolloPayload" objectParser+    where+      objectParser o =+        RequestPayload <$> o .:? "operationName" <*> o .:? "query" <*>+        o .:? "variables"++instance ToJSON a => ToJSON (ApolloSubscription a) where+  toEncoding (ApolloSubscription id' type' payload') =+    pairs $ "id" .= id' <> "type" .= type' <> "payload" .= payload'++acceptApolloSubProtocol :: RequestHead -> AcceptRequest+acceptApolloSubProtocol reqHead =+  apolloProtocol (getRequestSubprotocols reqHead)+  where+    apolloProtocol ["graphql-subscriptions"] =+      AcceptRequest (Just "graphql-subscriptions") []+    apolloProtocol ["graphql-ws"] = AcceptRequest (Just "graphql-ws") []+    apolloProtocol _ = AcceptRequest Nothing []++toApolloResponse :: ApolloID -> GQLResponse -> ByteString+toApolloResponse sid val =+  encode $ ApolloSubscription (Just sid) "data" (Just val)++data SubAction+  = RemoveSub ApolloID+  | AddSub ApolloID GQLRequest+  | SubError String++apolloFormat :: ByteString -> SubAction+apolloFormat = toWsAPI . eitherDecode+  where+    toWsAPI :: Either String (ApolloSubscription RequestPayload) -> SubAction+    toWsAPI (Right ApolloSubscription { apolloType = "start"+                                      , apolloId = Just sessionId+                                      , apolloPayload = Just RequestPayload { payloadQuery = Just query+                                                                            , payloadOperationName = operationName+                                                                            , payloadVariables = variables+                                                                            }+                                      }) =+      AddSub sessionId (GQLRequest {query, operationName, variables})+    toWsAPI (Right ApolloSubscription { apolloType = "stop"+                                      , apolloId = Just sessionId+                                      }) = RemoveSub sessionId+    toWsAPI (Right x) = SubError (show x)+    toWsAPI (Left x) = SubError x
+ src/Data/Morpheus/Execution/Subscription/ClientRegister.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Execution.Subscription.ClientRegister+  ( ClientRegister+  , GQLState+  , initGQLState+  , connectClient+  , disconnectClient+  , updateClientByID+  , publishUpdates+  , addClientSubscription+  , removeClientSubscription+  ) where++import           Control.Concurrent                          (MVar, modifyMVar, modifyMVar_, newMVar, readMVar)+import           Data.Foldable                               (traverse_)+import           Data.List                                   (intersect)+import           Data.Text                                   (Text)+import           Data.UUID.V4                                (nextRandom)+import           Network.WebSockets                          (Connection, sendTextData)++-- MORPHEUS+import           Data.Morpheus.Execution.Subscription.Apollo (toApolloResponse)+import           Data.Morpheus.Types.Internal.Stream         (Event (..), PubEvent, SubEvent)+import           Data.Morpheus.Types.Internal.WebSocket      (ClientID, ClientSession (..), GQLClient (..))++type ClientRegister m e c = [(ClientID, GQLClient m e c)]++-- | shared GraphQL state between __websocket__ and __http__ server,+-- stores information about subscriptions+type GQLState m e c = MVar (ClientRegister m e c) -- SharedState++-- | initializes empty GraphQL state+initGQLState :: IO (GQLState m e c)+initGQLState = newMVar []++connectClient :: Connection -> GQLState m e c -> IO (GQLClient m e c)+connectClient clientConnection varState' = do+  client' <- newClient+  modifyMVar_ varState' (addClient client')+  return (snd client')+  where+    newClient = do+      clientID <- nextRandom+      return+        (clientID, GQLClient {clientID, clientConnection, clientSessions = []})+    addClient client' state' = return (client' : state')++disconnectClient ::+     GQLClient m e c -> GQLState m e c -> IO (ClientRegister m e c)+disconnectClient client state = modifyMVar state removeUser+  where+    removeUser state' =+      let s' = removeClient state'+       in return (s', s')+    removeClient :: ClientRegister m e c -> ClientRegister m e c+    removeClient = filter ((/= clientID client) . fst)++updateClientByID ::+     ClientID+  -> (GQLClient m e c -> GQLClient m e c)+  -> MVar (ClientRegister m e c)+  -> IO ()+updateClientByID id' updateFunc state =+  modifyMVar_ state (return . map updateClient)+  where+    updateClient (key', client')+      | key' == id' = (key', updateFunc client')+    updateClient state' = state'++publishUpdates :: (Eq e) => GQLState IO e c -> PubEvent e c -> IO ()+publishUpdates state event = do+  state' <- readMVar state+  traverse_ sendMessage state'+  where+    sendMessage (_, GQLClient {clientSessions = []}) = return ()+    sendMessage (_, GQLClient {clientSessions, clientConnection}) =+      mapM_ __send (filterByChannels clientSessions)+      where+        __send ClientSession { sessionId+                             , sessionSubscription = Event {content = subscriptionRes}+                             } =+          subscriptionRes event >>=+          sendTextData clientConnection . toApolloResponse sessionId+        filterByChannels =+          filter+            (([] /=) .+             intersect (channels event) . channels . sessionSubscription)++removeClientSubscription :: ClientID -> Text -> GQLState m e c -> IO ()+removeClientSubscription id' sid' = updateClientByID id' stopSubscription+  where+    stopSubscription client' =+      client'+        { clientSessions =+            filter ((sid' /=) . sessionId) (clientSessions client')+        }++addClientSubscription ::+     ClientID -> SubEvent m e c -> Text -> GQLState m e c -> IO ()+addClientSubscription id' sessionSubscription sessionId =+  updateClientByID id' startSubscription+  where+    startSubscription client' =+      client'+        { clientSessions =+            ClientSession {sessionId, sessionSubscription} :+            clientSessions client'+        }
− src/Data/Morpheus/Interpreter.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes            #-}--module Data.Morpheus.Interpreter-  ( Interpreter(..)-  ) where--import           Data.Aeson                             (encode)-import           Data.ByteString                        (ByteString)-import qualified Data.ByteString.Lazy.Char8             as LB (ByteString, fromStrict, toStrict)-import           Data.Morpheus.Resolve.Operator         (RootResCon)-import           Data.Morpheus.Resolve.Resolve          (packStream, resolve, resolveByteString, resolveStream,-                                                         resolveStreamByteString)-import           Data.Morpheus.Server.ClientRegister    (GQLState)-import           Data.Morpheus.Types.Internal.WebSocket (OutputAction)-import           Data.Morpheus.Types.IO                 (GQLRequest, GQLResponse)-import           Data.Morpheus.Types.Resolver           (GQLRootResolver (..))-import           Data.Text                              (Text)-import qualified Data.Text.Lazy                         as LT (Text, fromStrict, toStrict)-import           Data.Text.Lazy.Encoding                (decodeUtf8, encodeUtf8)---- | main query processor and resolver---  possible versions of interpreter------ 1. with effect and state: where 'GQLState' is State Monad of subscriptions------     @---      k :: GQLState -> a -> IO a---     @------ 2. without effect and state: stateless query processor without any effect,---    if you don't need any subscription use this one , is simple and fast------     @---       k :: a -> IO a---       -- or---       k :: GQLRequest -> IO GQLResponse---     @-class Interpreter k m where-  interpreter ::-       Monad m-    => (RootResCon m a b c) =>-         GQLRootResolver m a b c -> k--{--  simple HTTP stateless Interpreter without side effects--}-type StateLess m a = a -> m a--instance Interpreter (GQLRequest -> m GQLResponse) m where-  interpreter = resolve--instance Interpreter (StateLess m LB.ByteString) m where-  interpreter = resolveByteString--instance Interpreter (StateLess m LT.Text) m where-  interpreter root request = decodeUtf8 <$> interpreter root (encodeUtf8 request)--instance Interpreter (StateLess m ByteString) m where-  interpreter root request = LB.toStrict <$> interpreter root (LB.fromStrict request)--instance Interpreter (StateLess m Text) m where-  interpreter root request = LT.toStrict <$> interpreter root (LT.fromStrict request)--{--   HTTP Interpreter with state and side effects, every mutation will-   trigger subscriptions in  shared `GQLState`--}-type WSPub m a = GQLState -> a -> m a--instance Interpreter (WSPub IO LB.ByteString) IO where-  interpreter root state = packStream state (resolveStreamByteString root)--instance Interpreter (WSPub IO LT.Text) IO where-  interpreter root state request = decodeUtf8 <$> interpreter root state (encodeUtf8 request)--instance Interpreter (WSPub IO ByteString) IO where-  interpreter root state request = LB.toStrict <$> interpreter root state (LB.fromStrict request)--instance Interpreter (WSPub IO Text) IO where-  interpreter root state request = LT.toStrict <$> interpreter root state (LT.fromStrict request)--{--   Websocket Interpreter without state and side effects, mutations and subscription will return Actions-   that will be executed in Websocket server--}-type WSSub m a = a -> m (OutputAction m a)--instance Interpreter (GQLRequest -> m (OutputAction m LB.ByteString)) m where-  interpreter root request = fmap encode <$> resolveStream root request--instance Interpreter (WSSub m LB.ByteString) m where-  interpreter = resolveStreamByteString--instance Interpreter (WSSub m LT.Text) m where-  interpreter root request = fmap decodeUtf8 <$> interpreter root (encodeUtf8 request)--instance Interpreter (WSSub m ByteString) m where-  interpreter root request = fmap LB.toStrict <$> interpreter root (LB.fromStrict request)--instance Interpreter (WSSub m Text) m where-  interpreter root request = fmap LT.toStrict <$> interpreter root (LT.fromStrict request)
src/Data/Morpheus/Kind.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds     #-} {-# LANGUAGE TypeFamilies  #-} {-# LANGUAGE TypeOperators #-} @@ -9,56 +10,36 @@   , WRAPPER   , UNION   , INPUT_OBJECT-  , KIND+  , INPUT_UNION+  , GQL_KIND   ) where -import           Data.Map                     (Map)-import           Data.Set                     (Set)-import           Data.Text                    (Text)---- MORPHEUS-import           Data.Morpheus.Types.Resolver (Resolver)---- | Type Family to associate type to GraphQL Kind-type family KIND a :: *+data GQL_KIND+  = SCALAR+  | OBJECT+  | ENUM+  | INPUT_OBJECT+  | UNION+  | INPUT_UNION+  | WRAPPER  -- | GraphQL Scalar: Int, Float, String, Boolean or any user defined custom Scalar type-data SCALAR+type SCALAR = 'SCALAR  -- | GraphQL Object-data OBJECT+type OBJECT = 'OBJECT  -- | GraphQL Enum-data ENUM+type ENUM = 'ENUM  -- | GraphQL input Object-data INPUT_OBJECT+type INPUT_OBJECT = 'INPUT_OBJECT  -- | GraphQL Union-data UNION---- | GraphQL Arrays , Resolvers and NonNull fields-data WRAPPER---- default Type Instances-type instance KIND Text = SCALAR--type instance KIND Int = SCALAR--type instance KIND Float = SCALAR--type instance KIND Bool = SCALAR--type instance KIND (Maybe a) = WRAPPER--type instance KIND [a] = WRAPPER--type instance KIND (a, b) = WRAPPER--type instance KIND (Set a) = WRAPPER--type instance KIND (Map k v) = WRAPPER+type UNION = 'UNION -type instance KIND (Resolver m a) = WRAPPER+-- | extension for graphQL+type INPUT_UNION = 'INPUT_UNION -type instance KIND (a -> b) = WRAPPER+-- | GraphQL Arrays , Resolvers and NonNull fields+type WRAPPER = 'WRAPPER
− src/Data/Morpheus/Parser/Arguments.hs 
@@ -1,27 +0,0 @@-module Data.Morpheus.Parser.Arguments-  ( maybeArguments-  ) where--import           Data.Morpheus.Parser.Internal                 (Parser)-import           Data.Morpheus.Parser.Primitive                (token, variable)-import           Data.Morpheus.Parser.Terms                    (parseAssignment, parseMaybeTuple)-import           Data.Morpheus.Parser.Value                    (enumValue, parseValue)-import           Data.Morpheus.Types.Internal.AST.RawSelection (Argument (..), RawArgument (..), RawArguments,-                                                                Reference (..))-import           Text.Megaparsec                               (getSourcePos, label, (<|>))--valueArgument :: Parser RawArgument-valueArgument = label "valueArgument" $ do-  position' <- getSourcePos-  value' <- parseValue <|> enumValue-  pure $ RawArgument $ Argument {argumentValue = value', argumentPosition = position'}--variableArgument :: Parser RawArgument-variableArgument = label "variableArgument" $ do-  (reference', position') <- variable-  pure $ VariableReference $ Reference {referenceName = reference', referencePosition = position'}--maybeArguments :: Parser RawArguments-maybeArguments = label "maybeArguments" $ parseMaybeTuple argument-  where-    argument = parseAssignment token (valueArgument <|> variableArgument)
− src/Data/Morpheus/Parser/Body.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parser.Body-  ( entries-  ) where--import           Data.Morpheus.Parser.Arguments                (maybeArguments)-import           Data.Morpheus.Parser.Internal                 (Parser)-import           Data.Morpheus.Parser.Primitive                (qualifier, token)-import           Data.Morpheus.Parser.Terms                    (onType, parseAssignment, spreadLiteral)-import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), RawArguments, RawSelection (..),-                                                                RawSelection' (..), RawSelectionSet, Reference (..))-import           Data.Text                                     (Text)-import           Text.Megaparsec                               (sepEndBy, between, getSourcePos, label, many, try, (<|>))-import           Text.Megaparsec.Char                          (char, space)--spread :: Parser (Text, RawSelection)-spread = label "spread" $ do-  index <- spreadLiteral-  key' <- token-  return (key', Spread $ Reference {referenceName = key', referencePosition = index})--inlineFragment :: Parser (Text, RawSelection)-inlineFragment = label "InlineFragment" $ do-  index <- spreadLiteral-  type' <- onType-  fragmentBody <- entries-  pure-    ( "INLINE_FRAGMENT"-    , InlineFragment $ Fragment {fragmentType = type', fragmentSelection = fragmentBody, fragmentPosition = index})--{--  accept:-  - field-  - field {...}-  - field (...)-  - field () {...}--}-parseSelectionField :: Parser (Text, RawSelection)-parseSelectionField = label "SelectionField" $ do-  (name', position') <- qualifier-  arguments' <- maybeArguments-  value' <- body arguments' <|> buildField arguments' position'-  return (name', value')-  where-    buildField arguments' position' =-      pure-        (RawSelectionField $-         RawSelection' {rawSelectionArguments = arguments', rawSelectionRec = (), rawSelectionPosition = position'})--alias :: Parser (Text, RawSelection)-alias = label "alias" $ do-  ((name', position'), selection') <- parseAssignment qualifier parseSelectionField-  return (name', RawAlias {rawAliasPosition = position', rawAliasSelection = selection'})--entries :: Parser RawSelectionSet-entries = label "entries" $-  between-    (char '{' *> space)-    (char '}' *> space)-    (entry `sepEndBy` many (char ',' *> space))-  where-    entry = label "entry" $-      try inlineFragment <|> try spread <|> try alias <|> parseSelectionField---body :: RawArguments -> Parser RawSelection-body args = label "body" $ do-  index <- getSourcePos-  entries' <- entries-  return-    (RawSelectionSet $-     RawSelection' {rawSelectionArguments = args, rawSelectionRec = entries', rawSelectionPosition = index})
− src/Data/Morpheus/Parser/Fragment.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parser.Fragment-  ( fragment-  ) where--import           Data.Morpheus.Parser.Body                     (entries)-import           Data.Morpheus.Parser.Internal                 (Parser)-import           Data.Morpheus.Parser.Primitive                (token)-import           Data.Morpheus.Parser.Terms                    (onType)-import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..))-import           Data.Text                                     (Text)-import           Text.Megaparsec                               (getSourcePos, label)-import           Text.Megaparsec.Char                          (space, string)--fragment :: Parser (Text, Fragment)-fragment = label "fragment" $ do-  index <- getSourcePos-  _ <- string "fragment"-  space-  name' <- token-  type' <- onType-  fragmentBody <- entries-  pure (name', Fragment {fragmentType = type', fragmentSelection = fragmentBody, fragmentPosition = index})
− src/Data/Morpheus/Parser/Internal.hs 
@@ -1,18 +0,0 @@-module Data.Morpheus.Parser.Internal-  ( GQLSyntax(..)-  , Parser-  , Position-  ) where--import           Data.Text       (Text)-import           Data.Void       (Void)-import           Text.Megaparsec (Parsec, SourcePos)--type Position = SourcePos--type Parser = Parsec Void Text--data GQLSyntax a-  = Invalid Text-            Position-  | Valid a
− src/Data/Morpheus/Parser/Operator.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parser.Operator-  ( parseAnonymousQuery-  , parseOperator-  ) where--import           Data.Functor                              (($>))-import           Data.Morpheus.Parser.Body                 (entries)-import           Data.Morpheus.Parser.Internal             (Parser)-import           Data.Morpheus.Parser.Primitive            (token, variable)-import           Data.Morpheus.Parser.Terms                (nonNull, parseAssignment, parseMaybeTuple)-import           Data.Morpheus.Types.Internal.AST.Operator (Operator (..), Operator' (..), RawOperator, RawOperator',-                                                            Variable (..))-import           Data.Morpheus.Types.Internal.Data         (DataTypeWrapper (..))-import           Data.Text                                 (Text)-import           Text.Megaparsec                           (between, getSourcePos, label, (<?>), (<|>))-import           Text.Megaparsec.Char                      (char, space, space1, string)--wrapMock :: Parser ([DataTypeWrapper], Text)-wrapMock = do-  mock <- token-  space-  return ([], mock)--insideList :: Parser ([DataTypeWrapper], Text)-insideList =-  between-    (char '[' *> space)-    (char ']' *> space)-    (do (list, name) <- wrapMock <|> insideList-        nonNull' <- nonNull-        return ((ListType : nonNull') ++ list, name))--wrappedSignature :: Parser ([DataTypeWrapper], Text)-wrappedSignature = do-  sig <- insideList <|> wrapMock-  space-  return sig--operatorArgument :: Parser (Text, Variable ())-operatorArgument =-  label "operatorArgument" $ do-    ((name', position'), (wrappers', type')) <- parseAssignment variable wrappedSignature-    nonNull' <- nonNull-    pure-      ( name'-      , Variable-          { variableType = type'-          , isVariableRequired = 0 < length nonNull'-          , variableTypeWrappers = nonNull' ++ wrappers'-          , variablePosition = position'-          , variableValue = ()-          })--parseOperator :: Parser RawOperator-parseOperator =-  label "operator" $ do-    pos <- getSourcePos-    kind' <- operatorKind-    operatorName' <- token-    variables <- parseMaybeTuple operatorArgument-    sel <- entries-    pure (kind' $ Operator' operatorName' variables sel pos)--parseAnonymousQuery :: Parser RawOperator-parseAnonymousQuery =-  label "AnonymousQuery" $ do-    position' <- getSourcePos-    selection' <- entries-    pure (Query $ Operator' "" [] selection' position') <?> "can't parse AnonymousQuery"--operatorKind :: Parser (RawOperator' -> RawOperator)-operatorKind =-  label "operatorKind" $ do-    kind <- (string "query" $> Query) <|> (string "mutation" $> Mutation) <|> (string "subscription" $> Subscription)-    space1-    return kind
− src/Data/Morpheus/Parser/Parser.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parser.Parser-  ( parseGQL-  ) where--import qualified Data.List.NonEmpty                      as NonEmpty-import           Data.Map                                (fromList, toList)-import           Data.Maybe                              (maybe)-import           Data.Morpheus.Parser.Fragment           (fragment)-import           Data.Morpheus.Parser.Internal           (Parser)-import           Data.Morpheus.Parser.Operator           (parseAnonymousQuery, parseOperator)-import           Data.Morpheus.Types.Internal.Validation (GQLError (GQLError), GQLErrors, Validation, desc, positions)-import           Data.Morpheus.Types.Internal.Value      (Value (..))-import           Data.Morpheus.Types.IO                  (GQLRequest (..))-import           Data.Morpheus.Types.Types               (GQLQueryRoot (..))-import           Data.Text                               (Text, pack)-import           Data.Void                               (Void)-import           Text.Megaparsec                         (ParseError, ParseErrorBundle (ParseErrorBundle), SourcePos,-                                                          attachSourcePos, bundleErrors, bundlePosState, eof,-                                                          errorOffset, label, manyTill, parseErrorPretty, runParser,-                                                          (<|>))-import           Text.Megaparsec.Char                    (space)--request :: Parser GQLQueryRoot-request =-  label "GQLQueryRoot" $ do-    space-    operator' <- parseAnonymousQuery <|> parseOperator-    fragmentLib <- fromList <$> manyTill fragment eof-    pure GQLQueryRoot {queryBody = operator', fragments = fragmentLib, inputVariables = []}--processErrorBundle :: ParseErrorBundle Text Void -> GQLErrors-processErrorBundle = fmap parseErrorToGQLError . bundleToErrors-  where-    parseErrorToGQLError :: (ParseError Text Void, SourcePos) -> GQLError-    parseErrorToGQLError (err, position) = GQLError {desc = pack (parseErrorPretty err), positions = [position]}-    bundleToErrors :: ParseErrorBundle Text Void -> [(ParseError Text Void, SourcePos)]-    bundleToErrors ParseErrorBundle {bundleErrors, bundlePosState} =-      NonEmpty.toList $ fst $ attachSourcePos errorOffset bundleErrors bundlePosState--getVariables :: GQLRequest -> [(Text, Value)]-getVariables request' = maybe [] toList (variables request')--parseReq :: GQLRequest -> Either (ParseErrorBundle Text Void) GQLQueryRoot-parseReq requestBody = runParser request "<input>" $ query requestBody--parseGQL :: GQLRequest -> Validation GQLQueryRoot-parseGQL requestBody =-  case parseReq requestBody of-    Right root      -> Right $ root {inputVariables = getVariables requestBody}-    Left parseError -> Left $ processErrorBundle parseError
− src/Data/Morpheus/Parser/Primitive.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parser.Primitive-  ( token-  , qualifier-  , variable-  ) where--import           Data.Morpheus.Parser.Internal      (Parser)-import           Data.Morpheus.Types.Internal.Base  (Position)-import           Data.Morpheus.Types.Internal.Value (convertToHaskellName)-import           Data.Text                          (Text)-import qualified Data.Text                          as T (pack)-import           Text.Megaparsec                    (getSourcePos, label, many, (<|>))-import           Text.Megaparsec.Char               (char, digitChar, letterChar, space)--token :: Parser Text-token =-  label "token" $ do-    firstChar <- letterChar <|> char '_'-    restToken <- many $ letterChar <|> char '_' <|> digitChar-    space-    return $ convertToHaskellName $ T.pack $ firstChar : restToken--qualifier :: Parser (Text, Position)-qualifier =-  label "qualifier" $ do-    position' <- getSourcePos-    value <- token-    return (value, position')--variable :: Parser (Text, Position)-variable =-  label "variable" $ do-    position' <- getSourcePos-    _ <- char '$'-    varName' <- token-    return (varName', position')
− src/Data/Morpheus/Parser/Terms.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parser.Terms-  ( onType-  , spreadLiteral-  , nonNull-  , parseMaybeTuple-  , parseAssignment-  ) where--import           Data.Functor                      (($>))-import           Data.Morpheus.Parser.Internal     (Parser, Position)-import           Data.Morpheus.Parser.Primitive    (token)-import           Data.Morpheus.Types.Internal.Data (DataTypeWrapper (..))-import           Data.Text                         (Text)-import           Text.Megaparsec                   (between, getSourcePos, label, sepBy, (<?>), (<|>))-import           Text.Megaparsec.Char              (char, space, space1, string)--nonNull :: Parser [DataTypeWrapper]-nonNull = do-  wrapper <- (char '!' $> [NonNullType]) <|> pure []-  space-  return wrapper--parseMaybeTuple :: Parser a -> Parser [a]-parseMaybeTuple parser = parseTuple parser <|> pure []--parseTuple :: Parser a -> Parser [a]-parseTuple parser = label "Tuple" $-  between-    (char '(' *> space)-    (char ')' *> space)-    (parser `sepBy` (char ',' *> space) <?> "empty Tuple value!")--parseAssignment :: (Show a, Show b) => Parser a -> Parser b -> Parser (a, b)-parseAssignment nameParser' valueParser' = label "assignment" $ do-  name' <- nameParser'-  char ':' *> space-  value' <- valueParser'-  pure (name', value')--onType :: Parser Text-onType = do-  _ <- string "on"-  space1-  token--spreadLiteral :: Parser Position-spreadLiteral = do-  index <- getSourcePos-  _ <- string "..."-  space-  return index
− src/Data/Morpheus/Parser/Value.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}-module Data.Morpheus.Parser.Value-  ( parseValue-  , enumValue-  ) where--import           Data.Functor                       (($>))-import           Data.Morpheus.Parser.Internal      (Parser)-import           Data.Morpheus.Parser.Primitive     (token)-import           Data.Morpheus.Parser.Terms         (parseAssignment)-import           Data.Morpheus.Types.Internal.Value (ScalarValue (..), Value (..), decodeScientific)-import           Data.Text                          (pack)-import           Text.Megaparsec                    (between, anySingleBut, choice, label, many, sepBy, (<|>))-import           Text.Megaparsec.Char               (char, space, string)-import           Text.Megaparsec.Char.Lexer         (scientific)--parseValue :: Parser Value-parseValue = label "value" $ do-  value <- valueNull <|> booleanValue <|> valueNumber <|> stringValue <|> objectValue <|> listValue-  space-  return value--valueNull :: Parser Value-valueNull = string "null" $> Null--booleanValue :: Parser Value-booleanValue = boolTrue <|> boolFalse-  where-    boolTrue = string "true" $> Scalar (Boolean True)-    boolFalse = string "false" $> Scalar (Boolean False)--valueNumber :: Parser Value-valueNumber = Scalar . decodeScientific <$> scientific--enumValue :: Parser Value-enumValue = do-  enum <- Enum <$> token-  space-  return enum--escaped :: Parser Char-escaped = label "escaped" $ do-  x <- anySingleBut '\"'-  if x == '\\'-    then choice (zipWith escapeChar codes replacements)-    else pure x-  where-    replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']-    codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']-    escapeChar code replacement = char code >> return replacement--stringValue :: Parser Value-stringValue = label "stringValue" $-  Scalar . String . pack <$>-    between-      (char '"')-      (char '"')-      (many escaped)--listValue :: Parser Value-listValue = label "listValue" $-  List <$> between-             (char '[' *> space)-             (char ']' *> space)-             (parseValue `sepBy` (char ',' *> space))--objectValue :: Parser Value-objectValue = label "objectValue" $-  Object <$> between-               (char '{' *> space)-               (char '}' *> space)-               (parseAssignment token parseValue `sepBy` (char ',' *> space))
+ src/Data/Morpheus/Parsing/Client/ParseMeta.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}++module Data.Morpheus.Parsing.Client.ParseMeta+  ( parseMeta+  ) where++import           Data.Morpheus.Parsing.Internal.Internal (Parser)+import           Data.Morpheus.Parsing.Internal.Terms    (parseAssignment, token)+import           Data.Text                               (Text)+import           Text.Megaparsec                         (between, label)+import           Text.Megaparsec.Char                    (char, space)++parseMeta :: Parser (Text, Text)+parseMeta =+  label "MetaData" $ do+    space+    _ <- char '#'+    between+      (char '{' *> space)+      (char '}' *> space)+      (parseAssignment token token)
+ src/Data/Morpheus/Parsing/Client/Parser.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Parsing.Client.Parser+  ( lookupGQLConfig+  ) where++import           Data.Text                               (Text)+import           Text.Megaparsec                         (label, runParser)+import           Text.Megaparsec.Char                    (space)++--+-- MORPHEUS+import           Data.Morpheus.Parsing.Client.ParseMeta  (parseMeta)+import           Data.Morpheus.Parsing.Internal.Internal (Parser, processErrorBundle)+import           Data.Morpheus.Types.Internal.Validation (Validation)++lookupGQLConfig :: Text -> Validation (Text, Text)+lookupGQLConfig text =+  case runParser request "<input>" text of+    Left x  -> Left $ processErrorBundle x+    Right x -> Right x+  where+    request :: Parser (Text, Text)+    request =+      label "GQLConfig" $ do+        space+        parseMeta
+ src/Data/Morpheus/Parsing/Document/DataType.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Parsing.Document.DataType+  ( parseDataType+  ) where++import           Data.Morpheus.Parsing.Internal.Create   (createArgument, createEnumType, createField, createScalarType,+                                                          createType, createUnionType)+import           Data.Morpheus.Parsing.Internal.Internal (Parser)+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)+import           Data.Text                               (Text)+import           Text.Megaparsec                         (label, sepBy1, (<|>))+import           Text.Megaparsec.Char                    (char, space1, string)++dataArgument :: Parser (Text, DataArgument)+dataArgument =+  label "Argument" $ do+    ((fieldName, _), (wrappers, fieldType)) <- parseAssignment qualifier parseWrappedType+    nonNull <- parseNonNull+    pure $ createArgument fieldName (nonNull ++ wrappers, fieldType)++typeDef :: Text -> Parser Text+typeDef kind = do+  _ <- string kind+  space1+  token++dataInputObject :: Parser (Text, DataFullType)+dataInputObject =+  label "inputObject" $ do+    typeName <- typeDef "input"+    typeData <- inputEntries+    pure (typeName, InputObject $ createType typeName typeData)+  where+    inputEntries :: Parser [(Key, DataArgument)]+    inputEntries = label "inputEntries" $ setOf entry+      where+        entry =+          label "entry" $ do+            ((fieldName, _), (wrappers, fieldType)) <- parseAssignment qualifier parseWrappedType+            nonNull <- parseNonNull+            return (fieldName, createField () fieldName (nonNull ++ wrappers, fieldType))++dataObject :: Parser (Text, DataFullType)+dataObject =+  label "object" $ do+    typeName <- typeDef "type"+    typeData <- entries+    pure (typeName, OutputObject $ createType typeName typeData)+  where+    entries :: Parser [(Key, DataOutputField)]+    entries = label "entries" $ setOf entry+      where+        fieldWithArgs =+          label "fieldWithArgs" $ do+            (name, _) <- qualifier+            args <- parseMaybeTuple dataArgument+            return (name, args)+        entry =+          label "entry" $ do+            ((fieldName, fieldArgs), (wrappers, fieldType)) <- parseAssignment fieldWithArgs parseWrappedType+            nonNull <- parseNonNull+            return (fieldName, createField fieldArgs fieldName (nonNull ++ wrappers, fieldType))++dataScalar :: Parser (Text, DataFullType)+dataScalar =+  label "scalar" $ do+    typeName <- typeDef "scalar"+    pure $ createScalarType typeName++dataEnum :: Parser (Text, DataFullType)+dataEnum =+  label "enum" $ do+    typeName <- typeDef "enum"+    typeData <- setOf token+    pure $ createEnumType typeName typeData++dataUnion :: Parser (Text, DataFullType)+dataUnion =+  label "union" $ do+    typeName <- typeDef "union"+    _ <- char '='+    spaceAndComments+    typeData <- unionsParser+    spaceAndComments+    pure $ createUnionType typeName typeData+  where+    unionsParser = token `sepBy1` pipeLiteral++parseDataType :: Parser (Text, DataFullType)+parseDataType = label "dataType" $ dataObject <|> dataInputObject <|> dataUnion <|> dataEnum <|> dataScalar
+ src/Data/Morpheus/Parsing/Document/Parse.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns   #-}++module Data.Morpheus.Parsing.Document.Parse+  ( parseGraphQLDocument+  , parseFullGQLDocument+  ) where++import           Control.Monad                           ((>=>))+import           Data.ByteString.Lazy.Char8              (ByteString)+import qualified Data.Text.Lazy                          as LT (toStrict)+import           Data.Text.Lazy.Encoding                 (decodeUtf8)++-- MORPHEUS+import           Data.Morpheus.Parsing.Document.Parser   (parseDocument)+import           Data.Morpheus.Schema.SchemaAPI          (defaultTypes)+import           Data.Morpheus.Types.Internal.Data       (DataTypeLib)+import           Data.Morpheus.Types.Internal.Validation (Validation)++parseGraphQLDocument :: ByteString -> Validation DataTypeLib+parseGraphQLDocument x = parseDocument (LT.toStrict $ decodeUtf8 x)++parseFullGQLDocument :: ByteString -> Validation DataTypeLib+parseFullGQLDocument = parseGraphQLDocument >=> defaultTypes
+ src/Data/Morpheus/Parsing/Document/Parser.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Parsing.Document.Parser+  ( parseDocument+  , parseTypes+  ) where++import           Data.Text                               (Text)+import           Text.Megaparsec                         (eof, label, manyTill, runParser)++-- MORPHEUS+import           Data.Morpheus.Parsing.Document.DataType (parseDataType)+import           Data.Morpheus.Parsing.Internal.Create   (createDataTypeLib)+import           Data.Morpheus.Parsing.Internal.Internal (processErrorBundle)+import           Data.Morpheus.Parsing.Internal.Terms    (spaceAndComments)+import           Data.Morpheus.Types.Internal.Data       (DataFullType, DataTypeLib)+import           Data.Morpheus.Types.Internal.Validation (Validation)++parseTypes :: Text -> Validation [(Text, DataFullType)]+parseTypes doc =+  case parseDoc of+    Right root      -> Right root+    Left parseError -> Left $ processErrorBundle parseError+  where+    parseDoc = runParser request "<input>" doc+    request =+      label "DocumentTypes" $ do+        spaceAndComments+        manyTill parseDataType eof++parseDocument :: Text -> Validation DataTypeLib+parseDocument doc =+  case parseDoc of+    Right root      -> Right root+    Left parseError -> Left $ processErrorBundle parseError+  where+    parseDoc = runParser request "<input>" doc+    request =+      label "Document" $ do+        spaceAndComments+        dataTypes <- manyTill parseDataType eof+        createDataTypeLib dataTypes
+ src/Data/Morpheus/Parsing/Internal/Create.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Parsing.Internal.Create+  ( createField+  , createArgument+  , createType+  , createScalarType+  , createEnumType+  , createUnionType+  , createDataTypeLib+  ) where++import           Data.Morpheus.Types.Internal.Data (DataField (..), DataFingerprint (..), DataFullType (..),+                                                    DataLeaf (..), DataType (..), DataTypeLib (..), DataTypeWrapper,+                                                    DataValidator (..), 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}++createArgument :: Text -> ([DataTypeWrapper], Text) -> (Text, DataField ())+createArgument fieldName x = (fieldName, createField () fieldName x)++createType :: Text -> a -> DataType a+createType typeName typeData =+  DataType {typeName, typeDescription = "", typeFingerprint = SystemFingerprint "", typeVisibility = True, typeData}++createScalarType :: Text -> (Text, DataFullType)+createScalarType typeName = (typeName, Leaf $ CustomScalar $ createType typeName (DataValidator pure))++createEnumType :: Text -> [Text] -> (Text, DataFullType)+createEnumType typeName typeData = (typeName, Leaf $ LeafEnum $ createType typeName typeData)++createUnionType :: Text -> [Text] -> (Text, DataFullType)+createUnionType typeName typeData = (typeName, Union $ createType typeName $ map unionField typeData)+  where+    unionField fieldType = createField () "" ([], fieldType)++createDataTypeLib :: Monad m => [(Text, DataFullType)] -> m DataTypeLib+createDataTypeLib types =+  case takeByKey "Query" types of+    (Just query, lib1) ->+      case takeByKey "Mutation" lib1 of+        (mutation, lib2) ->+          case takeByKey "Subscription" lib2 of+            (subscription, lib3) -> pure ((foldr defineType (initTypeLib query) lib3) {mutation, subscription})+    _ -> fail "Query Not Defined"+  ----------------------------------------------------------------------------+  where+    takeByKey key lib =+      case lookup key lib of+        Just (OutputObject value) -> (Just (key, value), filter ((/= key) . fst) lib)+        _                         -> (Nothing, lib)
+ src/Data/Morpheus/Parsing/Internal/Internal.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Parsing.Internal.Internal+  ( Parser+  , Position+  , processErrorBundle+  , getLocation+  ) where++import qualified Data.List.NonEmpty                      as NonEmpty+import           Data.Morpheus.Error.Utils               (toLocation)+import           Data.Morpheus.Types.Internal.Base       (Location)+import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)+import           Data.Text                               (Text, pack)+import           Data.Void                               (Void)+import           Text.Megaparsec                         (ParseError, ParseErrorBundle (ParseErrorBundle), Parsec,+                                                          SourcePos, attachSourcePos, bundleErrors, bundlePosState,+                                                          errorOffset, getSourcePos, parseErrorPretty)++type Position = Location++getLocation :: Parser Location+getLocation = fmap toLocation getSourcePos++type Parser = Parsec Void Text++processErrorBundle :: ParseErrorBundle Text Void -> GQLErrors+processErrorBundle = fmap parseErrorToGQLError . bundleToErrors+  where+    parseErrorToGQLError :: (ParseError Text Void, SourcePos) -> GQLError+    parseErrorToGQLError (err, position) =+      GQLError {desc = pack (parseErrorPretty err), positions = [toLocation position]}+    bundleToErrors :: ParseErrorBundle Text Void -> [(ParseError Text Void, SourcePos)]+    bundleToErrors ParseErrorBundle {bundleErrors, bundlePosState} =+      NonEmpty.toList $ fst $ attachSourcePos errorOffset bundleErrors bundlePosState
+ src/Data/Morpheus/Parsing/Internal/Terms.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++module Data.Morpheus.Parsing.Internal.Terms+  ( token+  , qualifier+  , variable+  , spaceAndComments+  , pipeLiteral+  -------------+  , setOf+  , onType+  , spreadLiteral+  , parseNonNull+  , parseMaybeTuple+  , parseAssignment+  , parseWrappedType+  ) where++import           Data.Functor                            (($>))+import           Data.Morpheus.Parsing.Internal.Internal (Parser, Position, getLocation)+import           Data.Morpheus.Types.Internal.Data       (DataTypeWrapper (..))+import           Data.Morpheus.Types.Internal.Value      (convertToHaskellName)+import           Data.Text                               (Text, pack)+import           Text.Megaparsec                         (between, label, many, sepBy, sepEndBy, skipMany, skipManyTill,+                                                          (<?>), (<|>))+import           Text.Megaparsec.Char                    (char, digitChar, letterChar, newline, printChar, space,+                                                          space1, string)++-- LITERALS+setLiteral :: Parser [a] -> Parser [a]+setLiteral = between (char '{' *> spaceAndComments) (char '}' *> spaceAndComments)++pipeLiteral :: Parser ()+pipeLiteral = char '|' *> spaceAndComments++-- PRIMITIVE+------------------------------------+token :: Parser Text+token =+  label "token" $ do+    firstChar <- letterChar <|> char '_'+    restToken <- many $ letterChar <|> char '_' <|> digitChar+    spaceAndComments+    return $ convertToHaskellName $ pack $ firstChar : restToken++qualifier :: Parser (Text, Position)+qualifier =+  label "qualifier" $ do+    position <- getLocation+    value <- token+    return (value, position)++variable :: Parser (Text, Position)+variable =+  label "variable" $ do+    position' <- getLocation+    _ <- char '$'+    varName' <- token+    return (varName', position')++spaceAndComments :: Parser ()+spaceAndComments = space *> skipMany inlineComment *> space+  where+    inlineComment = char '#' *> skipManyTill printChar newline *> space++-- COMPLEX+-----------------------------+setOf :: Parser a -> Parser [a]+setOf entry = setLiteral (entry `sepEndBy` many (char ',' *> spaceAndComments))++parseNonNull :: Parser [DataTypeWrapper]+parseNonNull = do+  wrapper <- (char '!' $> [NonNullType]) <|> pure []+  spaceAndComments+  return wrapper++parseMaybeTuple :: Parser a -> Parser [a]+parseMaybeTuple parser = parseTuple parser <|> pure []++parseTuple :: Parser a -> Parser [a]+parseTuple parser =+  label "Tuple" $+  between+    (char '(' *> spaceAndComments)+    (char ')' *> spaceAndComments)+    (parser `sepBy` (many (char ',') *> spaceAndComments) <?> "empty Tuple value!")++parseAssignment :: (Show a, Show b) => Parser a -> Parser b -> Parser (a, b)+parseAssignment nameParser valueParser =+  label "assignment" $ do+    name' <- nameParser+    char ':' *> spaceAndComments+    value' <- valueParser+    pure (name', value')++onType :: Parser Text+onType = do+  _ <- string "on"+  space1+  token++spreadLiteral :: Parser Position+spreadLiteral = do+  index <- getLocation+  _ <- string "..."+  space+  return index++parseWrappedType :: Parser ([DataTypeWrapper], Text)+parseWrappedType = (unwrapped <|> wrapped) <* spaceAndComments+  where+    unwrapped :: Parser ([DataTypeWrapper], Text)+    unwrapped = ([], ) <$> token <* spaceAndComments+    ----------------------------------------------+    wrapped :: Parser ([DataTypeWrapper], Text)+    wrapped =+      between+        (char '[' *> spaceAndComments)+        (char ']' *> spaceAndComments)+        (do (wrappers, name) <- unwrapped <|> wrapped+            nonNull' <- parseNonNull+            return ((ListType : nonNull') ++ wrappers, name))
+ src/Data/Morpheus/Parsing/JSONSchema/Parse.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}++module Data.Morpheus.Parsing.JSONSchema.Parse+  ( decodeIntrospection+  ) where++import           Data.Aeson+import           Data.ByteString.Lazy                    (ByteString)+import           Data.Morpheus.Error.Internal            (internalError)+import           Data.Morpheus.Parsing.Internal.Create   (createArgument, createDataTypeLib, createEnumType,+                                                          createField, createScalarType, createType, createUnionType)+import 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.Schema.TypeKind           (TypeKind (..))+import           Data.Morpheus.Types.Internal.Data       (DataFullType (..), DataTypeLib, DataTypeWrapper (..))+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 res -> fail $ show res+  where+    jsonSchema :: Either String (JSONResponse JSONIntro)+    jsonSchema = eitherDecode jsonDoc
+ src/Data/Morpheus/Parsing/Request/Arguments.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Parsing.Request.Arguments+  ( maybeArguments+  ) where++import           Data.Morpheus.Parsing.Internal.Internal       (Parser, getLocation)+import           Data.Morpheus.Parsing.Internal.Terms          (parseAssignment, parseMaybeTuple, token, variable)+import           Data.Morpheus.Parsing.Request.Value           (enumValue, parseValue)+import           Data.Morpheus.Types.Internal.AST.RawSelection (Argument (..), RawArgument (..), RawArguments,+                                                                Reference (..))+import           Data.Morpheus.Types.Internal.AST.Selection    (ArgumentOrigin (..))+import           Text.Megaparsec                               (label, (<|>))++valueArgument :: Parser RawArgument+valueArgument =+  label "valueArgument" $ do+    argumentPosition <- getLocation+    argumentValue <- parseValue <|> enumValue+    pure $ RawArgument $ Argument {argumentValue, argumentOrigin = INLINE, argumentPosition}++variableArgument :: Parser RawArgument+variableArgument =+  label "variableArgument" $ do+    (referenceName, referencePosition) <- variable+    pure $ VariableReference $ Reference {referenceName, referencePosition}++maybeArguments :: Parser RawArguments+maybeArguments = label "maybeArguments" $ parseMaybeTuple argument+  where+    argument = parseAssignment token (valueArgument <|> variableArgument)
+ src/Data/Morpheus/Parsing/Request/Body.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Parsing.Request.Body+  ( entries+  ) where++import           Data.Text                                     (Text)+import           Text.Megaparsec                               (label, try, (<|>))++--+-- MORPHEUS+import           Data.Morpheus.Parsing.Internal.Internal       (Parser, getLocation)+import           Data.Morpheus.Parsing.Internal.Terms          (onType, parseAssignment, qualifier, setOf,+                                                                spreadLiteral, token)+import           Data.Morpheus.Parsing.Request.Arguments       (maybeArguments)+import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), RawArguments, RawSelection (..),+                                                                RawSelection' (..), RawSelectionSet, Reference (..))++spread :: Parser (Text, RawSelection)+spread =+  label "spread" $ do+    referencePosition <- spreadLiteral+    referenceName <- token+    return (referenceName, Spread $ Reference {referenceName, referencePosition})++inlineFragment :: Parser (Text, RawSelection)+inlineFragment =+  label "InlineFragment" $ do+    fragmentPosition <- spreadLiteral+    fragmentType <- onType+    fragmentSelection <- entries+    pure ("INLINE_FRAGMENT", InlineFragment $ Fragment {fragmentType, fragmentSelection, fragmentPosition})++{-+  accept:+  - field+  - field {...}+  - field (...)+  - field () {...}+-}+parseSelectionField :: Parser (Text, RawSelection)+parseSelectionField =+  label "SelectionField" $ do+    (name, position) <- qualifier+    arguments <- maybeArguments+    value <- body arguments <|> buildField arguments position+    return (name, value)+  where+    buildField rawSelectionArguments rawSelectionPosition =+      pure (RawSelectionField $ RawSelection' {rawSelectionArguments, rawSelectionRec = (), rawSelectionPosition})++alias :: Parser (Text, RawSelection)+alias =+  label "alias" $ do+    ((name, rawAliasPosition), rawAliasSelection) <- parseAssignment qualifier parseSelectionField+    return (name, RawAlias {rawAliasPosition, rawAliasSelection})++entries :: Parser RawSelectionSet+entries = label "entries" $ setOf entry+  where+    entry = label "entry" $ try inlineFragment <|> try spread <|> try alias <|> parseSelectionField++body :: RawArguments -> Parser RawSelection+body rawSelectionArguments =+  label "body" $ do+    rawSelectionPosition <- getLocation+    rawSelectionRec <- entries+    return (RawSelectionSet $ RawSelection' {rawSelectionArguments, rawSelectionRec, rawSelectionPosition})
+ src/Data/Morpheus/Parsing/Request/Fragment.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Parsing.Request.Fragment+  ( fragment+  ) where++import           Data.Text                                     (Text)+import           Text.Megaparsec                               (label)+import           Text.Megaparsec.Char                          (space, string)++-- MORPHEUS+import           Data.Morpheus.Parsing.Internal.Internal       (Parser, getLocation)+import           Data.Morpheus.Parsing.Internal.Terms          (onType, token)+import           Data.Morpheus.Parsing.Request.Body            (entries)+import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..))++fragment :: Parser (Text, Fragment)+fragment =+  label "fragment" $ do+    _ <- string "fragment"+    space+    fragmentPosition <- getLocation+    name <- token+    fragmentType <- onType+    fragmentSelection <- entries+    pure (name, Fragment {fragmentType, fragmentSelection, fragmentPosition})
+ src/Data/Morpheus/Parsing/Request/Operation.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Parsing.Request.Operation+  ( parseAnonymousQuery+  , parseOperation+  ) where++import           Data.Functor                               (($>))+import           Data.Text                                  (Text)+import           Text.Megaparsec                            (label, (<?>), (<|>))+import           Text.Megaparsec.Char                       (space1, string)++--+-- MORPHEUS+import           Data.Morpheus.Parsing.Internal.Internal    (Parser, getLocation)+import           Data.Morpheus.Parsing.Internal.Terms       (parseAssignment, parseMaybeTuple, parseNonNull,+                                                             parseWrappedType, token, variable)+import           Data.Morpheus.Parsing.Request.Body         (entries)+import           Data.Morpheus.Types.Internal.AST.Operation (Operation (..), OperationKind (..), RawOperation,+                                                             Variable (..))++operationArgument :: Parser (Text, Variable ())+operationArgument =+  label "operatorArgument" $ do+    ((name, variablePosition), (wrappers, variableType)) <- parseAssignment variable parseWrappedType+    nonNull <- parseNonNull+    pure+      ( name+      , Variable+          { variableType+          , isVariableRequired = 0 < length nonNull+          , variableTypeWrappers = nonNull ++ wrappers+          , variablePosition+          , variableValue = ()+          })++parseOperation :: Parser RawOperation+parseOperation =+  label "operator" $ do+    operationPosition <- getLocation+    operationKind <- parseOperationKind+    operationName <- token+    operationArgs <- parseMaybeTuple operationArgument+    operationSelection <- entries+    pure (Operation {operationName, operationKind, operationArgs, operationSelection, operationPosition})++parseAnonymousQuery :: Parser RawOperation+parseAnonymousQuery =+  label "AnonymousQuery" $ do+    operationPosition <- getLocation+    operationSelection <- entries+    pure+      (Operation+         { operationName = "AnonymousQuery"+         , operationKind = QUERY+         , operationArgs = []+         , operationSelection+         , operationPosition+         }) <?>+      "can't parse AnonymousQuery"++parseOperationKind :: Parser OperationKind+parseOperationKind =+  label "operatorKind" $ do+    kind <- (string "query" $> QUERY) <|> (string "mutation" $> MUTATION) <|> (string "subscription" $> SUBSCRIPTION)+    space1+    return kind
+ src/Data/Morpheus/Parsing/Request/Parser.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Parsing.Request.Parser+  ( parseGQL+  ) where++import qualified Data.Aeson                              as Aeson (Value (..))+import           Data.HashMap.Lazy                       (toList)+import           Data.Text                               (Text)+import           Data.Void                               (Void)+import           Text.Megaparsec                         (ParseErrorBundle, eof, label, manyTill, runParser, (<|>))++--+-- MORPHEUS+import           Data.Morpheus.Parsing.Internal.Internal (Parser, processErrorBundle)+import           Data.Morpheus.Parsing.Internal.Terms    (spaceAndComments)+import           Data.Morpheus.Parsing.Request.Fragment  (fragment)+import           Data.Morpheus.Parsing.Request.Operation (parseAnonymousQuery, parseOperation)+import           Data.Morpheus.Types.Internal.Validation (Validation)+import           Data.Morpheus.Types.Internal.Value      (Value (..), replaceValue)+import           Data.Morpheus.Types.IO                  (GQLRequest (..))+import           Data.Morpheus.Types.Types               (GQLQueryRoot (..))++parseGQLSyntax :: Text -> Either (ParseErrorBundle Text Void) GQLQueryRoot+parseGQLSyntax = runParser request "<input>"+  where+    request :: Parser GQLQueryRoot+    request =+      label "GQLQueryRoot" $ do+        spaceAndComments+        operation <- parseAnonymousQuery <|> parseOperation+        fragments <- manyTill fragment eof+        pure GQLQueryRoot {operation, fragments, inputVariables = []}++parseGQL :: GQLRequest -> Validation GQLQueryRoot+parseGQL GQLRequest {query, variables} =+  case parseGQLSyntax query of+    Right root      -> Right $ root {inputVariables = toVariableMap variables}+    Left parseError -> Left $ processErrorBundle parseError+  where+    toVariableMap :: Maybe Aeson.Value -> [(Text, Value)]+    toVariableMap (Just (Aeson.Object x)) = map toMorpheusValue (toList x)+      where+        toMorpheusValue (key, value) = (key, replaceValue value)+    toVariableMap _ = []
+ src/Data/Morpheus/Parsing/Request/Value.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}++module Data.Morpheus.Parsing.Request.Value+  ( parseValue+  , enumValue+  ) where++import           Data.Functor                            (($>))+import           Data.Text                               (pack)+import           Text.Megaparsec                         (anySingleBut, between, choice, label, many, sepBy, (<|>))+import           Text.Megaparsec.Char                    (char, space, string)+import           Text.Megaparsec.Char.Lexer              (scientific)++--+-- MORPHEUS+import           Data.Morpheus.Parsing.Internal.Internal (Parser)+import           Data.Morpheus.Parsing.Internal.Terms    (parseAssignment, setOf, token)+import           Data.Morpheus.Types.Internal.Value      (ScalarValue (..), Value (..), decodeScientific)++parseValue :: Parser Value+parseValue =+  label "value" $ do+    value <-+      valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue <|>+      objectValue <|>+      listValue+    space+    return value++valueNull :: Parser Value+valueNull = string "null" $> Null++booleanValue :: Parser Value+booleanValue = boolTrue <|> boolFalse+  where+    boolTrue = string "true" $> Scalar (Boolean True)+    boolFalse = string "false" $> Scalar (Boolean False)++valueNumber :: Parser Value+valueNumber = Scalar . decodeScientific <$> scientific++enumValue :: Parser Value+enumValue = do+  enum <- Enum <$> token+  space+  return enum++escaped :: Parser Char+escaped =+  label "escaped" $ do+    x <- anySingleBut '\"'+    if x == '\\'+      then choice (zipWith escapeChar codes replacements)+      else pure x+  where+    replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']+    codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']+    escapeChar code replacement = char code >> return replacement++stringValue :: Parser Value+stringValue =+  label "stringValue" $+  Scalar . String . pack <$> between (char '"') (char '"') (many escaped)++listValue :: Parser Value+listValue =+  label "listValue" $+  List <$>+  between+    (char '[' *> space)+    (char ']' *> space)+    (parseValue `sepBy` (char ',' *> space))++objectValue :: Parser Value+objectValue = label "objectValue" $ Object <$> setOf entry+  where+    entry = parseAssignment token parseValue
+ src/Data/Morpheus/Rendering/GQL.hs view
@@ -0,0 +1,78 @@+{-# 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/Render.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Rendering.Haskell.Render+  ( renderHaskellDocument+  ) where++import           Data.ByteString.Lazy.Char8             (ByteString)+import           Data.Semigroup                         ((<>))+import           Data.Text                              (Text, intercalate, pack)+import qualified Data.Text                              as T (concat)+import qualified Data.Text.Lazy                         as LT (fromStrict)+import           Data.Text.Lazy.Encoding                (encodeUtf8)++-- MORPHEUS+import           Data.Morpheus.Rendering.Haskell.Terms  (Context (..), renderExtension)+import           Data.Morpheus.Rendering.Haskell.Types  (renderType)+import           Data.Morpheus.Rendering.Haskell.Values (Scope (..), renderResolver, renderRootResolver)+import           Data.Morpheus.Types.Internal.Data      (DataTypeLib (..), allDataTypes)++renderHaskellDocument :: String -> DataTypeLib -> ByteString+renderHaskellDocument modName lib =+  encodeText $+  renderLanguageExtensions context <> renderExports context <>+  renderImports context <>+  onSub renderApiEvents "" <>+  renderRootResolver context lib <>+  types+  where+    encodeText = encodeUtf8 . LT.fromStrict+    onSub onS els =+      case subscription lib of+        Nothing -> els+        _       -> onS+    renderApiEvents =+      "data Channel = Channel -- ChannelA | ChannelB" <> "\n\n" <>+      "data Content = Content -- ContentA Int | ContentB String" <>+      "\n\n"+    types = intercalate "\n\n" $ map renderFullType (allDataTypes lib)+      where+        renderFullType x = renderType cont x <> "\n\n" <> renderResolver cont x+          where+            cont = context {scope = getScope $ fst x}+            getScope "Mutation"     = Mutation+            getScope "Subscription" = Subscription+            getScope _              = Query+    context =+      Context+        { moduleName = pack modName+        , imports =+            [ ("GHC.Generics", ["Generic"])+            , ( "Data.Morpheus.Kind"+              , ["SCALAR", "ENUM", "INPUT_OBJECT", "OBJECT", "UNION"])+            , ( "Data.Morpheus.Types"+              , [ "GQLRootResolver(..)"+                , "toMutResolver"+                , "IORes"+                , "IOMutRes"+                , "IOSubRes"+                , "Event(..)"+                , "SubRootRes"+                , "GQLType(..)"+                , "GQLScalar(..)"+                , "ScalarValue(..)"+                ])+            , ("Data.Text", ["Text"])+            ]+        , extensions = ["OverloadedStrings", "DeriveGeneric", "TypeFamilies"]+        , scope = Query+        , pubSub = onSub ("Channel", "Content") ("()", "()")+        }++renderLanguageExtensions :: Context -> Text+renderLanguageExtensions Context {extensions} =+  T.concat (map renderExtension extensions) <> "\n"++renderExports :: Context -> Text+renderExports Context {moduleName} =+  "-- generated by 'Morpheus' CLI\n" <> "module " <> moduleName <>+  " (rootResolver) where\n\n"++renderImports :: Context -> Text+renderImports Context {imports} = T.concat (map renderImport imports) <> "\n"+  where+    renderImport (src, list) =+      "import  " <> src <> "  (" <> intercalate ", " list <> ")\n"
+ src/Data/Morpheus/Rendering/Haskell/Terms.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Rendering.Haskell.Terms+  ( indent+  , renderReturn+  , renderData+  , renderCon+  , renderMaybe+  , renderList+  , renderTuple+  , renderAssignment+  , renderExtension+  , renderWrapped+  , renderSet+  , renderUnionCon+  , renderEqual+  , Scope(..)+  , Context(..)+  ) where++import           Data.Semigroup                    ((<>))+import           Data.Text                         (Text, intercalate, toUpper)++-- MORPHEUS+import           Data.Morpheus.Types.Internal.Data (DataTypeWrapper (..))++indent :: Text+indent = "  "++renderEqual :: Text -> Text -> Text+renderEqual key value = key <> " = " <> value++renderReturn :: Text+renderReturn = "return "++renderData :: Text -> Text+renderData name = "data " <> name <> " = "++renderCon :: Text -> Text+renderCon name = name <> " "++renderMaybe :: Text -> Text+renderMaybe typeName = "Maybe " <> typeName++renderList :: Text -> Text+renderList typeName = "[" <> typeName <> "]"++renderTuple :: Text -> Text+renderTuple typeName = "(" <> typeName <> ")"++renderSet :: [Text] -> Text+renderSet fields =+  bracket "{ " <> intercalate ("\n  ," <> indent) fields <> bracket "}\n"+  where+    bracket x = "\n    " <> x++renderAssignment :: Text -> Text -> Text+renderAssignment key value = key <> " :: " <> value++renderExtension :: Text -> Text+renderExtension name = "{-# LANGUAGE " <> name <> " #-}\n"++renderWrapped :: [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++strToText :: Text -> Text+strToText "String" = "Text"+strToText x        = x++renderUnionCon :: Text -> Text -> Text+renderUnionCon typeName conName = renderCon (typeName <> "_" <> toUpper conName)++data Scope+  = Mutation+  | Subscription+  | Query++data Context =+  Context+    { moduleName :: Text+    , imports    :: [(Text, [Text])]+    , extensions :: [Text]+    , scope      :: Scope+    , pubSub     :: (Text, Text)+    }
+ src/Data/Morpheus/Rendering/Haskell/Types.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Rendering.Haskell.Types+  ( renderType+  ) where++import           Data.Maybe                            (catMaybes)+import           Data.Semigroup                        ((<>))+import           Data.Text                             (Text, intercalate, pack, toUpper)+import qualified Data.Text                             as T (head, tail)++-- MORPHEUS+import           Data.Morpheus.Rendering.Haskell.Terms (Context (..), Scope (..), indent, renderAssignment, renderCon,+                                                        renderData, renderSet, renderTuple, renderUnionCon,+                                                        renderWrapped)+import           Data.Morpheus.Types.Internal.Data     (DataArgument, DataField (..), DataFullType (..), DataLeaf (..),+                                                        DataType (..), DataTypeWrapper (..))++renderType :: Context -> (Text, DataFullType) -> Text+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 (InputUnion _) = "\n -- Error: Input Union Not Supported"+    renderT (OutputObject DataType {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"+    ----------------------------------------------------------------------------------------------------------++renderTypeInstanceHead :: Text -> Text -> Text+renderTypeInstanceHead className name =+  "instance " <> className <> " " <> name <> " where\n"++renderGQLScalar :: Text -> Text+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 typeName = unionType . map renderElem+  where+    renderElem DataField {fieldType} =+      renderUnionCon typeName fieldType <> fieldType++unionType :: [Text] -> Text+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+  where+    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)++renderField ::+     Context -> (Text, DataField [(Text, DataArgument)]) -> (Text, Maybe Text)+renderField Context {scope, pubSub = (channel, content)} (key, DataField { fieldTypeWrappers+                                                                         , fieldType+                                                                         , fieldArgs+                                                                         }) =+  ( key `renderAssignment` argTypeName <> " -> " <> renderMonad scope <>+    result fieldTypeWrappers+  , argTypes)+  where+    renderMonad Subscription = "IOSubRes " <> channel <> " " <> content <> " "+    renderMonad Mutation =+      case channel of+        "()" -> "IORes "+        _    -> "IOMutRes " <> channel <> " " <> content <> " "+    renderMonad _ = "IORes "+    -----------------------------------------------------------------+    result wrappers@(NonNullType:_) = renderWrapped wrappers fieldType+    result wrappers                 = renderTuple (renderWrapped wrappers fieldType)+    (argTypeName, argTypes) = renderArguments fieldArgs+    renderArguments :: [(Text, DataArgument)] -> (Text, Maybe Text)+    renderArguments [] = ("()", Nothing)+    renderArguments list =+      ( fieldArgTypeName+      , Just+          (renderData fieldArgTypeName <> renderCon fieldArgTypeName <>+           renderObject renderInputField list))+      where+        fieldArgTypeName = "Arg" <> camelCase key+        camelCase :: Text -> Text+        camelCase ""   = ""+        camelCase text = toUpper (pack [T.head text]) <> T.tail text
+ src/Data/Morpheus/Rendering/Haskell/Values.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Rendering.Haskell.Values+  ( renderRootResolver+  , renderResolver+  , Scope(..)+  ) where++import           Data.Semigroup                        ((<>))+import           Data.Text                             (Text)++-- 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 (..))++renderRootResolver :: Context -> DataTypeLib -> Text+renderRootResolver _ DataTypeLib {mutation, subscription} =+  renderSignature <> renderBody <> "\n\n"+  where+    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 <> " ()"+        ----------------------+        maybeOperator (Just (name, _)) = name+        maybeOperator Nothing          = "()"+    renderBody = "rootResolver =\n  GQLRootResolver" <> renderResObject fields+      where+        fields =+          [ ("queryResolver", "resolveQuery")+          , ("mutationResolver", maybeRes mutation)+          , ("subscriptionResolver", maybeRes subscription)+          ]+      ---------------------------------------------+        maybeRes (Just (name, _)) = "resolve" <> name+        maybeRes Nothing          = "return ()"++renderResolver :: Context -> (Text, DataFullType) -> Text+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+      where+        typeCon = fieldType $ head typeData+    renderSig (OutputObject DataType {typeData}) =+      defFunc <> renderReturn <> renderCon name <> renderObjFields+      where+        renderObjFields = renderResObject (map renderFieldRes typeData)+        renderFieldRes (key, DataField {fieldType, fieldTypeWrappers}) =+          ( key+          , "const " <>+            withScope scope (renderValue fieldTypeWrappers fieldType))+          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)+            ----------------------------------------------------------------------------+            fieldValue "String" = "$ return \"\""+            fieldValue "Int"    = "$ return 0"+            fieldValue fName    = "resolve" <> fName+            -------------------------------------------+            withScope Subscription x =+              "$ Event { channels = [Channel], content = const " <> x <> " }"+            withScope Mutation x =+              case (channel, content) of+                ("()", "()") -> 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"+    ---------------------------------------------------------------------------------+    renderMonad "Mutation" =+      "IOMutRes " <> channel <> " " <> content <> " Mutation"+    renderMonad "Subscription" = "SubRootRes IO " <> channel <> " Subscription"+    renderMonad tName = "IORes " <> tName+    ----------------------------------------------------------------------------------------------------------+    renderFunc = "resolve" <> name <> " = "+    ---------------------------------------++renderResObject :: [(Text, Text)] -> Text+renderResObject = renderSet . map renderEntry+  where+    renderEntry (key, value) = renderEqual key value
− src/Data/Morpheus/Resolve/Decode.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}--module Data.Morpheus.Resolve.Decode-  ( ArgumentsConstraint-  , decodeArguments-  ) where--import           Data.Morpheus.Error.Internal               (internalArgumentError, internalTypeMismatch)-import           Data.Morpheus.Kind                         (ENUM, INPUT_OBJECT, KIND, SCALAR, WRAPPER)-import           Data.Morpheus.Resolve.Generics.EnumRep     (EnumRep (..))-import           Data.Morpheus.Types.GQLScalar              (GQLScalar (..), toScalar)-import           Data.Morpheus.Types.Internal.AST.Selection (Argument (..), Arguments)-import           Data.Morpheus.Types.Internal.Validation    (Validation)-import           Data.Morpheus.Types.Internal.Value         (Value (..))-import           Data.Proxy                                 (Proxy (..))-import           Data.Text                                  (Text, pack)-import           GHC.Generics--type Decode_ a = Value -> Validation a--type ArgumentsConstraint a = (Generic a, GDecode Arguments (Rep a))--decodeArguments :: (Generic p, GDecode Arguments (Rep p)) => Arguments -> Validation p-decodeArguments args = to <$> gDecode "" args-------  GENERIC----fixProxy :: (a -> f a) -> f a-fixProxy f = f undefined--class GDecode i f where-  gDecode :: Text -> i -> Validation (f a)--instance GDecode i U1 where-  gDecode _ _ = pure U1--instance (Selector c, GDecode i f) => GDecode i (M1 S c f) where-  gDecode _ gql = fixProxy (\x -> M1 <$> gDecode (pack $ selName x) gql)--instance (Datatype c, GDecode i f) => GDecode i (M1 D c f) where-  gDecode key gql = fixProxy $ const (M1 <$> gDecode key gql)--instance GDecode i f => GDecode i (M1 C c f) where-  gDecode meta gql = M1 <$> gDecode meta gql--instance (GDecode i f, GDecode i g) => GDecode i (f :*: g) where-  gDecode meta gql = (:*:) <$> gDecode meta gql <*> gDecode meta gql--instance (Decode a (KIND a)) => GDecode Value (K1 i a) where-  gDecode key' (Object object) =-    case lookup key' object of-      Nothing    -> internalArgumentError "Missing Argument"-      Just value -> K1 <$> decode value-  gDecode _ isType = internalTypeMismatch "InputObject" isType--instance Decode a (KIND a) => GDecode Arguments (K1 i a) where-  gDecode key' args =-    case lookup key' args of-      Nothing                -> internalArgumentError "Required Argument Not Found"-      Just (Argument x _pos) -> K1 <$> decode x---- | Decode GraphQL query arguments and input values-decode ::-     forall a. Decode a (KIND a)-  => Decode_ a-decode = __decode (Proxy @(KIND a))---- | Decode GraphQL query arguments and input values-class Decode a b where-  __decode :: Proxy b -> Decode_ a------- SCALAR----instance (GQLScalar a) => Decode a SCALAR where-  __decode _ 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) = pure (to $ gToEnum value)-  __decode _ isType       = internalTypeMismatch "Enum" isType------- INPUT_OBJECT----instance (Generic a, GDecode Value (Rep a)) => Decode a INPUT_OBJECT where-  __decode _ (Object x) = to <$> gDecode "" (Object x)-  __decode _ isType     = internalTypeMismatch "InputObject" isType------- WRAPPERS: Maybe, List----instance Decode a (KIND a) => Decode (Maybe a) WRAPPER where-  __decode _ Null = pure Nothing-  __decode _ x    = Just <$> decode x--instance Decode a (KIND a) => Decode [a] WRAPPER where-  __decode _ (List li) = mapM decode li-  __decode _ isType    = internalTypeMismatch "List" isType
− src/Data/Morpheus/Resolve/Encode.hs 
@@ -1,229 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns        #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}--module Data.Morpheus.Resolve.Encode-  ( ObjectFieldResolvers(..)-  , resolveBySelection-  , resolversBy-  , QueryResult-  ) where--import           Control.Monad.Trans                        (lift)-import           Control.Monad.Trans.Except-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           GHC.Generics---- MORPHEUS-import           Data.Morpheus.Error.Internal               (internalErrorT)-import           Data.Morpheus.Error.Selection              (fieldNotResolved, subfieldsNotSelected)-import           Data.Morpheus.Kind                         (ENUM, KIND, OBJECT, SCALAR, UNION, WRAPPER)-import           Data.Morpheus.Resolve.Decode               (ArgumentsConstraint, decodeArguments)-import           Data.Morpheus.Resolve.Generics.EnumRep     (EnumRep (..))-import           Data.Morpheus.Types.Custom                 (MapKind, Pair (..), mapKindFromList)-import           Data.Morpheus.Types.GQLScalar              (GQLScalar (..))-import           Data.Morpheus.Types.GQLType                (GQLType (__typeName))-import           Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet)-import           Data.Morpheus.Types.Internal.Base          (Position)-import           Data.Morpheus.Types.Internal.Validation    (ResolveT, failResolveT)-import           Data.Morpheus.Types.Internal.Value         (ScalarValue (..), Value (..))-import           Data.Morpheus.Types.Resolver               (Effect (..), EffectT (..), Resolver)--type SelectRes m a = [(Text, (Text, Selection) -> ResolveT m a)] -> (Text, Selection) -> ResolveT m (Text, a)--type ResolveSel m a = [(Text, Selection)] -> [(Text, (Text, Selection) -> ResolveT m a)] -> ResolveT m a-------  OBJECT--- | Derives resolvers by object fields-class ObjectFieldResolvers f m where-  objectFieldResolvers :: Text -> f a -> [(Text, (Text, Selection) -> ResolveT m Value)]--instance ObjectFieldResolvers U1 res where-  objectFieldResolvers _ _ = []--instance (Selector s, ObjectFieldResolvers f res) => ObjectFieldResolvers (M1 S s f) res where-  objectFieldResolvers _ m@(M1 src) = objectFieldResolvers (pack $ selName m) src--instance ObjectFieldResolvers f res => ObjectFieldResolvers (M1 D c f) res where-  objectFieldResolvers key' (M1 src) = objectFieldResolvers key' src--instance ObjectFieldResolvers f res => ObjectFieldResolvers (M1 C c f) res where-  objectFieldResolvers key' (M1 src) = objectFieldResolvers key' src--instance (ObjectFieldResolvers f res, ObjectFieldResolvers g res) => ObjectFieldResolvers (f :*: g) res where-  objectFieldResolvers meta (a :*: b) = objectFieldResolvers meta a ++ objectFieldResolvers meta b--unwrapMonadTuple :: Monad m => (Text, m a) -> m (Text, a)-unwrapMonadTuple (text, ioa) = ioa >>= \x -> pure (text, x)--selectResolver :: Monad m => a -> SelectRes m a-selectResolver defaultValue resolvers' (key', selection') =-  case selectionRec selection' of-    SelectionAlias name' aliasSelection' ->-      unwrapMonadTuple (key', lookupResolver name' (selection' {selectionRec = aliasSelection'}))-    _ -> unwrapMonadTuple (key', lookupResolver key' selection')-  where-    lookupResolver resolverKey' sel =-      (fromMaybe (const $ return $defaultValue) $ lookup resolverKey' resolvers') (key', sel)------- UNION----class UnionResolvers f m where-  unionResolvers :: f a -> (Text, (Text, Selection) -> ResolveT m Value)--instance UnionResolvers f res => UnionResolvers (M1 S s f) res where-  unionResolvers (M1 x) = unionResolvers x--instance UnionResolvers f res => UnionResolvers (M1 D c f) res where-  unionResolvers (M1 x) = unionResolvers x--instance UnionResolvers f res => UnionResolvers (M1 C c f) res where-  unionResolvers (M1 x) = unionResolvers x--instance (UnionResolvers a res, UnionResolvers b res) => UnionResolvers (a :+: b) res where-  unionResolvers (L1 x) = unionResolvers x-  unionResolvers (R1 x) = unionResolvers x--type ObjectConstraint a m = (Monad m, Generic a, GQLType a, ObjectFieldResolvers (Rep a) m)--type UnionConstraint a m = (Monad m, Generic a, GQLType a, UnionResolvers (Rep a) m)--type EnumConstraint a = (Generic a, EnumRep (Rep a))--type QueryResult = Value--newtype WithGQLKind a b = WithGQLKind-  { resolverValue :: a-  }--type GQLKindOf a = WithGQLKind a (KIND a)--encode ::-     forall a m. Encoder a (KIND a) m-  => a-  -> (Text, Selection)-  -> ResolveT m Value-encode resolver = __encode (WithGQLKind resolver :: GQLKindOf a)--class Encoder a kind m where-  __encode :: WithGQLKind a kind -> (Text, Selection) -> ResolveT m Value------- SCALAR----instance (GQLScalar a, Monad m) => Encoder a SCALAR m where-  __encode = pure . pure . Scalar . serialize . resolverValue------- ENUM----instance (EnumConstraint a, Monad m) => Encoder a ENUM m where-  __encode = pure . pure . Scalar . String . encodeRep . from . resolverValue-------  OBJECTS----instance ObjectConstraint a m => Encoder a OBJECT 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--resolveBySelection :: Monad m => ResolveSel m Value-resolveBySelection selection resolvers = Object <$> mapM (selectResolver Null resolvers) selection--resolversBy ::-     (Generic a, Monad m, ObjectFieldResolvers (Rep a) m) => a -> [(Text, (Text, Selection) -> ResolveT m Value)]-resolversBy = objectFieldResolvers "" . from--instance Encoder a (KIND a) res => ObjectFieldResolvers (K1 s a) res where-  objectFieldResolvers key' (K1 src) = [(key', encode src)]---- | Resolves and encodes UNION,--- Handles all operators: Query, Mutation and Subscription,-instance UnionConstraint a m => Encoder a UNION 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"--instance (GQLType a, Encoder a (KIND a) res) => UnionResolvers (K1 s a) res where-  unionResolvers (K1 src) = (__typeName (Proxy @a), encode src)-------  RESOLVER: ::-> and ::->>------ | 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) m) => Encoder (a -> Resolver m b) WRAPPER m where-  __encode (WithGQLKind resolver) selection'@(fieldName, Selection {selectionArguments, selectionPosition}) = do-    args <- ExceptT $ pure $ decodeArguments selectionArguments-    lift (runExceptT $ resolver args) >>= liftEither selectionPosition fieldName >>= (`encode` selection')--liftEither :: Monad m => Position -> Text -> Either String a -> ResolveT m a-liftEither position name (Left message) = failResolveT $ fieldNotResolved position name (pack message)-liftEither _ _ (Right value)            = pure value---- packs Monad in EffectMonad-instance (Monad m, Encoder a (KIND a) m, ArgumentsConstraint p) => Encoder (p -> Either String a) WRAPPER m where-  __encode (WithGQLKind resolver) selection'@(fieldName, Selection {selectionArguments, selectionPosition}) =-    case decodeArguments selectionArguments of-      Left message -> failResolveT message-      Right value  -> liftEither selectionPosition fieldName (resolver value) >>= (`encode` selection')---- packs Monad in EffectMonad-instance (ArgumentsConstraint a, Monad m, Encoder b (KIND b) m) =>-         Encoder (a -> Resolver m b) WRAPPER (EffectT m c) where-  __encode resolver selection = ExceptT $ EffectT $ Effect [] <$> runExceptT (__encode resolver selection)------- MAYBE----instance (Monad m, Encoder a (KIND a) m) => Encoder (Maybe a) WRAPPER m where-  __encode (WithGQLKind Nothing)      = const $ pure Null-  __encode (WithGQLKind (Just value)) = encode value------- LIST----instance (Monad m, Encoder a (KIND a) m) => Encoder [a] WRAPPER m where-  __encode (WithGQLKind list) query = List <$> mapM (`__encode` query) (map WithGQLKind list :: [GQLKindOf a])-------  Tuple----instance Encoder (Pair k v) OBJECT m => Encoder (k, v) WRAPPER m where-  __encode (WithGQLKind (key, value)) = encode (Pair key value)-------  Set----instance Encoder [a] WRAPPER m => Encoder (Set a) WRAPPER m where-  __encode (WithGQLKind dataSet) = encode (S.toList dataSet)-------  Map----instance (Eq k, Monad m, Encoder (MapKind k v (Resolver m)) OBJECT m) => Encoder (Map k v) WRAPPER m where-  __encode (WithGQLKind value) = encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver m))
− src/Data/Morpheus/Resolve/Generics/EnumRep.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeOperators       #-}--module Data.Morpheus.Resolve.Generics.EnumRep-  ( EnumRep(..)-  ) where--import           Data.Proxy   (Proxy (..))-import           Data.Text    (Text, pack)-import           GHC.Generics--class EnumRep f where-  encodeRep :: f a -> Text-  gToEnum :: Text -> f a-  tagName :: Proxy f -> Text-  getTags :: Proxy f -> [Text]--instance (Datatype c, EnumRep f) => EnumRep (M1 D c f) where-  encodeRep (M1 src) = encodeRep src-  gToEnum = M1 . gToEnum-  tagName _ = ""-  getTags _ = getTags (Proxy :: Proxy f)--instance (Constructor c) => EnumRep (M1 C c U1) where-  encodeRep m@(M1 _) = pack $ conName m-  gToEnum _ = M1 U1-  tagName _ = pack $ conName (undefined :: (M1 C c U1 x))-  getTags proxy = [tagName proxy]--instance (EnumRep a, EnumRep b) => EnumRep (a :+: b) where-  encodeRep (L1 x) = encodeRep x-  encodeRep (R1 x) = encodeRep x-  gToEnum name =-    if tagName (Proxy @a) == name-      then L1 $ gToEnum name-      else R1 $ gToEnum name-  tagName _ = ""-  getTags _ = getTags (Proxy @a) ++ getTags (Proxy @b)
− src/Data/Morpheus/Resolve/Generics/TypeRep.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeOperators         #-}--module Data.Morpheus.Resolve.Generics.TypeRep-  ( UnionRep(..)-  , ObjectRep(..)-  , TypeUpdater-  , SelOf-  , RecSel-  , resolveTypes-  ) where--import           Control.Monad                           (foldM)-import           Data.Function                           ((&))-import           Data.Morpheus.Types.Internal.Data       (DataField, DataTypeLib)-import           Data.Morpheus.Types.Internal.Validation (SchemaValidation)-import           Data.Proxy                              (Proxy (..))-import           Data.Text                               (Text)-import           GHC.Generics--type SelOf s = M1 S s (Rec0 ()) ()--type RecSel s a = M1 S s (Rec0 a)--type TypeUpdater = DataTypeLib -> SchemaValidation DataTypeLib--{--  introspect Union Types--}-class UnionRep f where-  possibleTypes :: Proxy f -> [(DataField (), TypeUpdater)]--instance UnionRep f => UnionRep (M1 D x f) where-  possibleTypes _ = possibleTypes (Proxy @f)--instance UnionRep f => UnionRep (M1 C x f) where-  possibleTypes _ = possibleTypes (Proxy @f)--instance (UnionRep a, UnionRep b) => UnionRep (a :+: b) where-  possibleTypes _ = possibleTypes (Proxy @a) ++ possibleTypes (Proxy @b)--{--  introspect Input and Output Object Types--}-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 _ = []
− src/Data/Morpheus/Resolve/Introspect.hs 
@@ -1,244 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns        #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}--module Data.Morpheus.Resolve.Introspect-  ( introspectOutputType-  ) where--import           Data.Map                               (Map)-import           Data.Morpheus.Error.Schema             (nameCollisionError)-import           Data.Morpheus.Kind                     (ENUM, INPUT_OBJECT, KIND, OBJECT, SCALAR, UNION, WRAPPER)-import           Data.Morpheus.Resolve.Generics.EnumRep (EnumRep (..))-import           Data.Morpheus.Resolve.Generics.TypeRep (ObjectRep (..), RecSel, SelOf, TypeUpdater, UnionRep (..),-                                                         resolveTypes)-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 (..),-                                                         DataTypeKind (..), DataTypeWrapper (..), DataValidator,-                                                         defineType, isTypeDefined)-import           Data.Morpheus.Types.Resolver           (Resolver)-import           Data.Proxy                             (Proxy (..))-import           Data.Set                               (Set)-import           Data.Text                              (Text, pack)-import           GHC.Generics---- 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)--type UnionConstraint a = (GQL_TYPE a, UnionRep (Rep a))--scalarTypeOf :: GQLType a => DataValidator -> Proxy a -> DataFullType-scalarTypeOf validator = Leaf . LeafScalar . buildType validator--enumTypeOf :: GQLType a => [Text] -> Proxy a -> DataFullType-enumTypeOf tags' = Leaf . LeafEnum . buildType tags'--type InputType = ()--type OutputType = DataArguments--type InputOf t = Context t (KIND t) InputType--type OutputOf t = Context t (KIND t) OutputType--introspectOutputType ::-     forall a. Introspect a (KIND a) OutputType-  => Proxy a-  -> TypeUpdater-introspectOutputType _ = introspect (Context :: OutputOf 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--buildField :: GQLType a => DataTypeKind -> Proxy a -> t -> Text -> DataField t-buildField fieldKind proxy' fieldArgs fieldName =-  DataField-    { fieldName-    , fieldKind-    , fieldArgs-    , fieldTypeWrappers = [NonNullType]-    , fieldType = __typeName proxy'-    , fieldHidden = False-    }--buildType :: GQLType a => t -> Proxy a -> DataType t-buildType typeData proxy =-  DataType-    { typeName = __typeName proxy-    , typeFingerprint = __typeFingerprint proxy-    , typeDescription = description 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)---- |   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--type OutputConstraint a = Introspect a (KIND a) DataArguments------- SCALAR----instance (GQLScalar a, GQLType a) => Introspect a SCALAR InputType where-  __field _ = buildField KindScalar (Proxy @a) ()-  introspect _ = updateLib (scalarTypeOf (scalarValidator $ Proxy @a)) [] (Proxy @a)--instance (GQLScalar a, GQLType a) => Introspect a SCALAR OutputType where-  __field _ = buildField KindScalar (Proxy @a) []-  introspect _ = updateLib (scalarTypeOf (scalarValidator $ Proxy @a)) [] (Proxy @a)------- ENUM----instance EnumConstraint a => Introspect a ENUM InputType where-  __field _ = buildField KindEnum (Proxy @a) ()-  introspect _ = introspectEnum (Context :: InputOf a)--instance EnumConstraint a => Introspect a ENUM OutputType where-  __field _ = buildField KindEnum (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 $ getTags (Proxy @(Rep a))) [] (Proxy @a)------- OBJECTS , INPUT_OBJECT----instance InputObjectConstraint a => Introspect a INPUT_OBJECT InputType where-  __field _ = buildField KindInputObject (Proxy @a) ()-  introspect _ = updateLib (InputObject . buildType fields') stack' (Proxy @a)-    where-      (fields', stack') = unzip $ objectFieldTypes (Proxy @(Rep a))--instance ObjectConstraint a => Introspect a OBJECT OutputType where-  __field _ = buildField KindObject (Proxy @a) []-  introspect _ = updateLib (OutputObject . buildType (__typename : fields')) stack' (Proxy @a)-    where-      __typename =-        ( "__typename"-        , DataField-            { fieldName = "__typename"-            , fieldKind = KindScalar-            , fieldArgs = []-            , fieldTypeWrappers = []-            , fieldType = "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)------- UNION------ | recursion for union types--- iterates on possible types for UNION and introspects them recursively-instance (OutputConstraint a, ObjectConstraint a) => UnionRep (RecSel s a) where-  possibleTypes _ = [(buildField KindObject (Proxy @a) () "", introspect (Context :: OutputOf a))]--instance UnionConstraint a => Introspect a UNION OutputType where-  __field _ = buildField KindUnion (Proxy @a) []-  introspect _ = updateLib (Union . buildType fields) stack (Proxy @a)-    where-      (fields, stack) = unzip $ possibleTypes (Proxy @(Rep a))------- WRAPPER : Maybe, LIST , Resolver----instance Introspect a (KIND a) f => Introspect (Maybe a) WRAPPER f where-  __field _ name = maybeField $ __field (Context :: Context a (KIND a) f) name-    where-      maybeField :: DataField f -> DataField f-      maybeField field@DataField {fieldTypeWrappers = NonNullType:xs} = field {fieldTypeWrappers = xs}-      maybeField field                                                = field-  introspect _ = introspect (Context :: Context a (KIND a) f)--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)------- 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 Introspect [a] WRAPPER f => Introspect (Set a) WRAPPER f where-  __field _ = __field (Context :: Context [a] WRAPPER f)-  introspect _ = introspect (Context :: Context [a] WRAPPER f)---- | introspection Does not care about resolving monad, some fake monad just for mocking-type MockRes = (Resolver Maybe)--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)---- |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))--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))
− src/Data/Morpheus/Resolve/Operator.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE ConstraintKinds          #-}-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE FlexibleContexts         #-}-{-# LANGUAGE FlexibleInstances        #-}-{-# LANGUAGE MultiParamTypeClasses    #-}-{-# LANGUAGE NamedFieldPuns           #-}-{-# LANGUAGE OverloadedStrings        #-}-{-# LANGUAGE RankNTypes               #-}-{-# LANGUAGE ScopedTypeVariables      #-}-{-# LANGUAGE TypeApplications         #-}-{-# LANGUAGE TypeFamilies             #-}-{-# LANGUAGE TypeOperators            #-}--module Data.Morpheus.Resolve.Operator-  ( RootResCon-  , fullSchema-  , encodeQuery-  , effectEncode-  ) where--import           Data.Morpheus.Resolve.Encode               (ObjectFieldResolvers (..), resolveBySelection, resolversBy)-import           Data.Morpheus.Resolve.Generics.TypeRep     (ObjectRep (..), TypeUpdater, resolveTypes)-import           Data.Morpheus.Schema.SchemaAPI             (hiddenRootFields, schemaAPI, schemaTypes)-import           Data.Morpheus.Types.Internal.AST.Selection (SelectionSet)-import           Data.Morpheus.Types.Internal.Data          (DataArguments, DataFingerprint (..), DataType (..),-                                                             DataTypeLib (..), initTypeLib)-import           Data.Morpheus.Types.Internal.Validation    (ResolveT, SchemaValidation)-import           Data.Morpheus.Types.Internal.Value         (Value (..))-import           Data.Morpheus.Types.Resolver               (EffectT (..))-import           Data.Proxy-import           Data.Text                                  (Text)-import           Data.Typeable                              (Typeable)-import           GHC.Generics--type RootResCon m a b c = (OperatorCon m a, OperatorEffectCon m b, OperatorEffectCon m c)--type OperatorCon m a = (IntroCon a, EncodeCon m a)--type OperatorEffectCon m a = (IntroCon a, EncodeCon (EffectT m Text) a)--type Encode m a = ResolveT m a -> SelectionSet -> ResolveT m Value--type EncodeCon m a = (Generic a, ObjectFieldResolvers (Rep a) m)--type BaseEncode m a-   = EncodeCon m a =>-       DataTypeLib -> Encode m a--type EffectEncode m a-   = EncodeCon (EffectT m Text) a =>-       Encode (EffectT m Text) a--encodeQuery :: Monad m => BaseEncode m a-encodeQuery types rootResolver sel =-  fmap resolversBy rootResolver >>= resolveBySelection sel . (++) (resolversBy $ schemaAPI types)--effectEncode :: Monad m => EffectEncode m a-effectEncode rootResolver sel = rootResolver >>= resolveBySelection sel . resolversBy--type IntroCon a = (Generic a, ObjectRep (Rep a) DataArguments, Typeable a)--fullSchema ::-     forall m a b c. (IntroCon a, IntroCon b, IntroCon c)-  => ResolveT m a-  -> ResolveT (EffectT m Text) b-  -> ResolveT (EffectT m Text) c-  -> SchemaValidation DataTypeLib-fullSchema queryRes mutationRes subscriptionRes =-  querySchema queryRes >>= mutationSchema mutationRes >>= subscriptionSchema subscriptionRes-  where-    querySchema _ = resolveTypes queryType (schemaTypes : types)-      where-        queryType = initTypeLib (operatorType (hiddenRootFields ++ fields) "Query")-        (fields, types) = unzip $ objectFieldTypes (Proxy @(Rep a))--mutationSchema ::-     forall a m. IntroCon a-  => m a-  -> TypeUpdater-mutationSchema _ initialType = resolveTypes mutationType types'-  where-    mutationType = initialType {mutation = maybeOperator fields "Mutation"}-    (fields, types') = unzip $ objectFieldTypes (Proxy :: Proxy (Rep a))--subscriptionSchema ::-     forall a m. IntroCon a-  => m a-  -> TypeUpdater-subscriptionSchema _ initialType = resolveTypes mutationType types'-  where-    mutationType = initialType {subscription = maybeOperator fields "Subscription"}-    (fields, types') = unzip $ objectFieldTypes (Proxy :: Proxy (Rep a))--maybeOperator :: [a] -> Text -> Maybe (Text, DataType [a])-maybeOperator []     = const Nothing-maybeOperator fields = Just . operatorType fields--operatorType :: [a] -> Text -> (Text, DataType [a])-operatorType typeData typeName =-  (typeName, DataType {typeData, typeName, typeFingerprint = SystemFingerprint typeName, typeDescription = ""})
− src/Data/Morpheus/Resolve/Resolve.hs 
@@ -1,105 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Resolve.Resolve-  ( resolve-  , resolveByteString-  , resolveStreamByteString-  , resolveStream-  , packStream-  ) where--import Control.Monad.Trans.Except (ExceptT(..), runExceptT)-import Data.Aeson (eitherDecode, encode)-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Morpheus.Error.Utils (badRequestError, renderErrors)-import Data.Morpheus.Parser.Parser (parseGQL)-import Data.Morpheus.Resolve.Operator (RootResCon, effectEncode, encodeQuery, fullSchema)-import Data.Morpheus.Server.ClientRegister (GQLState, publishUpdates)-import Data.Morpheus.Types.IO (GQLRequest(..), GQLResponse(..))-import Data.Morpheus.Types.Internal.AST.Operator (Operator(..), Operator'(..))-import Data.Morpheus.Types.Internal.WebSocket (OutputAction(..))-import Data.Morpheus.Types.Resolver (GQLRootResolver(..), unpackEffect, unpackEffect2)-import Data.Morpheus.Validation.Validation (validateRequest)--resolveByteString ::-     Monad m-  => RootResCon m a b c =>-       GQLRootResolver m a b c -> ByteString -> m ByteString-resolveByteString rootResolver request =-  case eitherDecode request of-    Left aesonError' -> return $ badRequestError aesonError'-    Right req -> encode <$> resolve rootResolver req--resolveStreamByteString ::-     Monad m-  => RootResCon m a b c =>-       GQLRootResolver m a b c -> ByteString -> m (OutputAction m ByteString)-resolveStreamByteString rootResolver request =-  case eitherDecode request of-    Left aesonError' -> return $ NoEffect $ badRequestError aesonError'-    Right req -> fmap encode <$> resolveStream rootResolver req--resolve ::-     Monad m-  => RootResCon m a b c =>-       GQLRootResolver m a b c -> GQLRequest -> m GQLResponse-resolve GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver} request =-  case fullSchema queryResolver mutationResolver subscriptionResolver of-    Left error' -> return $ Errors $ renderErrors error'-    Right validSchema -> do-      value <- runExceptT $ _resolve validSchema-      case value of-        Left x -> return $ Errors $ renderErrors x-        Right x -> return $ Data x-      where _resolve gqlSchema = do-              rootGQL <- ExceptT $ pure (parseGQL request >>= validateRequest gqlSchema)-              case rootGQL of-                Query operator' -> encodeQuery gqlSchema queryResolver $ operatorSelection operator'-                Mutation operator' ->-                  snd <$> unpackEffect2 (effectEncode mutationResolver (operatorSelection operator'))-                Subscription operator' ->-                  snd <$> unpackEffect2 (effectEncode subscriptionResolver (operatorSelection operator'))--resolveStream ::-     Monad m-  => RootResCon m a b c =>-       GQLRootResolver m a b c -> GQLRequest -> m (OutputAction m GQLResponse)-resolveStream GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver} request =-  case fullSchema queryResolver mutationResolver subscriptionResolver of-    Left error' -> return $ NoEffect $ Errors $ renderErrors error'-    Right validSchema -> do-      value <- runExceptT $ _resolve validSchema-      case value of-        Left x -> return $ NoEffect $ Errors $ renderErrors x-        Right value' -> return $ fmap Data value'-  where-    _resolve gqlSchema = (ExceptT $ pure (parseGQL request >>= validateRequest gqlSchema)) >>= resolveOperator-      where-        resolveOperator (Query operator') = do-          value <- encodeQuery gqlSchema queryResolver $ operatorSelection operator'-          return (NoEffect value)-        resolveOperator (Mutation operator') = do-          (channels, response) <- unpackEffect2 $ effectEncode mutationResolver $ operatorSelection operator'-          return-            PublishMutation {mutationChannels = channels, mutationResponse = response, currentSubscriptionStateResolver}-          where-            currentSubscriptionStateResolver selection' = do-              value <- unpackEffect (effectEncode subscriptionResolver selection')-              case value of-                Left x -> pure $ Errors $ renderErrors x-                Right (_, x') -> return $ Data x'-        resolveOperator (Subscription operator') = do-          (subscriptionChannels, _) <- unpackEffect2 $ effectEncode subscriptionResolver $ operatorSelection operator'-          return InitSubscription {subscriptionChannels, subscriptionQuery = operatorSelection operator'}--packStream :: GQLState -> (ByteString -> IO (OutputAction IO ByteString)) -> ByteString -> IO ByteString-packStream state streamAPI request = do-  value <- streamAPI request-  case value of-    PublishMutation {mutationChannels, mutationResponse, currentSubscriptionStateResolver} -> do-      publishUpdates mutationChannels currentSubscriptionStateResolver state-      return mutationResponse-    InitSubscription {} -> pure "subscriptions are only allowed in websocket"-    NoEffect res' -> return res'
src/Data/Morpheus/Schema/Directive.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -7,21 +8,23 @@   ( Directive(..)   ) where -import           Data.Morpheus.Kind                                (KIND, OBJECT)-import           Data.Morpheus.Schema.DirectiveLocation            (DirectiveLocation)-import           Data.Morpheus.Schema.Internal.RenderIntrospection (InputValue)-import           Data.Morpheus.Types.GQLType                       (GQLType (__typeName))-import           Data.Text                                         (Text)-import           GHC.Generics                                      (Generic)--type instance KIND Directive = OBJECT+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 GQLType Directive where+instance Typeable a => GQLType (Directive a) where+  type KIND (Directive a) = OBJECT   __typeName = const "__Directive"+  __typeVisibility = const False -data Directive = Directive+data Directive t = Directive   { name        :: Text   , description :: Maybe Text   , locations   :: [DirectiveLocation]-  , args        :: [InputValue]-  } deriving (Generic)+  , args        :: [InputValue t]+  } deriving (Show, Generic, FromJSON)
src/Data/Morpheus/Schema/DirectiveLocation.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -6,12 +7,11 @@   ( DirectiveLocation(..)   ) where -import           Data.Morpheus.Kind          (ENUM, KIND)-import           Data.Morpheus.Types.GQLType (GQLType (__typeName))+import           Data.Aeson                  (FromJSON (..))+import           Data.Morpheus.Kind          (ENUM)+import           Data.Morpheus.Types.GQLType (GQLType (KIND, __typeName, __typeVisibility)) import           GHC.Generics -type instance KIND DirectiveLocation = ENUM- data DirectiveLocation   = QUERY   | MUTATION@@ -32,7 +32,9 @@   | ENUM_VALUE   | INPUT_OBJECT   | INPUT_FIELD_DEFINITION-  deriving (Generic)+  deriving (Show, Generic, FromJSON)  instance GQLType DirectiveLocation where+  type KIND DirectiveLocation = ENUM   __typeName = const "__DirectiveLocation"+  __typeVisibility = const False
src/Data/Morpheus/Schema/EnumValue.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -8,22 +9,23 @@   , isEnumOf   ) where -import           Data.Morpheus.Kind          (KIND, OBJECT)-import           Data.Morpheus.Types.GQLType (GQLType (__typeName))+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 -type instance KIND EnumValue = OBJECT- 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 (Generic)+  } deriving (Show, Generic, FromJSON)  createEnumValue :: Text -> EnumValue createEnumValue enumName =
src/Data/Morpheus/Schema/Field.hs view
@@ -4,18 +4,19 @@  module Data.Morpheus.Schema.Field where -import           Data.Morpheus.Kind                 (KIND, OBJECT)+import           Data.Aeson+import           Data.Morpheus.Kind                 (OBJECT) import           Data.Morpheus.Schema.InputValue    (InputValue)-import           Data.Morpheus.Types.GQLType        (GQLType (__typeName))+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 -type instance KIND (Field a) = OBJECT- instance Typeable a => GQLType (Field a) where+  type KIND (Field a) = OBJECT   __typeName = const "__Field"+  __typeVisibility = const False  data Field t = Field   { name              :: Text@@ -24,7 +25,14 @@   , type'             :: t   , isDeprecated      :: Bool   , deprecationReason :: Maybe Text-  } deriving (Generic)+  } 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 =
src/Data/Morpheus/Schema/InputValue.hs view
@@ -8,23 +8,29 @@   , createInputValueWith   ) where -import           Data.Morpheus.Kind          (KIND, OBJECT)-import           Data.Morpheus.Types.GQLType (GQLType (__typeName))+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 -type instance KIND (InputValue a) = OBJECT- 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 (Generic)+  } 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 =
src/Data/Morpheus/Schema/Internal/RenderIntrospection.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators     #-} @@ -15,36 +16,41 @@ import           Data.Morpheus.Schema.Type         (Type (..)) import           Data.Morpheus.Schema.TypeKind     (TypeKind (..)) import           Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataInputField, DataInputObject,-                                                    DataLeaf (..), DataOutputField, DataOutputObject, DataType (..),-                                                    DataTypeKind (..), DataTypeWrapper (..), DataUnion)+                                                    DataLeaf (..), DataOutputField, DataType (..), DataTypeKind (..),+                                                    DataTypeLib, DataTypeWrapper (..), DataUnion, kindOf,+                                                    lookupDataType) import           Data.Text                         (Text) -renderType :: (Text, DataFullType) -> Type-renderType (name', Leaf leaf')           = typeFromLeaf (name', leaf')-renderType (name', InputObject iObject') = typeFromInputObject (name', iObject')-renderType (name', OutputObject object') = typeFromObject (name', object')-renderType (name', Union union')         = typeFromUnion (name', union')- type InputValue = IN.InputValue Type +type Result a = DataTypeLib -> Either String a+ type Field = F.Field Type -inputValueFromArg :: (Text, DataInputField) -> InputValue-inputValueFromArg (key', input') = IN.createInputValueWith key' (createInputObjectType input')+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 -createInputObjectType :: DataInputField -> Type-createInputObjectType field' =-  wrap field' $ createType (renderTypeKind $ fieldKind field') (fieldType field') "" $ Just []- wrap :: DataField a -> Type -> Type wrap field' = wrapRec (fieldTypeWrappers field') @@ -55,17 +61,25 @@ wrapByTypeWrapper ListType    = wrapAs LIST wrapByTypeWrapper NonNullType = wrapAs NON_NULL -fieldFromObjectField :: (Text, DataOutputField) -> Field-fieldFromObjectField (key', field'@DataField {fieldType = type', fieldKind = kind', fieldArgs = args'}) =-  F.createFieldWith-    key'-    (wrap field' $ createType (renderTypeKind kind') type' "" $ Just [])-    (map inputValueFromArg args')+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', LeafScalar DataType {typeDescription = desc'}) = createLeafType SCALAR key' desc' Nothing-typeFromLeaf (key', LeafEnum DataType {typeDescription = desc', typeData = tags'}) =-  createLeafType ENUM key' desc' (Just $ map createEnumValue tags')+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' =@@ -82,7 +96,9 @@     }  typeFromUnion :: (Text, DataUnion) -> Type-typeFromUnion (name', DataType {typeData = fields', typeDescription = description'}) =+typeFromUnion (name', DataType { typeData = fields'+                               , typeDescription = description'+                               }) =   Type     { kind = UNION     , name = Just name'@@ -90,18 +106,33 @@     , fields = const $ return Nothing     , ofType = Nothing     , interfaces = Nothing-    , possibleTypes = Just (map (\x -> createObjectType (fieldType x) "" $ Just []) fields')+    , possibleTypes =+        Just (map (\x -> createObjectType (fieldType x) "" $ Just []) fields')     , enumValues = const $ return Nothing     , inputFields = Nothing     } -typeFromObject :: (Text, DataOutputObject) -> Type-typeFromObject (key', DataType {typeData = fields', typeDescription = description'}) =-  createObjectType key' description' (Just $ map fieldFromObjectField $ filter (not . fieldHidden . snd) fields')+inputValueFromArg :: (Text, DataInputField) -> Result InputValue+inputValueFromArg (key, input) =+  fmap (IN.createInputValueWith key) . createInputObjectType input -typeFromInputObject :: (Text, DataInputObject) -> Type-typeFromInputObject (key', DataType {typeData = fields', typeDescription = description'}) =-  createInputObject key' description' (map inputValueFromArg fields')+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' =
+ src/Data/Morpheus/Schema/JSONType.hs view
@@ -0,0 +1,46 @@+{-# 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
@@ -11,35 +11,43 @@   , Type   ) where -import           Data.Morpheus.Kind                                (KIND, OBJECT)+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 (__typeName))+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) -type instance KIND Schema = OBJECT- instance GQLType Schema where+  type KIND Schema = OBJECT   __typeName = const "__Schema"+  __typeVisibility = const False  data Schema = Schema   { types            :: [Type]   , queryType        :: Type   , mutationType     :: Maybe Type   , subscriptionType :: Maybe Type-  , directives       :: [Directive]+  , directives       :: [Directive Type]   } deriving (Generic)  convertTypes :: DataTypeLib -> [Type]-convertTypes lib' = map renderType (allDataTypes lib')+convertTypes lib =+  case traverse (`renderType` lib) (allDataTypes lib) of+    Left _  -> []+    Right x -> x  buildSchemaLinkType :: (Text, DataOutputObject) -> Type buildSchemaLinkType (key', _) = createObjectType key' "" $ Just []  findType :: Text -> DataTypeLib -> Maybe Type-findType name lib = renderType . (name, ) <$> lookup name (allDataTypes lib)+findType name lib = (name, ) <$> lookup name (allDataTypes lib) >>= renderT+  where+    renderT i =+      case renderType i lib of+        Left _  -> Nothing+        Right x -> Just x  initSchema :: DataTypeLib -> Schema initSchema types' =
src/Data/Morpheus/Schema/SchemaAPI.hs view
@@ -5,19 +5,20 @@  module Data.Morpheus.Schema.SchemaAPI   ( hiddenRootFields-  , schemaTypes+  , defaultTypes   , schemaAPI   ) where  import           Data.Proxy-import           Data.Text                              (Text)+import           Data.Text                                 (Text) import           GHC.Generics  -- MORPHEUS-import           Data.Morpheus.Resolve.Generics.TypeRep (ObjectRep (..), TypeUpdater)-import           Data.Morpheus.Resolve.Introspect       (introspectOutputType)-import           Data.Morpheus.Schema.Schema            (Schema, Type, findType, initSchema)-import           Data.Morpheus.Types.Internal.Data      (DataField (..), DataOutputField, DataTypeLib (..))+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 (..))  newtype TypeArgs = TypeArgs   { name :: Text@@ -34,8 +35,17 @@ hiddenRootFields :: [(Text, DataOutputField)] hiddenRootFields = map (hideFields . fst) $ objectFieldTypes $ Proxy @(Rep SchemaAPI) -schemaTypes :: TypeUpdater-schemaTypes = introspectOutputType (Proxy @Schema)+defaultTypes :: TypeUpdater+defaultTypes =+  flip+    resolveTypes+    [ introspectOutputType (Proxy @Bool)+    , introspectOutputType (Proxy @Int)+    , introspectOutputType (Proxy @Float)+    , introspectOutputType (Proxy @Text)+    , introspectOutputType (Proxy @ID)+    , introspectOutputType (Proxy @Schema)+    ]  schemaAPI :: DataTypeLib -> SchemaAPI schemaAPI lib = SchemaAPI {__type = \TypeArgs {name} -> return $ findType name lib, __schema = initSchema lib}
src/Data/Morpheus/Schema/Type.hs view
@@ -8,32 +8,36 @@   , DeprecationArgs(..)   ) where -import           Data.Morpheus.Kind              (KIND, OBJECT)+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 (__typeName))+import           Data.Morpheus.Types.GQLType     (GQLType (KIND, __typeName, __typeVisibility)) import           Data.Text                       (Text) import           GHC.Generics                    (Generic) -type instance KIND Type = OBJECT- 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)+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)+newtype DeprecationArgs =+  DeprecationArgs+    { includeDeprecated :: Maybe Bool+    }+  deriving (Generic)
src/Data/Morpheus/Schema/TypeKind.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -6,14 +7,15 @@   ( TypeKind(..)   ) where -import           Data.Morpheus.Kind          (ENUM, KIND)-import           Data.Morpheus.Types.GQLType (GQLType (__typeName))+import           Data.Aeson                  (FromJSON (..))+import           Data.Morpheus.Kind          (ENUM)+import           Data.Morpheus.Types.GQLType (GQLType (KIND, __typeName, __typeVisibility)) import           GHC.Generics -type instance KIND TypeKind = ENUM- instance GQLType TypeKind where+  type KIND TypeKind = ENUM   __typeName = const "__TypeKind"+  __typeVisibility = const False  data TypeKind   = SCALAR@@ -24,4 +26,4 @@   | INPUT_OBJECT   | LIST   | NON_NULL-  deriving (Eq, Generic, Show)+  deriving (Eq, Generic, FromJSON, Show)
src/Data/Morpheus/Server.hs view
@@ -1,62 +1,76 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- |  GraphQL Wai Server Applications module Data.Morpheus.Server   ( gqlSocketApp   , initGQLState   , GQLState-  , GQLAPI   ) where -import           Control.Exception                      (finally)-import           Control.Monad                          (forever)-import           Data.ByteString.Lazy.Char8             (ByteString)-import           Data.Morpheus.Server.Apollo            (ApolloSubscription (..), apolloProtocol, parseApolloRequest)-import           Data.Morpheus.Server.ClientRegister    (GQLState, addClientSubscription, connectClient,-                                                         disconnectClient, initGQLState, publishUpdates,-                                                         removeClientSubscription)-import           Data.Morpheus.Types                    (GQLRequest (..))-import           Data.Morpheus.Types.Internal.WebSocket (GQLClient (..), OutputAction (..))-import           Network.WebSockets                     (ServerApp, acceptRequestWith, forkPingThread, receiveData,-                                                         sendTextData)---- | statefull GraphQL interpreter-type GQLAPI = GQLRequest -> IO (OutputAction IO ByteString)+import           Control.Exception                                   (finally)+import           Control.Monad                                       (forever)+import           Data.Text                                           (Text)+import           Network.WebSockets                                  (ServerApp, acceptRequestWith, forkPingThread,+                                                                      pendingRequest, receiveData, sendTextData) -handleGQLResponse :: GQLClient -> GQLState -> Int -> OutputAction IO ByteString -> IO ()-handleGQLResponse GQLClient {clientConnection = connection', clientID = clientId'} state sessionId' msg =-  case msg of-    PublishMutation { mutationChannels = channels'-                    , currentSubscriptionStateResolver = resolver'-                    , mutationResponse = response'-                    } -> sendTextData connection' response' >> publishUpdates channels' resolver' state-    InitSubscription {subscriptionQuery = selection', subscriptionChannels = channels'} ->-      addClientSubscription clientId' selection' channels' sessionId' state-    NoEffect response' -> sendTextData connection' response'+-- MORPHEUS+import           Data.Morpheus.Execution.Server.Resolve              (RootResCon, streamResolver)+import           Data.Morpheus.Execution.Subscription.Apollo         (SubAction (..), acceptApolloSubProtocol,+                                                                      apolloFormat, toApolloResponse)+import           Data.Morpheus.Execution.Subscription.ClientRegister (GQLState, addClientSubscription, connectClient,+                                                                      disconnectClient, initGQLState, publishUpdates,+                                                                      removeClientSubscription)+import           Data.Morpheus.Types.Internal.Stream                 (ResponseEvent (..), ResponseStream, closeStream)+import           Data.Morpheus.Types.Internal.WebSocket              (GQLClient (..))+import           Data.Morpheus.Types.IO                              (GQLResponse (..))+import           Data.Morpheus.Types.Resolver                        (GQLRootResolver (..)) -queryHandler :: GQLAPI -> GQLClient -> GQLState -> IO ()-queryHandler interpreter' client'@GQLClient {clientConnection = connection', clientID = id'} state =-  forever handleRequest+handleSubscription ::+     Eq e+  => GQLClient IO e c+  -> GQLState IO e c+  -> Text+  -> ResponseStream IO e c GQLResponse+  -> IO ()+handleSubscription GQLClient {clientConnection, clientID} state sessionId stream = do+  (actions, response) <- closeStream stream+  case response of+    Data _ -> mapM_ execute actions+    Errors _ ->+      sendTextData clientConnection (toApolloResponse sessionId response)   where-    handleRequest = do-      msg <- receiveData connection'-      case parseApolloRequest msg of-        Left x -> print x-        Right ApolloSubscription {apolloType = "subscription_end", apolloId = Just sid'} ->-          removeClientSubscription id' sid' state-        Right ApolloSubscription { apolloType = "subscription_start"-                                 , apolloId = Just sid'-                                 , apolloQuery = Just query'-                                 , apolloOperationName = name'-                                 , apolloVariables = variables'-                                 } -> interpreter' request >>= handleGQLResponse client' state sid'-          where request = GQLRequest {query = query', operationName = name', variables = variables'}-        Right _ -> return ()+    execute (Publish pub)   = publishUpdates state pub+    execute (Subscribe sub) = addClientSubscription clientID sub sessionId state --- | Wai Websocket Server App for GraphQL subscriptions-gqlSocketApp :: GQLAPI -> GQLState -> ServerApp-gqlSocketApp interpreter' state pending = do-  connection' <- acceptRequestWith pending apolloProtocol-  forkPingThread connection' 30-  client' <- connectClient connection' state-  finally (queryHandler interpreter' client' state) (disconnectClient client' state)+-- | Wai WebSocket Server App for GraphQL subscriptions+gqlSocketApp ::+     RootResCon IO e c que mut sub+  => GQLRootResolver IO e c que mut sub+  -> GQLState IO e c+  -> ServerApp+gqlSocketApp gqlRoot state pending = do+  connection <-+    acceptRequestWith pending $ acceptApolloSubProtocol (pendingRequest pending)+  forkPingThread connection 30+  client <- connectClient connection state+  finally (queryHandler client) (disconnectClient client state)+  where+    queryHandler client = forever handleRequest+      where+        handleRequest =+          receiveData (clientConnection client) >>=+          resolveMessage . apolloFormat+          where+            resolveMessage (SubError x) = print x+            resolveMessage (AddSub sessionId request) =+              handleSubscription+                client+                state+                sessionId+                (streamResolver gqlRoot request)+            resolveMessage (RemoveSub sessionId) =+              removeClientSubscription (clientID client) sessionId state
− src/Data/Morpheus/Server/Apollo.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Server.Apollo-  ( ApolloSubscription(..)-  , apolloProtocol-  , toApolloResponse-  , parseApolloRequest-  ) where--import           Data.Aeson                         (FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode,-                                                     pairs, withObject, (.:), (.:?), (.=))-import           Data.ByteString.Lazy.Char8         (ByteString)-import           Data.Map                           (Map)-import qualified Data.Morpheus.Types.Internal.Value as V (Value)-import           Data.Morpheus.Types.IO             (GQLResponse)-import           Data.Semigroup                     ((<>))-import           Data.Text                          (Text)-import           GHC.Generics                       (Generic)-import           Network.WebSockets                 (AcceptRequest (..))--data ApolloSubscription a = ApolloSubscription-  { apolloId            :: Maybe Int-  , apolloType          :: Text-  , apolloPayload       :: Maybe a-  , apolloQuery         :: Maybe Text-  , apolloOperationName :: Maybe Text-  , apolloVariables     :: Maybe (Map Text V.Value)-  } deriving (Generic)--instance FromJSON (ApolloSubscription Value) where-  parseJSON = withObject "ApolloSubscription" objectParser-    where-      objectParser o =-        ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload" <*> o .:? "query" <*>-        o .:? "operationName" <*>-        o .:? "variables"--instance ToJSON (ApolloSubscription GQLResponse) where-  toEncoding (ApolloSubscription id' type' payload' query' operationName' variables') =-    pairs $-    "id" .= id' <> "type" .= type' <> "payload" .= payload' <> "query" .= query' <> "operationName" .= operationName' <>-    "variables" .=-    variables'--apolloProtocol :: AcceptRequest-apolloProtocol = AcceptRequest (Just "graphql-subscriptions") []--toApolloResponse :: Int -> GQLResponse -> ByteString-toApolloResponse sid' val' =-  encode $ ApolloSubscription (Just sid') "subscription_data" (Just val') Nothing Nothing Nothing--parseApolloRequest :: ByteString -> Either String (ApolloSubscription Value)-parseApolloRequest = eitherDecode
− src/Data/Morpheus/Server/ClientRegister.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Server.ClientRegister-  ( ClientRegister-  , GQLState-  , initGQLState-  , connectClient-  , disconnectClient-  , updateClientByID-  , publishUpdates-  , addClientSubscription-  , removeClientSubscription-  ) where--import           Control.Concurrent                         (MVar, modifyMVar, modifyMVar_, newMVar, readMVar)-import           Control.Monad                              (forM_)-import           Data.List                                  (intersect)-import           Data.Morpheus.Server.Apollo                (toApolloResponse)-import           Data.Morpheus.Types.Internal.AST.Selection (SelectionSet)-import           Data.Morpheus.Types.Internal.WebSocket     (Channel, ClientID, ClientSession (..), GQLClient (..))-import           Data.Morpheus.Types.IO                     (GQLResponse (..))-import           Data.Text                                  (Text)-import           Data.UUID.V4                               (nextRandom)-import           Network.WebSockets                         (Connection, sendTextData)--type ClientRegister = [(ClientID, GQLClient)]---- | shared GraphQL state between __websocket__ and __http__ server,--- stores information about subscriptions-type GQLState = MVar ClientRegister -- SharedState---- | initializes empty GraphQL state-initGQLState :: IO GQLState-initGQLState = newMVar []--connectClient :: Connection -> GQLState -> IO GQLClient-connectClient clientConnection varState' = do-  client' <- newClient-  modifyMVar_ varState' (addClient client')-  return (snd client')-  where-    newClient = do-      clientID <- nextRandom-      return (clientID, GQLClient {clientID, clientConnection, clientSessions = []})-    addClient client' state' = return (client' : state')--disconnectClient :: GQLClient -> GQLState -> IO ClientRegister-disconnectClient client state = modifyMVar state removeUser-  where-    removeUser state' =-      let s' = removeClient state'-       in return (s', s')-    removeClient :: ClientRegister -> ClientRegister-    removeClient = filter ((/= clientID client) . fst)--updateClientByID :: ClientID -> (GQLClient -> GQLClient) -> MVar ClientRegister -> IO ()-updateClientByID id' updateFunc state = modifyMVar_ state (return . map updateClient)-  where-    updateClient (key', client')-      | key' == id' = (key', updateFunc client')-    updateClient state' = state'--publishUpdates :: [Channel] -> (SelectionSet -> IO GQLResponse) -> GQLState -> IO ()-publishUpdates channels resolver' state = do-  state' <- readMVar state-  forM_ state' sendMessage-  where-    sendMessage (_, GQLClient {clientSessions = []}) = return ()-    sendMessage (_, GQLClient {clientSessions, clientConnection}) = mapM_ __send (filterByChannels clientSessions)-      where-        __send ClientSession {sessionQuerySelection, sessionId} =-          resolver' sessionQuerySelection >>= sendTextData clientConnection . toApolloResponse sessionId-        filterByChannels :: [ClientSession] -> [ClientSession]-        filterByChannels = filter (([] /=) . intersect channels . sessionChannels)--removeClientSubscription :: ClientID -> Int -> GQLState -> IO ()-removeClientSubscription id' sid' = updateClientByID id' stopSubscription-  where-    stopSubscription client' = client' {clientSessions = filter ((sid' /=) . sessionId) (clientSessions client')}--addClientSubscription :: ClientID -> SelectionSet -> [Text] -> Int -> GQLState -> IO ()-addClientSubscription id' sessionQuerySelection sessionChannels sessionId = updateClientByID id' startSubscription-  where-    startSubscription client' =-      client'-        {clientSessions = ClientSession {sessionId, sessionChannels, sessionQuerySelection} : clientSessions client'}
src/Data/Morpheus/Types.hs view
@@ -1,14 +1,17 @@ -- | GQL Types module Data.Morpheus.Types-  ( gqlResolver-  , gqlEffectResolver-  , liftEffectResolver+  ( resolver+  , mutResolver+  , toMutResolver   -- Resolver Monad+  , IORes+  , IOMutRes+  , IOSubRes   , Resolver-  , ResM-  , EffectM+  , SubRootRes+  , Event(..)   -- Type Classes-  , GQLType(description)+  , GQLType(KIND, description)   , GQLScalar(parseValue, serialize)   -- Values   , GQLRequest(..)@@ -19,9 +22,15 @@   ) where  import           Data.Morpheus.Types.GQLScalar      (GQLScalar (parseValue, serialize))-import           Data.Morpheus.Types.GQLType        (GQLType (description))+import           Data.Morpheus.Types.GQLType        (GQLType (KIND, description)) import           Data.Morpheus.Types.ID             (ID (..)) import           Data.Morpheus.Types.Internal.Value (ScalarValue (..)) import           Data.Morpheus.Types.IO             (GQLRequest (..), GQLResponse (..))-import           Data.Morpheus.Types.Resolver       (EffectM, GQLRootResolver (..), ResM, Resolver, gqlEffectResolver,-                                                     gqlResolver, liftEffectResolver)+import           Data.Morpheus.Types.Resolver       (Event (..), GQLRootResolver (..), MutResolver, Resolver,+                                                     SubResolver, SubRootRes, mutResolver, resolver, toMutResolver)++type IORes = Resolver IO++type IOMutRes e c = MutResolver IO e c++type IOSubRes e c a = SubResolver IO e c a
src/Data/Morpheus/Types/Custom.hs view
@@ -11,38 +11,34 @@   , mapKindFromList   ) where -import           GHC.Generics       (Generic)---- MORPHEUS-import           Data.Morpheus.Kind (KIND, OBJECT)--type instance KIND (Pair k v) = OBJECT--data Pair k v = Pair-  { key   :: k-  , value :: v-  } deriving (Generic)+import           GHC.Generics (Generic) -newtype MapArgs k = MapArgs-  { oneOf :: Maybe [k]-  } deriving (Generic)+data Pair k v =+  Pair+    { key   :: k+    , value :: v+    }+  deriving (Generic) -type instance KIND (MapKind k v m) = OBJECT+newtype MapArgs k =+  MapArgs+    { oneOf :: Maybe [k]+    }+  deriving (Generic) -data MapKind k v m = MapKind-  { size   :: Int-  , keys   :: () -> m [k]-  , values :: MapArgs k -> m [v]-  , pairs  :: MapArgs k -> m [Pair k v]-  } deriving (Generic)+data MapKind k v m =+  MapKind+    { size  :: Int+    , pairs :: MapArgs k -> m [Pair k v]+    }+  deriving (Generic)  mapKindFromList :: (Eq k, Monad m) => [(k, v)] -> MapKind k v m mapKindFromList inputPairs =-  MapKind {size = length inputPairs, keys = resolveKeys, values = resolveValues, pairs = resolvePairs}+  MapKind {size = length inputPairs, pairs = resolvePairs}   where-    filterBy MapArgs {oneOf = Just list} = filter ((`elem` list) . fst) inputPairs-    filterBy _                           = inputPairs-    resolveKeys _ = return $ map fst inputPairs-    resolveValues = return . map snd . filterBy+    filterBy MapArgs {oneOf = Just list} =+      filter ((`elem` list) . fst) inputPairs+    filterBy _ = inputPairs     resolvePairs = return . (map toGQLTuple . filterBy)     toGQLTuple (x, y) = Pair x y
src/Data/Morpheus/Types/GQLScalar.hs view
@@ -35,7 +35,6 @@   parseValue :: ScalarValue -> Either Text a   -- | serialization of haskell type into scalar value   serialize :: a -> ScalarValue-   scalarValidator :: Proxy a -> DataValidator   scalarValidator _ = DataValidator {validateValue = validator}     where
src/Data/Morpheus/Types/GQLType.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds            #-} {-# LANGUAGE DefaultSignatures    #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-}@@ -5,6 +6,7 @@ {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE TypeOperators        #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -12,6 +14,7 @@   ( GQLType(..)   ) where +import           Data.Map                          (Map) import           Data.Proxy                        (Proxy (..)) import           Data.Set                          (Set) import           Data.Text                         (Text, intercalate, pack)@@ -19,6 +22,7 @@                                                     tyConName, typeRep)  -- 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)@@ -39,7 +43,8 @@ ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon] ignoreResolver (con, _)   | con == resolverCon = []-ignoreResolver (con, args) = con : concatMap (ignoreResolver . splitTyConApp) args+ignoreResolver (con, args) =+  con : concatMap (ignoreResolver . splitTyConApp) args  -- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'. --@@ -56,46 +61,82 @@ --       description = const "your description ..." --  @ class GQLType a where+  type KIND a :: GQL_KIND   description :: Proxy a -> Text   description _ = ""+  __typeVisibility :: Proxy a -> Bool+  __typeVisibility = const True   __typeName :: Proxy a -> Text   default __typeName :: (Typeable a) =>     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 Int+instance GQLType Int where+  type KIND Int = SCALAR+  __typeVisibility = const False -instance GQLType Float+instance GQLType Float where+  type KIND Float = SCALAR+  __typeVisibility = const False  instance GQLType Text where+  type KIND Text = SCALAR   __typeName = const "String"+  __typeVisibility = const False  instance GQLType Bool where+  type KIND Bool = SCALAR   __typeName = const "Boolean"+  __typeVisibility = const False  instance GQLType a => GQLType (Maybe a) where+  type KIND (Maybe a) = WRAPPER   __typeName _ = __typeName (Proxy @a)   __typeFingerprint _ = __typeFingerprint (Proxy @a)  instance GQLType a => GQLType [a] where+  type KIND [a] = WRAPPER   __typeName _ = __typeName (Proxy @a)   __typeFingerprint _ = __typeFingerprint (Proxy @a) +instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where+  type KIND (a, b) = WRAPPER+  __typeName _ = __typeName $ Proxy @(Pair a b)+ instance GQLType a => GQLType (Set a) where+  type KIND (Set a) = WRAPPER   __typeName _ = __typeName (Proxy @a)   __typeFingerprint _ = __typeFingerprint (Proxy @a) -instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where-  __typeName _ = __typeName $ Proxy @(Pair a b)+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, GQLType a, GQLType b) => GQLType (Pair a b)+instance (Typeable a, Typeable b, Typeable m, GQLType a, GQLType b) =>+         GQLType (MapKind a b m) where+  type KIND (MapKind a b m) = OBJECT -instance (Typeable a, Typeable b, Typeable m, GQLType a, GQLType b) => GQLType (MapKind a b m)+instance (Typeable k, Typeable v) => GQLType (Map k v) where+  type KIND (Map k v) = WRAPPER++instance GQLType a => GQLType (Resolver m a) where+  type KIND (Resolver m a) = WRAPPER+  __typeName _ = __typeName (Proxy @a)+  __typeFingerprint _ = __typeFingerprint (Proxy @a)++instance GQLType b => GQLType (a -> b) where+  type KIND (a -> b) = WRAPPER+  __typeName _ = __typeName (Proxy @b)+  __typeFingerprint _ = __typeFingerprint (Proxy @b)
src/Data/Morpheus/Types/ID.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -7,21 +6,25 @@   ( ID(..)   ) where -import           Data.Morpheus.Kind                 (KIND, SCALAR)+import           Data.Morpheus.Kind                 (SCALAR) import           Data.Morpheus.Types.GQLScalar      (GQLScalar (..))-import           Data.Morpheus.Types.GQLType        (GQLType)+import           Data.Morpheus.Types.GQLType        (GQLType (KIND, __typeVisibility)) import           Data.Morpheus.Types.Internal.Value (ScalarValue (..)) import           Data.Text                          (Text, pack) import           GHC.Generics                       (Generic) -type instance KIND ID = SCALAR- -- | default GraphQL type, -- parses only 'String' and 'Int' values, -- serialized always as 'String'-newtype ID = ID-  { unpackID :: Text-  } deriving (Generic, GQLType)+newtype ID =+  ID+    { unpackID :: Text+    }+  deriving (Generic)++instance GQLType ID where+  type KIND ID = SCALAR+  __typeVisibility _ = False  instance GQLScalar ID where   parseValue (Int x)    = return (ID $ pack $ show x)
src/Data/Morpheus/Types/IO.hs view
@@ -5,10 +5,11 @@ module Data.Morpheus.Types.IO   ( GQLRequest(..)   , GQLResponse(..)+  , JSONResponse(..)   ) where -import           Data.Aeson                              (FromJSON (..), ToJSON (..), pairs, (.=))-import           Data.Map                                (Map)+import           Data.Aeson                              (FromJSON (..), ToJSON (..), pairs, withObject, (.:?), (.=))+import qualified Data.Aeson                              as Aeson (Value (..)) import           GHC.Generics                            (Generic)  -- MORPHEUS@@ -16,12 +17,22 @@ import           Data.Morpheus.Types.Internal.Validation (JSONError (..)) import           Data.Morpheus.Types.Internal.Value      (Value) +instance FromJSON a => FromJSON (JSONResponse a) where+  parseJSON = withObject "JSONResponse" objectParser+    where+      objectParser o = JSONResponse <$> o .:? "data" <*> o .:? "errors"++data JSONResponse a = JSONResponse+  { responseData   :: Maybe a+  , responseErrors :: Maybe [JSONError]+  } deriving (Generic, Show, ToJSON)+ -- | GraphQL HTTP Request Body data GQLRequest = GQLRequest   { query         :: Key   , operationName :: Maybe Key-  , variables     :: Maybe (Map Key Value)-  } deriving (Show, Generic, FromJSON)+  , variables     :: Maybe Aeson.Value+  } deriving (Show, Generic, FromJSON, ToJSON)  -- | GraphQL Response data GQLResponse
+ src/Data/Morpheus/Types/Internal/AST/Operation.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DeriveLift        #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell   #-}++module Data.Morpheus.Types.Internal.AST.Operation+  ( Operation(..)+  , Variable(..)+  , OperationKind(..)+  , ValidOperation+  , RawOperation+  , VariableDefinitions+  , ValidVariables+  ) where++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.TH               (apply, liftText, liftTextMap)+import           Data.Morpheus.Types.Internal.Value            (Value)+import           Language.Haskell.TH.Syntax                    (Lift (..))++type VariableDefinitions = Collection (Variable ())++type ValidVariables = Collection (Variable Value)++type ValidOperation = Operation Arguments SelectionSet++type RawOperation = Operation VariableDefinitions RawSelectionSet++data OperationKind+  = QUERY+  | MUTATION+  | SUBSCRIPTION+  deriving (Show, Lift)++data Operation args sel = Operation+  { operationName      :: Key+  , operationKind      :: OperationKind+  , operationArgs      :: args+  , operationSelection :: sel+  , operationPosition  :: Position+  } deriving (Show)++instance Lift (Operation VariableDefinitions RawSelectionSet) where+  lift (Operation name kind args sel pos) =+    apply 'Operation [liftText name, lift kind, liftTextMap args, liftTextMap sel, lift pos]++data Variable a = Variable+  { variableType         :: Key+  , isVariableRequired   :: Bool+  , variableTypeWrappers :: [DataTypeWrapper]+  , variablePosition     :: Position+  , variableValue        :: a+  } deriving (Show)++instance Lift (Variable ()) where+  lift (Variable t ir w p v) = apply 'Variable [liftText t, lift ir, lift w, lift p, lift v]
− src/Data/Morpheus/Types/Internal/AST/Operator.hs 
@@ -1,50 +0,0 @@-module Data.Morpheus.Types.Internal.AST.Operator-  ( Operator(..)-  , ValidOperator-  , RawOperator-  , Variable(..)-  , VariableDefinitions-  , Operator'(..)-  , ValidOperator'-  , RawOperator'-  , ValidVariables-  ) where--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.Value            (Value)--type ValidOperator = Operator Arguments SelectionSet--type ValidOperator' = Operator' Arguments SelectionSet--data Variable a = Variable-  { variableType         :: Key-  , isVariableRequired   :: Bool-  , variableTypeWrappers :: [DataTypeWrapper]-  , variablePosition     :: Position-  , variableValue        :: a-  } deriving (Show)--type VariableDefinitions = Collection (Variable ())--type ValidVariables = Collection (Variable Value)--type RawOperator = Operator VariableDefinitions RawSelectionSet--type RawOperator' = Operator' VariableDefinitions RawSelectionSet--data Operator' args sel = Operator'-  { operatorName      :: Key-  , operatorArgs      :: args-  , operatorSelection :: sel-  , operatorPosition  :: Position-  } deriving (Show)--data Operator args sel-  = Query (Operator' args sel)-  | Mutation (Operator' args sel)-  | Subscription (Operator' args sel)-  deriving (Show)
src/Data/Morpheus/Types/Internal/AST/RawSelection.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE DeriveLift        #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell   #-}+ module Data.Morpheus.Types.Internal.AST.RawSelection   ( Reference(..)   , Argument(..)@@ -10,37 +14,55 @@   , RawSelectionSet   ) where -import           Data.Map                                   (Map) import           Data.Morpheus.Types.Internal.AST.Selection (Argument (..)) import           Data.Morpheus.Types.Internal.Base          (Collection, Key, Position)+import           Data.Morpheus.Types.Internal.TH            (apply, liftText, liftTextMap, liftTextTuple)+import           Language.Haskell.TH.Syntax                 (Lift (..))  data Reference = Reference   { referenceName     :: Key   , referencePosition :: Position   } deriving (Show) +instance Lift Reference where+  lift (Reference name pos) = apply 'Reference [liftText name, lift pos]+ data Fragment = Fragment   { fragmentType      :: Key   , fragmentPosition  :: Position   , fragmentSelection :: RawSelectionSet   } deriving (Show) +instance Lift Fragment where+  lift (Fragment t p sel) = apply 'Fragment [liftText t, lift p, liftTextMap sel]+ data RawSelection' a = RawSelection'   { rawSelectionArguments :: RawArguments   , rawSelectionPosition  :: Position   , rawSelectionRec       :: a   } deriving (Show) -type FragmentLib = Map Key Fragment+instance Lift a => Lift (RawSelection' a) where+  lift (RawSelection' t p sel) = apply 'RawSelection' [liftTextMap t, lift p, lift sel] +type FragmentLib = [(Key, Fragment)]+ data RawArgument   = VariableReference Reference   | RawArgument Argument-  deriving (Show)+  deriving (Show, Lift)  type RawArguments = Collection RawArgument  type RawSelectionSet = Collection RawSelection++instance Lift RawSelection where+  lift (RawSelectionSet (RawSelection' t p sel)) =+    apply 'RawSelectionSet [apply 'RawSelection' [liftTextMap t, lift p, liftTextMap sel]]+  lift (RawSelectionField p) = apply 'RawSelectionField [lift p]+  lift (InlineFragment f) = apply 'InlineFragment [lift f]+  lift (Spread f) = apply 'Spread [lift f]+  lift (RawAlias p s) = apply 'RawAlias [lift p, liftTextTuple s]  data RawSelection   = RawSelectionSet (RawSelection' RawSelectionSet)
src/Data/Morpheus/Types/Internal/AST/Selection.hs view
@@ -1,18 +1,28 @@+{-# LANGUAGE DeriveLift #-}+ module Data.Morpheus.Types.Internal.AST.Selection   ( Argument(..)   , Arguments   , SelectionSet   , Selection(..)   , SelectionRec(..)+  , ArgumentOrigin(..)   ) where  import           Data.Morpheus.Types.Internal.Base  (Collection, Key, Position) import           Data.Morpheus.Types.Internal.Value (Value)+import           Language.Haskell.TH.Syntax         (Lift (..)) +data ArgumentOrigin+  = VARIABLE+  | INLINE+  deriving (Show, Lift)+ data Argument = Argument   { argumentValue    :: Value+  , argumentOrigin   :: ArgumentOrigin   , argumentPosition :: Position-  } deriving (Show)+  } deriving (Show, Lift)  type Arguments = Collection Argument
src/Data/Morpheus/Types/Internal/Base.hs view
@@ -1,16 +1,28 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE DeriveLift     #-}+ module Data.Morpheus.Types.Internal.Base   ( Key   , Collection   , Position   , EnhancedKey(..)+  , Location(..)   , enhanceKeyWithNull   ) where -import           Data.Text       (Text)-import           Text.Megaparsec (SourcePos, initialPos)+import           Data.Aeson                 (FromJSON, ToJSON)+import           Data.Text                  (Text)+import           GHC.Generics               (Generic)+import           Language.Haskell.TH.Syntax (Lift) -type Position = SourcePos+type Position = Location +data Location = Location+  { line   :: Int+  , column :: Int+  } deriving (Show, Generic, FromJSON, ToJSON, Lift)+ type Key = Text  type Collection a = [(Key, a)]@@ -24,5 +36,8 @@ instance Eq EnhancedKey where   (EnhancedKey id1 _) == (EnhancedKey id2 _) = id1 == id2 +instance Ord EnhancedKey where+  compare (EnhancedKey x _) (EnhancedKey y _) = compare x y+ enhanceKeyWithNull :: Key -> EnhancedKey-enhanceKeyWithNull text = EnhancedKey {uid = text, location = initialPos ""}+enhanceKeyWithNull text = EnhancedKey {uid = text, location = Location 0 0}
src/Data/Morpheus/Types/Internal/Data.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveLift        #-} {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Types.Internal.Data@@ -31,12 +32,15 @@   , showFullAstType   , isFieldNullable   , allDataTypes+  , lookupDataType+  , kindOf   ) where  import           Data.Morpheus.Types.Internal.Value (Value (..)) import           Data.Text                          (Text) import qualified Data.Text                          as T (concat) import           GHC.Fingerprint.Type               (Fingerprint)+import           Language.Haskell.TH.Syntax         (Lift)  type Key = Text @@ -48,7 +52,8 @@   | KindInputObject   | KindList   | KindNonNull-  deriving (Eq, Show)+  | KindInputUnion+  deriving (Eq, Show, Lift)  data DataFingerprint   = SystemFingerprint Text@@ -89,12 +94,11 @@ data DataTypeWrapper   = ListType   | NonNullType-  deriving (Show)+  deriving (Show, Lift)  data DataField a = DataField   { fieldArgs         :: a   , fieldName         :: Text-  , fieldKind         :: DataTypeKind   , fieldType         :: Text   , fieldTypeWrappers :: [DataTypeWrapper]   , fieldHidden       :: Bool@@ -108,11 +112,13 @@   { typeName        :: Text   , typeFingerprint :: DataFingerprint   , typeDescription :: Text+  , typeVisibility  :: Bool   , typeData        :: a   } deriving (Show)  data DataLeaf-  = LeafScalar DataScalar+  = BaseScalar DataScalar+  | CustomScalar DataScalar   | LeafEnum DataEnum   deriving (Show) @@ -120,6 +126,7 @@   = ScalarKind DataScalar   | EnumKind DataEnum   | ObjectKind (DataObject a)+  | UnionKind DataUnion   deriving (Show)  data DataFullType@@ -127,6 +134,7 @@   | InputObject DataInputObject   | OutputObject DataOutputObject   | Union DataUnion+  | InputUnion DataUnion   deriving (Show)  data DataTypeLib = DataTypeLib@@ -134,10 +142,11 @@   , inputObject  :: [(Text, DataInputObject)]   , object       :: [(Text, DataOutputObject)]   , union        :: [(Text, DataUnion)]+  , inputUnion   :: [(Text, DataUnion)]   , query        :: (Text, DataOutputObject)   , mutation     :: Maybe (Text, DataOutputObject)   , subscription :: Maybe (Text, DataOutputObject)-  }+  } deriving (Show)  showWrappedType :: [DataTypeWrapper] -> Text -> Text showWrappedType [] type'               = type'@@ -148,36 +157,62 @@ 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' =   DataTypeLib-    {leaf = [], inputObject = [], query = query', object = [], union = [], mutation = Nothing, subscription = Nothing}+    { leaf = []+    , inputObject = []+    , query = query'+    , object = []+    , union = []+    , inputUnion = []+    , mutation = Nothing+    , subscription = Nothing+    }  allDataTypes :: DataTypeLib -> [(Text, DataFullType)]-allDataTypes (DataTypeLib leaf' inputObject' object' union' query' mutation' subscription') =+allDataTypes (DataTypeLib leaf' inputObject' object' union' inputUnion' query' mutation' subscription') =   packType OutputObject query' :+  fromMaybeType mutation' +++  fromMaybeType subscription' +++  map (packType Leaf) leaf' ++   map (packType InputObject) inputObject' ++-  map (packType OutputObject) object' ++-  map (packType Leaf) leaf' ++ map (packType Union) union' ++ fromMaybeType mutation' ++ fromMaybeType subscription'+  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 (Just (key', dataType')) = [(key', OutputObject dataType')]     fromMaybeType Nothing                  = [] +lookupDataType :: Text -> DataTypeLib -> Maybe DataFullType+lookupDataType name lib = name `lookup` allDataTypes lib++kindOf :: DataFullType -> DataTypeKind+kindOf (Leaf (BaseScalar _))   = KindScalar+kindOf (Leaf (CustomScalar _)) = KindScalar+kindOf (Leaf (LeafEnum _))     = KindEnum+kindOf (InputObject _)         = KindInputObject+kindOf (OutputObject _)        = KindObject+kindOf (Union _)               = KindUnion+kindOf (InputUnion _)          = KindInputUnion+ isTypeDefined :: Text -> DataTypeLib -> Maybe DataFingerprint-isTypeDefined name_ lib' = getTypeFingerprint <$> name_ `lookup` allDataTypes lib'+isTypeDefined name lib = getTypeFingerprint <$> lookupDataType name lib   where     getTypeFingerprint :: DataFullType -> DataFingerprint-    getTypeFingerprint (Leaf (LeafScalar 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 (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'  defineType :: (Text, 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}
+ src/Data/Morpheus/Types/Internal/DataD.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveLift #-}++module Data.Morpheus.Types.Internal.DataD+  ( FieldD(..)+  , TypeD(..)+  , ConsD(..)+  , QueryD(..)+  , AppD(..)+  , GQLTypeD+  , gqlToHSWrappers+  ) 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++type GQLTypeD = (TypeD, DataTypeKind, [TypeD])++data QueryD = QueryD+  { queryText     :: String+  , queryTypes    :: [TypeD]+  , queryArgTypes :: [TypeD]+  } deriving (Show, Lift)++data FieldD = FieldD+  { fieldNameD :: String+  , fieldTypeD :: AppD String+  } deriving (Show, Lift)++data TypeD = TypeD+  { tName :: String+  , tCons :: [ConsD]+  } deriving (Show, Lift)++data ConsD = ConsD+  { cName   :: String+  , cFields :: [FieldD]+  } deriving (Show, Lift)
+ src/Data/Morpheus/Types/Internal/Stream.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE DeriveFunctor  #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies   #-}++module Data.Morpheus.Types.Internal.Stream+  ( StreamState(..)+  , ResponseEvent(..)+  , SubEvent+  , PubEvent+  , Event(..)+  -- STREAMS+  , StreamT(..)+  , SubscribeStream+  , PublishStream+  , ResponseStream+  , closeStream+  , mapS+  ) where++import           Data.Morpheus.Types.IO (GQLResponse)++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)++instance Monad m => Applicative (StreamT m c) where+  pure = StreamT . return . StreamState []+  StreamT app1 <*> StreamT app2 =+    StreamT $ do+      (StreamState effect1 func) <- app1+      (StreamState effect2 val) <- app2+      return $ StreamState (effect1 ++ effect2) (func val)++instance Monad m => Monad (StreamT m c) where+  return = pure+  (StreamT m1) >>= mFunc =+    StreamT $ do+      (StreamState e1 v1) <- m1+      (StreamState e2 v2) <- runStreamT $ mFunc v1+      return $ StreamState (e1 ++ e2) v2++type SubEvent m e c = Event e (Event e c -> m GQLResponse)++type PubEvent e c = Event e c++-- EVENTS+data ResponseEvent m e c+  = Publish (PubEvent e c)+  | Subscribe (SubEvent m e c)++-- STREAMS+type SubscribeStream m e = StreamT m [e]++type PublishStream m e c = StreamT m (PubEvent e c)++type ResponseStream m event con a = StreamT m (ResponseEvent m event con) a++-- Helper Functions+toTuple :: StreamState s a -> ([s], a)+toTuple StreamState {streamEvents, streamValue} = (streamEvents, streamValue)++closeStream :: Monad m => (StreamT m s) v -> m ([s], v)+closeStream resolver = toTuple <$> runStreamT resolver++mapS :: Monad m => (a -> b) -> StreamT m a value -> StreamT m b value+mapS func (StreamT ma) =+  StreamT $ do+    state <- ma+    return $ state {streamEvents = map func (streamEvents state)}
+ src/Data/Morpheus/Types/Internal/TH.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TemplateHaskell   #-}++module Data.Morpheus.Types.Internal.TH where++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))++liftTextTuple :: Lift a => (Text, a) -> ExpQ+liftTextTuple (name, x) = tupE [liftText name, lift x]++liftTextMap :: Lift a => [(Text, a)] -> ExpQ+liftTextMap = listE . map liftTextTuple++apply :: Name -> [Q Exp] -> Q Exp+apply n = foldl appE (conE n)
src/Data/Morpheus/Types/Internal/Validation.hs view
@@ -3,7 +3,7 @@  module Data.Morpheus.Types.Internal.Validation   ( GQLError(..)-  , ErrorLocation(..)+  , Location(..)   , GQLErrors   , JSONError(..)   , Validation@@ -14,28 +14,23 @@   ) where  import           Control.Monad.Trans.Except         (ExceptT (..))-import           Data.Aeson                         (ToJSON)-import           Data.Morpheus.Types.Internal.Base  (Position)+import           Data.Aeson                         (FromJSON, ToJSON)+import           Data.Morpheus.Types.Internal.Base  (Location (..)) import           Data.Morpheus.Types.Internal.Value (Value) import           Data.Text                          (Text) import           GHC.Generics                       (Generic)  data GQLError = GQLError   { desc      :: Text-  , positions :: [Position]+  , positions :: [Location]   } deriving (Show)  type GQLErrors = [GQLError] -data ErrorLocation = ErrorLocation-  { line   :: Int-  , column :: Int-  } deriving (Show, Generic, ToJSON)- data JSONError = JSONError   { message   :: Text-  , locations :: [ErrorLocation]-  } deriving (Show, Generic, ToJSON)+  , locations :: [Location]+  } deriving (Show, Generic, FromJSON, ToJSON)  type Validation a = Either GQLErrors a
src/Data/Morpheus/Types/Internal/Value.hs view
@@ -1,29 +1,67 @@ {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveLift        #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}  module Data.Morpheus.Types.Internal.Value   ( Value(..)   , ScalarValue(..)+  , replaceValue   , decodeScientific   , convertToJSONName   , convertToHaskellName   ) where -import qualified Data.Aeson          as A (FromJSON (..), ToJSON (..), Value (..), object, pairs, (.=))-import qualified Data.HashMap.Strict as M (toList)-import           Data.Scientific     (Scientific, floatingOrInteger)-import           Data.Semigroup      ((<>))-import           Data.Text           (Text)-import qualified Data.Vector         as V (toList)-import           GHC.Generics        (Generic)+import qualified Data.Aeson                      as A (FromJSON (..), ToJSON (..), Value (..), object, pairs, (.=))+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)+import qualified Data.Text                       as T+import qualified Data.Vector                     as V (toList)+import           GHC.Generics                    (Generic)+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax +isReserved :: Text -> Bool+isReserved "case"     = True+isReserved "class"    = True+isReserved "data"     = True+isReserved "default"  = True+isReserved "deriving" = True+isReserved "do"       = True+isReserved "else"     = True+isReserved "foreign"  = True+isReserved "if"       = True+isReserved "import"   = True+isReserved "in"       = True+isReserved "infix"    = True+isReserved "infixl"   = True+isReserved "infixr"   = True+isReserved "instance" = True+isReserved "let"      = True+isReserved "module"   = True+isReserved "newtype"  = True+isReserved "of"       = True+isReserved "then"     = True+isReserved "type"     = True+isReserved "where"    = True+isReserved "_"        = True+isReserved _          = False++{-# INLINE isReserved #-} convertToJSONName :: Text -> Text-convertToJSONName "type'" = "type"-convertToJSONName x       = x+convertToJSONName hsName+  | not (T.null hsName) && isReserved name && (T.last hsName == '\'') = name+  | otherwise = hsName+  where+    name = T.init hsName  convertToHaskellName :: Text -> Text-convertToHaskellName "type" = "type'"-convertToHaskellName x      = x+convertToHaskellName name+  | isReserved name = name <> "'"+  | otherwise = name  -- | Primitive Values for GQLScalar: 'Int', 'Float', 'String', 'Boolean'. -- for performance reason type 'Text' represents GraphQl 'String' value@@ -34,11 +72,30 @@   | Boolean Bool   deriving (Show, Generic) +instance Lift ScalarValue where+  lift (String n)  = apply 'String [liftText n]+  lift (Int n)     = apply 'Int [lift n]+  lift (Float n)   = apply 'Float [lift n]+  lift (Boolean n) = apply 'Boolean [lift n]+ instance A.ToJSON ScalarValue where-  toEncoding (Float x)   = A.toEncoding x-  toEncoding (Int x)     = A.toEncoding x-  toEncoding (Boolean x) = A.toEncoding x-  toEncoding (String x)  = A.toEncoding x+  toJSON (Float x)   = A.toJSON x+  toJSON (Int x)     = A.toJSON x+  toJSON (Boolean x) = A.toJSON x+  toJSON (String x)  = A.toJSON x++instance A.FromJSON ScalarValue where+  parseJSON (A.Bool v)   = pure $ Boolean v+  parseJSON (A.Number v) = pure $ decodeScientific v+  parseJSON (A.String v) = pure $ String v+  parseJSON notScalar    = fail $ "Expected Scalar got :" <> show notScalar++instance Lift Value where+  lift (Object ls) = apply 'Object [liftTextMap ls]+  lift (List n)    = apply 'List [lift n]+  lift (Enum n)    = apply 'Enum [liftText n]+  lift (Scalar n)  = apply 'Scalar [lift n]+  lift Null        = varE 'Null  data Value   = Object [(Text, Value)]
src/Data/Morpheus/Types/Internal/WebSocket.hs view
@@ -1,46 +1,39 @@-{-# LANGUAGE DeriveFunctor  #-} {-# LANGUAGE NamedFieldPuns #-}  module Data.Morpheus.Types.Internal.WebSocket   ( GQLClient(..)   , ClientID-  , Channel-  , OutputAction(..)   , ClientSession(..)   ) where -import           Data.Morpheus.Types.Internal.AST.Selection (SelectionSet)-import           Data.Morpheus.Types.IO                     (GQLResponse (..))-import           Data.Semigroup                             ((<>))-import           Data.Text                                  (Text)-import           Data.UUID                                  (UUID)-import           Network.WebSockets                         (Connection)+import           Data.Semigroup                      ((<>))+import           Data.Text                           (Text)+import           Data.UUID                           (UUID)+import           Network.WebSockets                  (Connection) -data OutputAction m a-  = PublishMutation { mutationChannels                 :: [Text]-                    , mutationResponse                 :: a-                    , currentSubscriptionStateResolver :: SelectionSet -> m GQLResponse }-  | InitSubscription { subscriptionChannels :: [Text]-                     , subscriptionQuery    :: SelectionSet }-  | NoEffect a-  deriving (Functor)+-- MORPHEUS+import           Data.Morpheus.Types.Internal.Stream (SubEvent)  type ClientID = UUID -type Channel = Text+data ClientSession m e c =+  ClientSession+    { sessionId           :: Text+    , sessionSubscription :: SubEvent m e c+    } -data ClientSession = ClientSession-  { sessionId             :: Int-  , sessionChannels       :: [Channel]-  , sessionQuerySelection :: SelectionSet-  } deriving (Show)+instance (Show e, Show c) => Show (ClientSession m e c) where+  show ClientSession {sessionId} =+    "GQLSession { id: " <> show sessionId <> ", sessions: " <> "" <> " }" -data GQLClient = GQLClient-  { clientID         :: ClientID-  , clientConnection :: Connection-  , clientSessions   :: [ClientSession]-  }+data GQLClient m e c =+  GQLClient+    { clientID         :: ClientID+    , clientConnection :: Connection+    , clientSessions   :: [ClientSession m e c]+    } -instance Show GQLClient where+instance (Show e, Show c) => Show (GQLClient m e c) where   show GQLClient {clientID, clientSessions} =-    "GQLClient {id:" <> show clientID <> ", sessions:" <> show clientSessions <> "}"+    "GQLClient {id:" <> show clientID <> ", sessions:" <> show clientSessions <>+    "}"
src/Data/Morpheus/Types/Resolver.hs view
@@ -1,105 +1,82 @@ {-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveFunctor         #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE InstanceSigs          #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE PolyKinds             #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-}  module Data.Morpheus.Types.Resolver   ( Pure-  , ResM-  , EffectM-  , EffectT(..)-  , Effect(..)   , Resolver+  , MutResolver+  , SubResolver+  , ResolveT+  , SubResolveT+  , MutResolveT+  , SubRootRes+  , Event(..)   , GQLRootResolver(..)-  , gqlResolver-  , gqlEffectResolver-  , liftEffectResolver-  , unpackEffect-  , unpackEffect2+  , resolver+  , mutResolver+  , toMutResolver   ) where  import           Control.Monad.Trans.Except              (ExceptT (..), runExceptT)-import           Data.Text                               (Text)  -- MORPHEUS-import           Data.Morpheus.Types.Internal.Validation (GQLErrors, ResolveT)---- | Pure Resolver without effect-type Pure = Either String---- | Monad IO resolver without GraphQL effect-type ResM = Resolver IO+--+import           Data.Morpheus.Types.Internal.Stream     (Event (..), PublishStream, StreamState (..), StreamT (..),+                                                          SubscribeStream)+import           Data.Morpheus.Types.Internal.Validation (ResolveT) --- | Monad Resolver with GraphQL effects, used for communication between mutation and subscription-type EffectM = Resolver (EffectT IO Text)+-- SubResolver m (Event [c1, c2] d) a+----------------------------------------------------------------------------------------+type MutResolveT m e c a = ResolveT (PublishStream m e c) a --- | Resolver Monad Transformer+------------------------------------------------------------------- type Resolver = ExceptT String --- | GraphQL Resolver-gqlResolver :: m (Either String a) -> Resolver m a-gqlResolver = ExceptT---- | GraphQL Root resolver, also the interpreter generates a GQL schema from it.------  'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional,---  if your schema does not supports __mutation__ or __subscription__ , you acn use __()__ for it.-data GQLRootResolver m a b c = GQLRootResolver-  { queryResolver        :: ResolveT m a-  , mutationResolver     :: ResolveT (EffectT m Text) b-  , subscriptionResolver :: ResolveT (EffectT m Text) c-  }---- | GraphQL Resolver for mutation or subscription resolver , adds effect to normal resolver-gqlEffectResolver :: Monad m => [c] -> (EffectT m c) (Either String a) -> Resolver (EffectT m c) a-gqlEffectResolver channels = ExceptT . insertEffect channels+type MutResolver m e c = Resolver (PublishStream m e c) -insertEffect :: Monad m => [c] -> EffectT m c a -> EffectT m c a-insertEffect channels EffectT {runEffectT = monadEffect} = EffectT $ effectPlus <$> monadEffect-  where-    effectPlus x = x {resultEffects = channels ++ resultEffects x}+type SubResolver m e c a = Event e (Event e c -> Resolver m a) --- | lift Normal resolver inside Effect Resolver-liftEffectResolver :: Monad m => [c] -> m (Either String a) -> Resolver (EffectT m c) a-liftEffectResolver channels = ExceptT . EffectT . fmap (Effect channels)+type SubResolveT m e c a+   = ResolveT (SubscribeStream m e) (Event e c -> ResolveT m a) -unpackEffect2 :: Monad m => ResolveT (EffectT m Text) v -> ResolveT m ([Text], v)-unpackEffect2 x = ExceptT $ unpackEffect x+type SubRootRes m e sub = Resolver (SubscribeStream m e) sub -unpackEffect :: Monad m => ResolveT (EffectT m Text) v -> m (Either GQLErrors ([Text], v))-unpackEffect resolver = do-  (Effect effects eitherValue) <- runEffectT $ runExceptT resolver-  case eitherValue of-    Left errors -> return $ Left errors-    Right value -> return $ Right (effects, value)+-------------------------------------------------------------------+-- | Pure Resolver without effect+type Pure = Either String -data Effect c v = Effect-  { resultEffects :: [c]-  , resultValue   :: v-  } deriving (Functor)+-- | GraphQL Resolver+resolver :: m (Either String a) -> Resolver m a+resolver = ExceptT --- | Monad Transformer that sums all effect Together-newtype EffectT m c v = EffectT-  { runEffectT :: m (Effect c v)-  } deriving (Functor)+toMutResolver :: Monad m => [Event e c] -> Resolver m a -> MutResolver m e c a+toMutResolver channels =+  ExceptT . StreamT . fmap (StreamState channels) . runExceptT -instance Monad m => Applicative (EffectT m c) where-  pure = EffectT . return . Effect []-  EffectT app1 <*> EffectT app2 =-    EffectT $ do-      (Effect effect1 func) <- app1-      (Effect effect2 val) <- app2-      return $ Effect (effect1 ++ effect2) (func val)+-- | 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 channels = ExceptT . StreamT . fmap effectPlus . runStreamT+  where+    effectPlus state = state {streamEvents = channels ++ streamEvents state} -instance Monad m => Monad (EffectT m c) where-  return = pure-  (EffectT m1) >>= mFunc =-    EffectT $ do-      (Effect e1 v1) <- m1-      (Effect e2 v2) <- runEffectT $ mFunc v1-      return $ Effect (e1 ++ e2) v2+-- | GraphQL Root resolver, also the interpreter generates a GQL schema from it.+--+--  'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional,+--  if your schema does not supports __mutation__ or __subscription__ , you 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+    }
src/Data/Morpheus/Types/Types.hs view
@@ -1,18 +1,25 @@+{-# LANGUAGE TemplateHaskell #-}+ module Data.Morpheus.Types.Types   ( GQLQueryRoot(..)   , Variables   ) where  import           Data.Map                                      (Map)-import           Data.Morpheus.Types.Internal.AST.Operator     (RawOperator)+import           Data.Morpheus.Types.Internal.AST.Operation    (RawOperation) import           Data.Morpheus.Types.Internal.AST.RawSelection (FragmentLib) import           Data.Morpheus.Types.Internal.Base             (Key)+import           Data.Morpheus.Types.Internal.TH               (apply, liftTextMap) import           Data.Morpheus.Types.Internal.Value            (Value)+import           Language.Haskell.TH.Syntax                    (Lift (..))  type Variables = Map Key Value  data GQLQueryRoot = GQLQueryRoot   { fragments      :: FragmentLib-  , queryBody      :: RawOperator+  , operation      :: RawOperation   , inputVariables :: [(Key, Value)]-  }+  } deriving (Show)++instance Lift GQLQueryRoot where+  lift (GQLQueryRoot f o v) = apply 'GQLQueryRoot [liftTextMap f, lift o, liftTextMap v]
src/Data/Morpheus/Validation/Arguments.hs view
@@ -10,9 +10,9 @@ import           Data.Morpheus.Error.Input                     (InputValidation, inputErrorMessage) import           Data.Morpheus.Error.Internal                  (internalUnknownTypeMessage) import           Data.Morpheus.Error.Variable                  (incompatibleVariableType, undefinedVariable)-import           Data.Morpheus.Types.Internal.AST.Operator     (ValidVariables, Variable (..))+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 (..), Arguments)+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, DataTypeWrapper (..),@@ -23,14 +23,28 @@ import           Data.Morpheus.Validation.Utils.Utils          (checkForUnknownKeys, checkNameCollision, getInputType) import           Data.Text                                     (Text) -resolveArgumentVariables :: Text -> ValidVariables -> DataOutputField -> RawArguments -> Validation Arguments-resolveArgumentVariables operatorName variables DataField {fieldName, fieldArgs} = mapM resolveVariable+resolveArgumentVariables ::+     Text+  -> ValidVariables+  -> DataOutputField+  -> RawArguments+  -> Validation Arguments+resolveArgumentVariables operatorName variables DataField {fieldName, fieldArgs} =+  mapM resolveVariable   where     resolveVariable :: (Text, RawArgument) -> Validation (Text, Argument)-    resolveVariable (key', RawArgument argument') = pure (key', argument')-    resolveVariable (key', VariableReference Reference {referenceName, referencePosition}) =-      (key', ) . (`Argument` referencePosition) <$> lookupVar+    resolveVariable (key, RawArgument argument) = pure (key, argument)+    resolveVariable (key, VariableReference Reference { referenceName+                                                      , referencePosition+                                                      }) =+      (key, ) . toArgument <$> lookupVar       where+        toArgument argumentValue =+          Argument+            { argumentValue+            , argumentOrigin = VARIABLE+            , argumentPosition = referencePosition+            }         stricter [] []                               = True         stricter (NonNullType:xs1) (NonNullType:xs2) = stricter xs1 xs2         stricter (NonNullType:xs1) xs2               = stricter xs1 xs2@@ -38,49 +52,85 @@         stricter _ _                                 = False         lookupVar =           case lookup referenceName variables of-            Nothing -> Left $ undefinedVariable operatorName referencePosition referenceName+            Nothing ->+              Left $+              undefinedVariable operatorName referencePosition referenceName             Just Variable {variableValue, variableType, variableTypeWrappers} ->-              case lookup key' fieldArgs of-                Nothing -> Left $ unknownArguments fieldName [EnhancedKey key' referencePosition]+              case lookup key fieldArgs of+                Nothing ->+                  Left $+                  unknownArguments fieldName [EnhancedKey key referencePosition]                 Just DataField {fieldType, fieldTypeWrappers} ->-                  if variableType == fieldType && stricter variableTypeWrappers fieldTypeWrappers+                  if variableType == fieldType &&+                     stricter variableTypeWrappers fieldTypeWrappers                     then return variableValue-                    else Left $ incompatibleVariableType referenceName varSignature fieldSignature referencePosition-                  where varSignature = showWrappedType variableTypeWrappers variableType-                        fieldSignature = showWrappedType fieldTypeWrappers fieldType+                    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 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 = typeName', fieldTypeWrappers = wrappers'} (key', Argument value' position') =-  getInputType typeName' lib' (internalUnknownTypeMessage typeName') >>= checkType >>-  pure (key', Argument value' position')+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' position' (validateInputValue lib' [] wrappers' type' (key', value'))+    checkType type' =+      handleInputError+        key+        argumentPosition+        (validateInputValue lib [] fieldTypeWrappers type' (key, argumentValue)) -validateArgument :: DataTypeLib -> Position -> Arguments -> (Text, DataArgument) -> Validation (Text, Argument)-validateArgument types position' requestArgs (key', arg) =-  case lookup key' requestArgs of-    Nothing                   -> handleNullable-    Just (Argument Null _)    -> handleNullable-    Just (Argument value pos) -> validateArgumentValue types arg (key', Argument value pos)+validateArgument ::+     DataTypeLib+  -> Position+  -> Arguments+  -> (Text, DataArgument)+  -> Validation (Text, Argument)+validateArgument types argumentPosition requestArgs (key, arg) =+  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)   where-    handleNullable =-      if isFieldNullable arg-        then pure (key', Argument Null position')-        else Left $ undefinedArgument (EnhancedKey key' position')+    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 (fieldKey', DataField {fieldArgs = astArgs'}) args' =-  checkForUnknownKeys enhancedKeys' fieldKeys error' >> checkNameCollision enhancedKeys' fieldKeys argumentNameCollision >>-  pure astArgs'+checkForUnknownArguments ::+     (Text, DataOutputField) -> Arguments -> Validation [(Text, DataInputField)]+checkForUnknownArguments (key, DataField {fieldArgs}) args =+  checkForUnknownKeys enhancedKeys fieldKeys argError >>+  checkNameCollision enhancedKeys argumentNameCollision >>+  pure fieldArgs   where-    error' = unknownArguments fieldKey'-    enhancedKeys' = map argToKey args'-    argToKey (key', Argument _ pos) = EnhancedKey key' pos-    fieldKeys = map fst astArgs'+    argError = unknownArguments key+    enhancedKeys = map argToKey args+    argToKey (key', Argument {argumentPosition}) =+      EnhancedKey key' argumentPosition+    fieldKeys = map fst fieldArgs  validateArguments ::      DataTypeLib
src/Data/Morpheus/Validation/Fragment.hs view
@@ -1,45 +1,112 @@+{-# LANGUAGE NamedFieldPuns #-}+ module Data.Morpheus.Validation.Fragment   ( validateFragments+  , castFragmentType+  , resolveSpread+  , getFragment   ) where -import qualified Data.Map                                      as M (toList)-import           Data.Morpheus.Error.Fragment                  (cannotSpreadWithinItself)-import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), RawSelection (..), RawSelection' (..),-                                                                Reference (..))-import           Data.Morpheus.Types.Internal.Base             (EnhancedKey (..))+import           Data.List                                     ((\\))+import           Data.Semigroup                                ((<>))+import           Data.Text                                     (Text)+import qualified Data.Text                                     as T (concat)++-- MORPHEUS+import           Data.Morpheus.Error.Fragment                  (cannotBeSpreadOnType, cannotSpreadWithinItself,+                                                                fragmentNameCollision, unknownFragment, unusedFragment)+import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawSelection (..),+                                                                RawSelection' (..), Reference (..))+import           Data.Morpheus.Types.Internal.Base             (EnhancedKey (..), Position) import           Data.Morpheus.Types.Internal.Data             (DataTypeLib) import           Data.Morpheus.Types.Internal.Validation       (Validation)-import           Data.Morpheus.Types.Types                     (GQLQueryRoot (..))-import           Data.Morpheus.Validation.Utils.Utils          (existsObjectType)-import           Data.Text                                     (Text)+import           Data.Morpheus.Validation.Utils.Utils          (checkNameCollision, existsObjectType) +validateFragments ::+     DataTypeLib -> FragmentLib -> [(Text, RawSelection)] -> Validation ()+validateFragments lib fragments operatorSel =+  validateNameCollision >> checkLoop >> checkUnusedFragments+  where+    validateNameCollision =+      checkNameCollision fragmentsKeys fragmentNameCollision+    checkUnusedFragments =+      case fragmentsKeys \\ usedFragments fragments operatorSel of+        []     -> return ()+        unused -> Left $ unusedFragment unused+    checkLoop = mapM (validateFragment lib) fragments >>= detectLoopOnFragments+    fragmentsKeys = map toEnhancedKey fragments+      where+        toEnhancedKey (key, Fragment {fragmentPosition}) =+          EnhancedKey key fragmentPosition+ type Node = EnhancedKey  type NodeEdges = (Node, [Node])  type Graph = [NodeEdges] -scanForSpread :: DataTypeLib -> GQLQueryRoot -> (Text, RawSelection) -> [Node]-scanForSpread lib' root' (_, RawSelectionSet RawSelection' {rawSelectionRec = selection'}) =-  concatMap (scanForSpread lib' root') selection'-scanForSpread lib' root' (_, RawAlias {rawAliasSelection = selection'}) =-  concatMap (scanForSpread lib' root') [selection']-scanForSpread lib' root' (_, InlineFragment Fragment {fragmentSelection = selection'}) =-  concatMap (scanForSpread lib' root') selection'-scanForSpread _ _ (_, RawSelectionField {}) = []-scanForSpread _ _ (_, Spread Reference {referenceName = name', referencePosition = position'}) =-  [EnhancedKey name' position']+getFragment :: Reference -> FragmentLib -> Validation Fragment+getFragment Reference {referenceName, referencePosition} lib =+  case lookup referenceName lib of+    Nothing       -> Left $ unknownFragment referenceName referencePosition+    Just fragment -> pure fragment -validateFragment :: DataTypeLib -> GQLQueryRoot -> (Text, Fragment) -> Validation NodeEdges-validateFragment lib' root (fName, Fragment { fragmentSelection = selection'-                                            , fragmentType = target'-                                            , fragmentPosition = position'-                                            }) =-  existsObjectType position' target' lib' >>-  pure (EnhancedKey fName position', concatMap (scanForSpread lib' root) selection')+castFragmentType ::+     Maybe Text -> Position -> [Text] -> Fragment -> Validation Fragment+castFragmentType key' position' targets' fragment@Fragment {fragmentType} =+  if fragmentType `elem` targets'+    then pure fragment+    else Left $+         cannotBeSpreadOnType key' fragmentType position' (T.concat targets') -validateFragments :: DataTypeLib -> GQLQueryRoot -> Validation ()-validateFragments lib root = mapM (validateFragment lib root) (M.toList $ fragments root) >>= detectLoopOnFragments+resolveSpread :: FragmentLib -> [Text] -> Reference -> Validation Fragment+resolveSpread fragments allowedTargets reference@Reference { referenceName+                                                           , referencePosition+                                                           } =+  getFragment reference fragments >>=+  castFragmentType (Just referenceName) referencePosition allowedTargets++usedFragments :: FragmentLib -> [(Text, RawSelection)] -> [Node]+usedFragments fragments = concatMap findAllUses+  where+    findAllUses :: (Text, RawSelection) -> [Node]+    findAllUses (_, RawSelectionSet RawSelection' {rawSelectionRec}) =+      concatMap findAllUses rawSelectionRec+    findAllUses (_, RawAlias {rawAliasSelection}) =+      concatMap findAllUses [rawAliasSelection]+    findAllUses (_, InlineFragment Fragment {fragmentSelection}) =+      concatMap findAllUses fragmentSelection+    findAllUses (_, RawSelectionField {}) = []+    findAllUses (_, Spread Reference {referenceName, referencePosition}) =+      [EnhancedKey referenceName referencePosition] <> searchInFragment+      where+        searchInFragment =+          maybe+            []+            (concatMap findAllUses . fragmentSelection)+            (lookup referenceName fragments)++scanForSpread :: (Text, RawSelection) -> [Node]+scanForSpread (_, RawSelectionSet RawSelection' {rawSelectionRec = selection'}) =+  concatMap scanForSpread selection'+scanForSpread (_, RawAlias {rawAliasSelection = selection'}) =+  concatMap scanForSpread [selection']+scanForSpread (_, InlineFragment Fragment {fragmentSelection = selection'}) =+  concatMap scanForSpread selection'+scanForSpread (_, RawSelectionField {}) = []+scanForSpread (_, Spread Reference { referenceName = name'+                                   , referencePosition = position'+                                   }) = [EnhancedKey name' position']++validateFragment :: DataTypeLib -> (Text, Fragment) -> Validation NodeEdges+validateFragment lib (fName, Fragment { fragmentSelection+                                      , fragmentType+                                      , fragmentPosition+                                      }) =+  existsObjectType fragmentPosition fragmentType lib >>+  pure+    ( EnhancedKey fName fragmentPosition+    , concatMap scanForSpread fragmentSelection)  detectLoopOnFragments :: Graph -> Validation () detectLoopOnFragments lib = mapM_ checkFragment lib
src/Data/Morpheus/Validation/Input/Object.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Validation.Input.Object@@ -14,28 +15,45 @@ import           Data.Text                            (Text)  typeMismatch :: Value -> Text -> [Prop] -> InputError-typeMismatch jsType expected' path' = UnexpectedType path' expected' jsType Nothing+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+     DataTypeLib+  -> [Prop]+  -> [DataTypeWrapper]+  -> DataInputType+  -> (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+    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+    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+    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 (NonNullType:wrappers') type' value' =+      validateInputValue lib' prop' wrappers' type' value'     {-- VALIDATE LIST -}-    validate (ListType:wrappers') type' (key', List list') = List <$> mapM validateElement list'+    validate (ListType: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) =@@ -44,23 +62,36 @@         validateField (_name, value') = do           (type', currentProp') <- validationData value'           wrappers' <- fieldTypeWrappers <$> getField-          value'' <- validateInputValue lib' currentProp' wrappers' type' (_name, value')+          value'' <-+            validateInputValue lib' currentProp' wrappers' type' (_name, value')           return (_name, value'')           where             validationData x = do               fieldTypeName' <- 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)+            getField =+              lookupField _name parentFields' (UnknownField prop' _name)+    -- VALIDATE INPUT UNION+    -- TODO: Validate Union+    validate [] (UnionKind DataType {typeData}) (_, Object fields) =+      return (Object fields)     {-- VALIDATE SCALAR --}     validate [] (EnumKind DataType {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 DataType { typeName = name'+                                     , typeData = DataValidator {validateValue = validator'}+                                     }) (_, value') =       case validator' value' of-        Right _           -> return value'-        Left ""           -> Left $ UnexpectedType prop' name' value' Nothing-        Left errorMessage -> Left $ UnexpectedType prop' name' value' (Just errorMessage)+        Right _ -> return value'+        Left "" -> Left $ UnexpectedType prop' name' value' Nothing+        Left errorMessage ->+          Left $ UnexpectedType prop' name' value' (Just errorMessage)     {-- 3. THROW ERROR: on invalid values --}     validate wrappers' type' (_, value') = throwError wrappers' type' value'
src/Data/Morpheus/Validation/Selection.hs view
@@ -9,58 +9,74 @@   ) where  import           Data.Morpheus.Error.Selection                 (cannotQueryField, duplicateQuerySelections,-                                                                hasNoSubfields)-import           Data.Morpheus.Types.Internal.AST.Operator     (ValidVariables)+                                                                hasNoSubfields, subfieldsNotSelected)+import           Data.Morpheus.Error.Variable                  (unknownType)+import           Data.Morpheus.Types.Internal.AST.Operation    (ValidVariables) import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawSelection (..),                                                                 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 (..), DataOutputObject, DataType (..),-                                                                DataTypeKind (..), DataTypeLib (..))+import           Data.Morpheus.Types.Internal.Data             (DataField (..), DataFullType (..), DataOutputObject,+                                                                DataType (..), DataTypeLib (..), allDataTypes) import           Data.Morpheus.Types.Internal.Validation       (Validation) import           Data.Morpheus.Validation.Arguments            (validateArguments)-import           Data.Morpheus.Validation.Spread               (castFragmentType, resolveSpread)+import           Data.Morpheus.Validation.Fragment             (castFragmentType, resolveSpread) import           Data.Morpheus.Validation.Utils.Selection      (lookupFieldAsSelectionSet, lookupSelectionField,-                                                                lookupUnionTypes, notObject)-import           Data.Morpheus.Validation.Utils.Utils          (checkNameCollision)+                                                                lookupUnionTypes)+import           Data.Morpheus.Validation.Utils.Utils          (checkNameCollision, lookupType) import           Data.Text                                     (Text)  checkDuplicatesOn :: DataOutputObject -> SelectionSet -> Validation SelectionSet-checkDuplicatesOn DataType {typeName = name'} keys = checkNameCollision enhancedKeys (map fst keys) error' >> pure keys+checkDuplicatesOn DataType {typeName = name'} keys =+  checkNameCollision enhancedKeys selError >> pure keys   where-    error' = duplicateQuerySelections name'+    selError = duplicateQuerySelections name'     enhancedKeys = map selToKey keys-    selToKey (key', Selection {selectionPosition = position'}) = EnhancedKey key' position'+    selToKey (key', Selection {selectionPosition = position'}) =+      EnhancedKey key' position'  clusterUnionSelection ::-     FragmentLib -> Text -> [DataOutputObject] -> (Text, RawSelection) -> Validation ([Fragment], SelectionSet)-clusterUnionSelection fragments' type' possibleTypes' = splitFrag+     FragmentLib+  -> Text+  -> [DataOutputObject]+  -> (Text, RawSelection)+  -> Validation ([Fragment], SelectionSet)+clusterUnionSelection fragments type' possibleTypes' = splitFrag   where-    packFragment fragment' = return ([fragment'], [])+    packFragment fragment = return ([fragment], [])     typeNames = map typeName possibleTypes'     splitFrag :: (Text, RawSelection) -> Validation ([Fragment], SelectionSet)-    splitFrag (_, Spread reference') = resolveSpread fragments' typeNames reference' >>= packFragment+    splitFrag (_, Spread ref) =+      resolveSpread fragments typeNames ref >>= packFragment     splitFrag ("__typename", RawSelectionField RawSelection' {rawSelectionPosition = position'}) =       return         ( []         , [ ( "__typename"-            , Selection {selectionRec = SelectionField, selectionArguments = [], selectionPosition = position'})+            , Selection+                { selectionRec = SelectionField+                , selectionArguments = []+                , selectionPosition = position'+                })           ])-    splitFrag (key', RawSelectionSet RawSelection' {rawSelectionPosition = position'}) =-      Left $ cannotQueryField key' type' position'-    splitFrag (key', RawSelectionField RawSelection' {rawSelectionPosition = position'}) =+    splitFrag (key, RawSelectionSet RawSelection' {rawSelectionPosition}) =+      Left $ cannotQueryField key type' rawSelectionPosition+    splitFrag (key, RawSelectionField RawSelection' {rawSelectionPosition}) =+      Left $ cannotQueryField key type' rawSelectionPosition+    splitFrag (key', RawAlias {rawAliasPosition = position'}) =       Left $ cannotQueryField key' type' position'-    splitFrag (key', RawAlias {rawAliasPosition = position'}) = Left $ cannotQueryField key' type' position'     splitFrag (_, InlineFragment fragment') =-      castFragmentType Nothing (fragmentPosition fragment') typeNames fragment' >>= packFragment+      castFragmentType Nothing (fragmentPosition fragment') typeNames fragment' >>=+      packFragment -categorizeTypes :: [DataOutputObject] -> [Fragment] -> [(DataOutputObject, [Fragment])]-categorizeTypes types' fragments' = map categorizeType types'+categorizeTypes ::+     [DataOutputObject] -> [Fragment] -> [(DataOutputObject, [Fragment])]+categorizeTypes types fragments = filter notEmpty $ map categorizeType types   where+    notEmpty = (0 /=) . length . snd     categorizeType :: DataOutputObject -> (DataOutputObject, [Fragment])-    categorizeType type' = (type', filter matches fragments')+    categorizeType datatype = (datatype, filter matches fragments)       where-        matches fragment' = fragmentType fragment' == typeName type'+        matches fragment = fragmentType fragment == typeName datatype  flatTuple :: [([a], [b])] -> ([a], [b]) flatTuple list' = (concatMap fst list', concatMap snd list')@@ -84,78 +100,127 @@   -> DataOutputObject   -> RawSelectionSet   -> Validation SelectionSet-validateSelectionSet lib' fragments' operatorName variables = __validate+validateSelectionSet lib fragments' operatorName variables = __validate   where     __validate dataType'@DataType {typeName = typeName'} selectionSet' =-      concat <$> mapM validateSelection selectionSet' >>= checkDuplicatesOn dataType'+      concat <$> mapM validateSelection selectionSet' >>=+      checkDuplicatesOn dataType'       where-        validateFragment Fragment {fragmentSelection = selection'} = __validate dataType' selection'+        validateFragment Fragment {fragmentSelection = selection'} =+          __validate dataType' selection'         {-             get dataField and validated arguments for RawSelection         -}-        getValidationData key' RawSelection' {rawSelectionArguments, rawSelectionPosition} = do-          selectionField <- lookupSelectionField rawSelectionPosition key' dataType'-          arguments' <-+        getValidationData key RawSelection' { rawSelectionArguments+                                            , rawSelectionPosition+                                            } = do+          selectionField <-+            lookupSelectionField rawSelectionPosition key dataType'+          -- validate field Argument -----+          arguments <-             validateArguments-              lib'+              lib               operatorName               variables-              (key', selectionField)+              (key, selectionField)               rawSelectionPosition               rawSelectionArguments-          return (selectionField, arguments')-        {--             validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet-        -}+          -- check field Type existence  -----+          fieldDataType <-+            lookupType+              (unknownType (fieldType selectionField) rawSelectionPosition)+              (allDataTypes lib)+              (fieldType selectionField)+          return (selectionField, fieldDataType, arguments)+        -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet+        --         validateSelection :: (Text, RawSelection) -> Validation SelectionSet-        validateSelection (key', RawAlias {rawAliasSelection = rawSelection', rawAliasPosition = position'}) =+        validateSelection (key', RawAlias { rawAliasSelection = rawSelection'+                                          , rawAliasPosition = position'+                                          }) =           fmap processSingleSelection <$> validateSelection rawSelection'           where             processSingleSelection (selKey', selection') =               ( key'               , selection'-                  { selectionRec = SelectionAlias {aliasFieldName = selKey', aliasSelection = selectionRec selection'}+                  { selectionRec =+                      SelectionAlias+                        { aliasFieldName = selKey'+                        , aliasSelection = selectionRec selection'+                        }                   , selectionPosition = position'                   })         validateSelection (key', RawSelectionSet fullRawSelection'@RawSelection' { rawSelectionRec = rawSelectors                                                                                  , rawSelectionPosition = position'                                                                                  }) = do-          (dataField', arguments') <- getValidationData key' fullRawSelection'-          case fieldKind dataField' of-            KindUnion -> do-              (categories', __typename') <- clusterTypes-              mapM (validateCluster __typename') categories' >>= returnSelection arguments' . UnionSelection+          (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'-                      (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)+                      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 sysSelection' (type', frags') = do-                      selection' <- __validate type' (concatMap fragmentSelection frags')+                      selection' <-+                        __validate type' (concatMap fragmentSelection frags')                       return (typeName type', sysSelection' ++ selection')-            KindObject -> do-              fieldType' <- lookupFieldAsSelectionSet position' key' lib' dataField'-              __validate fieldType' rawSelectors >>= returnSelection arguments' . SelectionSet+            OutputObject _ -> do+              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'           where             returnSelection arguments' selection' =               pure                 [ ( key'                   , Selection-                      {selectionArguments = arguments', selectionRec = selection', selectionPosition = position'})+                      { selectionArguments = arguments'+                      , selectionRec = selection'+                      , selectionPosition = position'+                      })                 ]-        validateSelection (key', RawSelectionField fullRawSelection'@RawSelection' {rawSelectionPosition = position'}) = do-          (dataField', arguments') <- getValidationData key' fullRawSelection'-          _ <- notObject (key', position') dataField'+        validateSelection (key', RawSelectionField fullRawSelection'@RawSelection' {rawSelectionPosition}) = do+          (dataField, datatype, arguments') <-+            getValidationData key' fullRawSelection'+          isLeaf datatype dataField           pure             [ ( key'               , Selection-                  {selectionArguments = arguments', selectionRec = SelectionField, selectionPosition = position'})+                  { selectionArguments = arguments'+                  , selectionRec = SelectionField+                  , selectionPosition = rawSelectionPosition+                  })             ]-        validateSelection (_, Spread reference') = resolveSpread fragments' [typeName'] reference' >>= validateFragment+          where+            isLeaf (Leaf _) _ = Right ()+            isLeaf _ DataField {fieldType} =+              Left $ subfieldsNotSelected key' fieldType rawSelectionPosition+        validateSelection (_, Spread reference') =+          resolveSpread fragments' [typeName'] reference' >>= validateFragment         validateSelection (_, InlineFragment fragment') =-          castFragmentType Nothing (fragmentPosition fragment') [typeName'] fragment' >>= validateFragment+          castFragmentType+            Nothing+            (fragmentPosition fragment')+            [typeName']+            fragment' >>=+          validateFragment
− src/Data/Morpheus/Validation/Spread.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Validation.Spread-  ( getFragment-  , resolveSpread-  , castFragmentType-  ) where--import qualified Data.Map                                      as M (lookup)-import           Data.Morpheus.Error.Spread                    (cannotBeSpreadOnType, unknownFragment)-import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, Reference (..))-import           Data.Morpheus.Types.Internal.Base             (Position)-import           Data.Morpheus.Types.Internal.Validation       (Validation)-import           Data.Text                                     (Text)-import qualified Data.Text                                     as T (concat)--getFragment :: Reference -> FragmentLib -> Validation Fragment-getFragment Reference {referenceName, referencePosition} lib =-  case M.lookup referenceName lib of-    Nothing       -> Left $ unknownFragment referenceName referencePosition-    Just fragment -> pure fragment--castFragmentType :: Maybe Text -> Position -> [Text] -> Fragment -> Validation Fragment-castFragmentType key' position' targets' fragment@Fragment {fragmentType = type'} =-  if type' `elem` targets'-    then pure fragment-    else Left $ cannotBeSpreadOnType key' type' position' (T.concat targets')--resolveSpread :: FragmentLib -> [Text] -> Reference -> Validation Fragment-resolveSpread fragments' allowedTargets' reference@Reference {referenceName = key', referencePosition = position'} =-  getFragment reference fragments' >>= castFragmentType (Just key') position' allowedTargets'
src/Data/Morpheus/Validation/Utils/Selection.hs view
@@ -1,46 +1,44 @@ module Data.Morpheus.Validation.Utils.Selection   ( lookupFieldAsSelectionSet-  , mustBeObject-  , notObject   , lookupSelectionField   , lookupUnionTypes   ) where -import           Data.Morpheus.Error.Selection           (cannotQueryField, hasNoSubfields, subfieldsNotSelected)+import           Data.Morpheus.Error.Selection           (cannotQueryField, hasNoSubfields) import           Data.Morpheus.Types.Internal.Base       (Position) import           Data.Morpheus.Types.Internal.Data       (DataField (..), DataOutputField, DataOutputObject,-                                                          DataType (..), DataTypeKind (..), DataTypeLib (..))+                                                          DataType (..), DataTypeLib (..)) import           Data.Morpheus.Types.Internal.Validation (Validation) import           Data.Morpheus.Validation.Utils.Utils    (lookupField, lookupType) import           Data.Text                               (Text) -isObjectKind :: DataField a -> Bool-isObjectKind field' = KindObject == fieldKind field'--mustBeObject :: (Text, Position) -> DataOutputField -> Validation DataOutputField-mustBeObject (key', position') field' =-  if isObjectKind field'-    then pure field'-    else Left $ hasNoSubfields key' (fieldType field') position'--notObject :: (Text, Position) -> DataOutputField -> Validation DataOutputField-notObject (key', position') field' =-  if isObjectKind field'-    then Left $ subfieldsNotSelected key' (fieldType field') position'-    else pure field'--lookupUnionTypes :: Position -> Text -> DataTypeLib -> DataOutputField -> Validation [DataOutputObject]+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+  lookupType error' (union lib') type' >>=+  mapM (lookupType error' (object lib') . 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+  -> DataOutputField+  -> Validation DataOutputObject+lookupFieldAsSelectionSet position' key' lib' DataField {fieldType = type'} =+  lookupType error' (object lib') type'   where     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 -> DataOutputObject -> Validation DataOutputField+lookupSelectionField position' key' DataType { typeData = fields'+                                             , typeName = name'+                                             } = lookupField key' fields' error'   where     error' = cannotQueryField key' name' position'
src/Data/Morpheus/Validation/Utils/Utils.hs view
@@ -6,6 +6,7 @@   , lookupField   , checkNameCollision   , checkForUnknownKeys+  , VALIDATION_MODE(..)   ) where  import           Data.List                               ((\\))@@ -19,6 +20,11 @@  type GenError error a = error -> Either error a +data VALIDATION_MODE+  = WITHOUT_VARIABLES+  | FULL_VALIDATION+  deriving (Eq, Show)+ lookupType :: error -> [(Text, a)] -> Text -> Either error a lookupType error' lib' typeName' =   case lookup typeName' lib' of@@ -36,13 +42,19 @@   case lookup typeName' (inputObject lib) of     Just x -> pure (ObjectKind x)     Nothing ->-      case lookup typeName' (leaf lib) of-        Nothing             -> Left error'-        Just (LeafScalar x) -> pure (ScalarKind x)-        Just (LeafEnum x)   -> pure (EnumKind x)+      case lookup typeName' (inputUnion lib) of+        Just x -> pure (UnionKind x)+        Nothing ->+          case lookup typeName' (leaf lib) of+            Nothing               -> Left error'+            Just (BaseScalar x)   -> pure (ScalarKind x)+            Just (CustomScalar x) -> pure (ScalarKind x)+            Just (LeafEnum x)     -> pure (EnumKind x) -existsObjectType :: Position -> Text -> DataTypeLib -> Validation DataOutputObject-existsObjectType position' typeName' lib = lookupType error' (object lib) typeName'+existsObjectType ::+     Position -> Text -> DataTypeLib -> Validation DataOutputObject+existsObjectType position' typeName' lib =+  lookupType error' (object lib) typeName'   where     error' = unknownType typeName' position' @@ -55,13 +67,18 @@ elementOfKeys :: [Text] -> EnhancedKey -> Bool elementOfKeys keys' EnhancedKey {uid = id'} = id' `elem` keys' -checkNameCollision :: [EnhancedKey] -> [Text] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey]-checkNameCollision enhancedKeys' keys' errorGenerator' =-  case differKeys enhancedKeys' (removeDuplicates keys') of-    []          -> pure enhancedKeys'-    duplicates' -> Left $ errorGenerator' duplicates'+checkNameCollision ::+     [EnhancedKey] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey]+checkNameCollision enhancedKeys errorGenerator =+  case enhancedKeys \\ removeDuplicates enhancedKeys of+    []         -> pure enhancedKeys+    duplicates -> Left $ errorGenerator duplicates -checkForUnknownKeys :: [EnhancedKey] -> [Text] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey]+checkForUnknownKeys ::+     [EnhancedKey]+  -> [Text]+  -> ([EnhancedKey] -> error)+  -> Either error [EnhancedKey] checkForUnknownKeys enhancedKeys' keys' errorGenerator' =   case filter (not . elementOfKeys keys') enhancedKeys' of     []           -> pure enhancedKeys'
src/Data/Morpheus/Validation/Validation.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE NamedFieldPuns      #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators       #-} @@ -9,43 +10,61 @@ import           Data.Map                                   (fromList) import           Data.Morpheus.Error.Mutation               (mutationIsNotDefined) import           Data.Morpheus.Error.Subscription           (subscriptionIsNotDefined)-import           Data.Morpheus.Types.Internal.AST.Operator  (Operator (..), Operator' (..), RawOperator, RawOperator',-                                                             ValidOperator)-import           Data.Morpheus.Types.Internal.AST.Selection (SelectionSet)+import           Data.Morpheus.Types.Internal.AST.Operation (Operation (..), OperationKind (..), RawOperation,+                                                             ValidOperation) import           Data.Morpheus.Types.Internal.Data          (DataOutputObject, DataTypeLib (..)) import           Data.Morpheus.Types.Internal.Validation    (Validation) import           Data.Morpheus.Types.Types                  (GQLQueryRoot (..)) import           Data.Morpheus.Validation.Fragment          (validateFragments) import           Data.Morpheus.Validation.Selection         (validateSelectionSet)-import           Data.Morpheus.Validation.Variable          (resolveOperatorVariables)--updateQuery :: RawOperator -> SelectionSet -> ValidOperator-updateQuery (Query (Operator' name' _ _ pos)) sel        = Query (Operator' name' [] sel pos)-updateQuery (Mutation (Operator' name' _ _ pos)) sel     = Mutation (Operator' name' [] sel pos)-updateQuery (Subscription (Operator' name' _ _ pos)) sel = Subscription (Operator' name' [] sel pos)+import           Data.Morpheus.Validation.Utils.Utils       (VALIDATION_MODE)+import           Data.Morpheus.Validation.Variable          (resolveOperationVariables) -getOperator :: RawOperator -> DataTypeLib -> Validation (DataOutputObject, RawOperator')-getOperator (Query operator') lib' = pure (snd $ query lib', operator')-getOperator (Mutation operator') lib' =-  case mutation lib' of-    Just (_, mutation') -> pure (mutation', operator')-    Nothing             -> Left $ mutationIsNotDefined (operatorPosition operator')-getOperator (Subscription operator') lib' =-  case subscription lib' of-    Just (_, subscription') -> pure (subscription', operator')-    Nothing                 -> Left $ subscriptionIsNotDefined (operatorPosition operator')+getOperationDataType ::+     RawOperation -> DataTypeLib -> Validation DataOutputObject+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 =+  case subscription lib of+    Just (_, subscription') -> pure subscription'+    Nothing                 -> Left $ subscriptionIsNotDefined operationPosition -validateRequest :: DataTypeLib -> GQLQueryRoot -> Validation ValidOperator-validateRequest lib' root' = do-  (operatorType', operator') <- getOperator (queryBody root') lib'-  variables' <- resolveOperatorVariables lib' (fragments root') (fromList $ inputVariables root') operator'-  validateFragments lib' root'-  selectors <-+validateRequest ::+     DataTypeLib -> VALIDATION_MODE -> GQLQueryRoot -> Validation ValidOperation+validateRequest lib validationMode GQLQueryRoot { fragments+                                                , inputVariables+                                                , operation = rawOperation@Operation { operationName+                                                                                     , operationKind+                                                                                     , operationSelection+                                                                                     , operationPosition+                                                                                     }+                                                } = do+  operationDataType <- getOperationDataType rawOperation lib+  variables <-+    resolveOperationVariables+      lib+      fragments+      (fromList inputVariables)+      validationMode+      rawOperation+  validateFragments lib fragments operationSelection+  selection <-     validateSelectionSet-      lib'-      (fragments root')-      (operatorName operator')-      variables'-      operatorType'-      (operatorSelection operator')-  pure $ updateQuery (queryBody root') selectors+      lib+      fragments+      operationName+      variables+      operationDataType+      operationSelection+  pure $+    Operation+      { operationName+      , operationKind+      , operationArgs = []+      , operationSelection = selection+      , operationPosition+      }
src/Data/Morpheus/Validation/Variable.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-}  module Data.Morpheus.Validation.Variable-  ( resolveOperatorVariables+  ( resolveOperationVariables   ) where  import           Data.List                                     ((\\))@@ -10,7 +10,7 @@ import           Data.Morpheus.Error.Input                     (InputValidation, inputErrorMessage) import           Data.Morpheus.Error.Variable                  (uninitializedVariable, unknownType, unusedVariables,                                                                 variableGotInvalidValue)-import           Data.Morpheus.Types.Internal.AST.Operator     (Operator' (..), RawOperator', ValidVariables,+import           Data.Morpheus.Types.Internal.AST.Operation    (Operation (..), RawOperation, ValidVariables,                                                                 Variable (..)) import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawArgument (..),                                                                 RawSelection (..), RawSelection' (..), RawSelectionSet,@@ -20,9 +20,9 @@ import           Data.Morpheus.Types.Internal.Validation       (Validation) import           Data.Morpheus.Types.Internal.Value            (Value (..)) import           Data.Morpheus.Types.Types                     (Variables)+import           Data.Morpheus.Validation.Fragment             (getFragment) import           Data.Morpheus.Validation.Input.Object         (validateInputValue)-import           Data.Morpheus.Validation.Spread               (getFragment)-import           Data.Morpheus.Validation.Utils.Utils          (getInputType)+import           Data.Morpheus.Validation.Utils.Utils          (VALIDATION_MODE (..), getInputType) import           Data.Semigroup                                ((<>)) import           Data.Text                                     (Text) @@ -37,59 +37,94 @@     Nothing    -> Left $ error' key'     Just value -> pure value -handleInputError :: Text -> Position -> InputValidation Value -> Validation (Text, Value)-handleInputError key' position' (Left error') = Left $ variableGotInvalidValue key' (inputErrorMessage error') position'+handleInputError ::+     Text -> Position -> InputValidation Value -> Validation (Text, Value)+handleInputError key' position' (Left error') =+  Left $ variableGotInvalidValue key' (inputErrorMessage error') position' handleInputError key' _ (Right value') = pure (key', value')  concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f = fmap concat . mapM f -allVariableReferences :: FragmentLib -> [RawSelectionSet] -> Validation [EnhancedKey]+allVariableReferences ::+     FragmentLib -> [RawSelectionSet] -> Validation [EnhancedKey] allVariableReferences fragmentLib = concatMapM (concatMapM searchReferences)   where     referencesFromArgument :: (Text, RawArgument) -> [EnhancedKey]     referencesFromArgument (_, RawArgument {}) = []-    referencesFromArgument (_, VariableReference Reference {referenceName, referencePosition}) =+    referencesFromArgument (_, VariableReference Reference { referenceName+                                                           , referencePosition+                                                           }) =       [EnhancedKey referenceName referencePosition]     -- | search used variables in every arguments     searchReferences :: (Text, RawSelection) -> Validation [EnhancedKey]-    searchReferences (_, RawSelectionSet RawSelection' {rawSelectionArguments, rawSelectionRec}) =+    searchReferences (_, RawSelectionSet RawSelection' { rawSelectionArguments+                                                       , rawSelectionRec+                                                       }) =       getArgs <$> concatMapM searchReferences rawSelectionRec       where         getArgs :: [EnhancedKey] -> [EnhancedKey]         getArgs x = concatMap referencesFromArgument rawSelectionArguments <> x-    searchReferences (_, InlineFragment Fragment {fragmentSelection}) = concatMapM searchReferences fragmentSelection-    searchReferences (_, RawAlias {rawAliasSelection}) = searchReferences rawAliasSelection+    searchReferences (_, InlineFragment Fragment {fragmentSelection}) =+      concatMapM searchReferences fragmentSelection+    searchReferences (_, RawAlias {rawAliasSelection}) =+      searchReferences rawAliasSelection     searchReferences (_, RawSelectionField RawSelection' {rawSelectionArguments}) =       return $ concatMap referencesFromArgument rawSelectionArguments     searchReferences (_, Spread reference) =-      getFragment reference fragmentLib >>= concatMapM searchReferences . fragmentSelection+      getFragment reference fragmentLib >>=+      concatMapM searchReferences . fragmentSelection -resolveOperatorVariables :: DataTypeLib -> FragmentLib -> Variables -> RawOperator' -> Validation ValidVariables-resolveOperatorVariables typeLib fragmentLib root operator' = do-  allVariableReferences fragmentLib [operatorSelection operator'] >>= checkUnusedVariables-  mapM (lookupAndValidateValueOnBody typeLib root) (operatorArgs operator')+resolveOperationVariables ::+     DataTypeLib+  -> FragmentLib+  -> Variables+  -> VALIDATION_MODE+  -> RawOperation+  -> Validation ValidVariables+resolveOperationVariables typeLib lib root validationMode Operation { operationName+                                                                    , operationSelection+                                                                    , operationArgs+                                                                    } = do+  allVariableReferences lib [operationSelection] >>= checkUnusedVariables+  mapM (lookupAndValidateValueOnBody typeLib root validationMode) operationArgs   where     varToKey :: (Text, Variable ()) -> EnhancedKey-    varToKey (key', Variable {variablePosition}) = EnhancedKey key' variablePosition+    varToKey (key', Variable {variablePosition}) =+      EnhancedKey key' variablePosition     --     checkUnusedVariables :: [EnhancedKey] -> Validation ()-    checkUnusedVariables references' =-      case map varToKey (operatorArgs operator') \\ references' of+    checkUnusedVariables refs =+      case map varToKey operationArgs \\ refs of         []      -> pure ()-        unused' -> Left $ unusedVariables (operatorName operator') unused'+        unused' -> Left $ unusedVariables operationName unused' -lookupAndValidateValueOnBody :: DataTypeLib -> Variables -> (Text, Variable ()) -> Validation (Text, Variable Value)-lookupAndValidateValueOnBody typeLib bodyVariables (key', var@Variable { variableType-                                                                       , variablePosition-                                                                       , isVariableRequired-                                                                       , variableTypeWrappers-                                                                       }) =-  toVariable <$> (getVariableType variableType variablePosition typeLib >>= checkType isVariableRequired)+lookupAndValidateValueOnBody ::+     DataTypeLib+  -> Variables+  -> VALIDATION_MODE+  -> (Text, Variable ())+  -> Validation (Text, Variable Value)+lookupAndValidateValueOnBody typeLib bodyVariables validationMode (key, var@Variable { variableType+                                                                                     , variablePosition+                                                                                     , isVariableRequired+                                                                                     , variableTypeWrappers+                                                                                     }) =+  toVariable <$>+  (getVariableType variableType variablePosition typeLib >>=+   checkType (validationMode /= WITHOUT_VARIABLES && isVariableRequired))   where-    toVariable (k, x) = (k, var {variableValue = x})-    checkType True _type =-      lookupVariable bodyVariables key' (uninitializedVariable variablePosition variableType) >>= validator _type-    checkType False _type = maybe (pure (key', Null)) (validator _type) (M.lookup key' bodyVariables)-    validator _type varValue =-      handleInputError key' variablePosition $ validateInputValue typeLib [] variableTypeWrappers _type (key', varValue)+    toVariable (varKey, variableValue) = (varKey, var {variableValue})+    ------------------------------------------------------------------+    checkType True varType =+      lookupVariable+        bodyVariables+        key+        (uninitializedVariable variablePosition variableType) >>=+      validator varType+    checkType False varType =+      maybe (pure (key, Null)) (validator varType) (M.lookup key bodyVariables)+    -----------------------------------------------------------------------------------------------+    validator varType varValue =+      handleInputError key variablePosition $+      validateInputValue typeLib [] variableTypeWrappers varType (key, varValue)
test/Feature/Holistic/API.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -10,52 +9,48 @@  import           Data.ByteString.Lazy.Char8 (ByteString) import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (ENUM, INPUT_OBJECT, KIND, OBJECT, SCALAR, UNION)-import           Data.Morpheus.Types        (GQLRootResolver (..), GQLScalar (..), GQLType (..), ID (..), ResM,-                                             ScalarValue (..))+import           Data.Morpheus.Kind         (ENUM, INPUT_OBJECT, OBJECT, SCALAR, UNION)+import           Data.Morpheus.Types        (Event (..), GQLRootResolver (..), GQLScalar (..), GQLType (..), ID (..),+                                             IORes, IOSubRes, ScalarValue (..)) import           Data.Text                  (Text) import           GHC.Generics               (Generic) -type instance KIND TestEnum = ENUM--type instance KIND TestScalar = SCALAR--type instance KIND NestedInputObject = INPUT_OBJECT--type instance KIND Coordinates = INPUT_OBJECT--type instance KIND TestInputObject = INPUT_OBJECT--type instance KIND Address = OBJECT--type instance KIND User = OBJECT--type instance KIND TestUnion = UNION- data TestEnum   = EnumA   | EnumB   | EnumC-  deriving (Generic, GQLType)+  deriving (Generic) +instance GQLType TestEnum where+  type KIND TestEnum = ENUM+ data TestScalar =   TestScalar Int              Int-  deriving (Generic, GQLType)+  deriving (Generic) +instance GQLType TestScalar where+  type KIND TestScalar = SCALAR+ instance GQLScalar TestScalar where   parseValue _ = pure (TestScalar 1 0)   serialize (TestScalar x y) = Int (x * 100 + y)  newtype NestedInputObject = NestedInputObject   { fieldTestID :: ID-  } deriving (Generic, GQLType)+  } deriving (Generic) +instance GQLType NestedInputObject where+  type KIND NestedInputObject = INPUT_OBJECT+ data TestInputObject = TestInputObject   { fieldTestScalar        :: TestScalar   , fieldNestedInputObject :: [Maybe NestedInputObject]-  } deriving (Generic, GQLType)+  } deriving (Generic) +instance GQLType TestInputObject where+  type KIND TestInputObject = INPUT_OBJECT+ data StreetArgs = StreetArgs   { argInputObject :: TestInputObject   , argMaybeString :: Maybe Text@@ -63,20 +58,29 @@  data Address = Address   { city        :: Text-  , street      :: StreetArgs -> ResM (Maybe [Maybe [[[Text]]]])+  , street      :: StreetArgs -> IORes (Maybe [Maybe [[[Text]]]])   , houseNumber :: Int-  } deriving (Generic, GQLType)+  } deriving (Generic) +instance GQLType Address where+  type KIND Address = OBJECT+ data TestUnion   = UnionA User   | UnionB Address-  deriving (Generic, GQLType)+  deriving (Generic) +instance GQLType TestUnion where+  type KIND TestUnion = UNION+ data Coordinates = Coordinates   { latitude  :: TestScalar   , longitude :: Int-  } deriving (Generic, GQLType)+  } deriving (Generic) +instance GQLType Coordinates where+  type KIND Coordinates = INPUT_OBJECT+ data AddressArgs = AddressArgs   { coordinates :: Coordinates   , comment     :: Maybe Text@@ -90,48 +94,47 @@ data User = User   { name    :: Text   , email   :: Text-  , address :: AddressArgs -> ResM Address-  , office  :: OfficeArgs -> ResM Address-  , friend  :: () -> ResM (Maybe User)+  , address :: AddressArgs -> IORes Address+  , office  :: OfficeArgs -> IORes Address+  , friend  :: () -> IORes (Maybe User)   } deriving (Generic)  instance GQLType User where-  description _ = "Custom Description for Client Defined User Type"+  type KIND User = OBJECT+  description = const "Custom Description for Client Defined User Type"  data Query = Query-  { user      :: () -> ResM User+  { user      :: () -> IORes User   , testUnion :: Maybe TestUnion   } deriving (Generic)  newtype Mutation = Mutation-  { createUser :: AddressArgs -> ResM User+  { createUser :: AddressArgs -> IORes User   } deriving (Generic) +data EVENT =+  EVENT+  deriving (Show, Eq)+ newtype Subscription = Subscription-  { newUser :: AddressArgs -> ResM User+  { newUser :: AddressArgs -> IOSubRes EVENT () User   } deriving (Generic) -resolveAddress :: a -> ResM Address+resolveAddress :: a -> IORes Address resolveAddress _ = return Address {city = "", houseNumber = 1, street = const $ return Nothing} -resolveUser :: a -> ResM User+resolveUser :: a -> IORes User resolveUser _ =   return $   User     {name = "testName", email = "", address = resolveAddress, office = resolveAddress, friend = const $ return Nothing} -createUserMutation :: AddressArgs -> ResM User-createUserMutation = resolveUser--newUserSubscription :: AddressArgs -> ResM User-newUserSubscription = resolveUser--rootResolver :: GQLRootResolver IO Query Mutation Subscription+rootResolver :: GQLRootResolver IO EVENT () Query Mutation Subscription rootResolver =   GQLRootResolver     { queryResolver = return Query {user = resolveUser, testUnion = Nothing}-    , mutationResolver = return Mutation {createUser = createUserMutation}-    , subscriptionResolver = return Subscription {newUser = newUserSubscription}+    , mutationResolver = return Mutation {createUser = resolveUser}+    , subscriptionResolver = return Subscription {newUser = const $ Event [EVENT] resolveUser}     }  api :: ByteString -> IO ByteString
test/Feature/Holistic/cases.json view
@@ -56,6 +56,22 @@     "description": "fail when: fragment type is incompatible with object type"   },   {+    "path": "fragment/unusedFragment",+    "description": "fail when: defined fragment is not used query"+  },+  {+    "path": "fragment/nameCollision",+    "description": "fail when: fragments are defined with same name"+  },+  {+    "path": "parsing/duplicatedFields",+    "description": "fail when: user supplies duplicated fields"+  },+  {+    "path": "parsing/invalidFields",+    "description": "fail when: user supplies invalid fields"+  },+  {     "path": "parsing/invalidNotNullOperator",     "description": "fail when: user supplies '@' instead of '!'"   },@@ -125,7 +141,7 @@   },   {     "path": "introspection/defaultTypes/Float",-    "description": "Float returns null, if it is not defined by schema"+    "description": "benchmark Float"   },   {     "path": "introspection/defaultTypes/ID",
test/Feature/Holistic/fragment/loopingFragment/response.json view
@@ -5,7 +5,7 @@       "locations": [         {           "line": 7,-          "column": 1+          "column": 10         },         {           "line": 9,
+ test/Feature/Holistic/fragment/nameCollision/query.gql view
@@ -0,0 +1,14 @@+{+  user {+    email+    ...F+  }+}++fragment F on User {+  name+}++fragment F on User {+  name+}
+ test/Feature/Holistic/fragment/nameCollision/response.json view
@@ -0,0 +1,13 @@+{+  "errors": [+    {+      "message": "There can be only one fragment named \"F\".",+      "locations": [+        {+          "line": 12,+          "column": 10+        }+      ]+    }+  ]+}
+ test/Feature/Holistic/fragment/unusedFragment/query.gql view
@@ -0,0 +1,22 @@+{+  user {+    email+    ...A+  }+}++fragment A on User {+  ...B+}++fragment B on User {+  name+}++fragment C on User {+  ...D+}++fragment D on User {+  email+}
+ test/Feature/Holistic/fragment/unusedFragment/response.json view
@@ -0,0 +1,22 @@+{+  "errors": [+    {+      "message": "Fragment \"C\" is never used.",+      "locations": [+        {+          "line": 16,+          "column": 10+        }+      ]+    },+    {+      "message": "Fragment \"D\" is never used.",+      "locations": [+        {+          "line": 20,+          "column": 10+        }+      ]+    }+  ]+}
test/Feature/Holistic/introspection/defaultTypes/Float/response.json view
@@ -1,5 +1,13 @@ {   "data": {-    "__type": null+    "__type": {+      "kind": "SCALAR",+      "name": "Float",+      "fields": null,+      "inputFields": null,+      "interfaces": null,+      "enumValues": null,+      "possibleTypes": null+    }   } }
+ test/Feature/Holistic/parsing/duplicatedFields/query.gql view
@@ -0,0 +1,2 @@+{ user { email, email } }+
+ test/Feature/Holistic/parsing/duplicatedFields/response.json view
@@ -0,0 +1,13 @@+{+	"errors": [+    {+      "message": "duplicate selection of key \"email\" on type \"User\".",+      "locations": [+        {+          "line": 1,+          "column": 17+        }+      ]+    }+  ]+}
test/Feature/Holistic/parsing/invalidFields/response.json view
@@ -1,11 +1,11 @@ {   "errors": [     {-      "message": "offset=66:\nunexpected end of input\nexpecting '}', entry, or white space\n",+      "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', body, digit, entry, letter, maybeArguments, or white space\n",       "locations": [         {-          "line": 5,-          "column": 1+          "line": 1,+          "column": 27         }       ]     }
test/Feature/Holistic/parsing/invalidNotNullOperator/response.json view
@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=20:\nunexpected '@'\nexpecting '!', ']', '_', digit, letter, or white space\n",+      "message": "offset=20:\nunexpected '@'\nexpecting '!', '#', ']', '_', digit, letter, or white space\n",       "locations": [         {           "line": 1,
test/Feature/Holistic/parsing/missingCloseBrace/response.json view
@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=66:\nunexpected end of input\nexpecting ',', '}', entry, or white space\n",+      "message": "offset=66:\nunexpected end of input\nexpecting '#', ',', '}', entry, or white space\n",       "locations": [         {           "line": 5,
+ test/Feature/Input/Enum/API.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE TypeOperators  #-}++module Feature.Input.Enum.API+  ( api+  ) where++import           Data.ByteString.Lazy.Char8 (ByteString)+import           Data.Morpheus              (interpreter)+import           Data.Morpheus.Kind         (ENUM)+import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType (..), IORes)+import           GHC.Generics               (Generic)++data TwoCon+  = LA+  | LB+  deriving (Show, Generic)++data ThreeCon+  = T1+  | T2+  | T3+  deriving (Show, Generic)++data Level+  = L0+  | L1+  | L2+  | L3+  | L4+  | L5+  | L6+  deriving (Show, Generic)++-- types & args+newtype TestArgs a = TestArgs+  { level :: a+  } deriving (Generic, Show)++instance GQLType Level where+  type KIND Level = ENUM++instance GQLType TwoCon where+  type KIND TwoCon = ENUM++instance GQLType ThreeCon where+  type KIND ThreeCon = ENUM++-- query+testRes :: TestArgs a -> IORes a+testRes TestArgs {level} = return level++-- resolver+data Query = Query+  { test  :: TestArgs Level -> IORes Level+  , test2 :: TestArgs TwoCon -> IORes TwoCon+  , test3 :: TestArgs ThreeCon -> IORes ThreeCon+  } deriving (Generic)++rootResolver :: GQLRootResolver IO () () Query () ()+rootResolver =+  GQLRootResolver+    { queryResolver = return Query {test = testRes, test2 = testRes, test3 = testRes}+    , mutationResolver = return ()+    , subscriptionResolver = return ()+    }++api :: ByteString -> IO ByteString+api = interpreter rootResolver
+ test/Feature/Input/Enum/cases.json view
@@ -0,0 +1,42 @@+[+  {+    "path": "decode2Con",+    "description": "decode string to correct Haskell Enum Representation"+  },+  {+    "path": "decode3Con",+    "description": "decode string to correct Haskell Enum Representation"+  },+  {+    "path": "decodeMany/con0",+    "description": "decode string to correct Haskell Enum Representation"+  },+  {+    "path": "decodeMany/con1",+    "description": "decode string to correct Haskell Enum Representation"+  },+  {+    "path": "decodeMany/con2",+    "description": "decode string to correct Haskell Enum Representation"+  },+  {+    "path": "decodeMany/con3",+    "description": "decode string to correct Haskell Enum Representation"+  },+  {+    "path": "decodeMany/con4",+    "description": "decode string to correct Haskell Enum Representation"+  },+  {+    "path": "decodeMany/con5",+    "description": "decode string to correct Haskell Enum Representation"+  },+  {+    "path": "decodeMany/con6",+    "description": "decode string to correct Haskell Enum Representation"+  },+  {+    "path":"decodeInvalidValue",+    "description":"fail on invalid enum value"+  }+]
+ test/Feature/Input/Enum/decode2Con/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+  test2 (level:LA)+}
+ test/Feature/Input/Enum/decode2Con/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "test2": "LA"+  }+}
+ test/Feature/Input/Enum/decode3Con/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+  test3 (level:T1)+}
+ test/Feature/Input/Enum/decode3Con/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "test3": "T1"+  }+}
+ test/Feature/Input/Enum/decodeInvalidValue/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+  test2 (level:LK)+}
+ test/Feature/Input/Enum/decodeInvalidValue/response.json view
@@ -0,0 +1,13 @@+{+  "errors": [+    {+      "message": "Argument level got invalid value ; Expected type \"TwoCon\" found \"LK\".",+      "locations": [+        {+          "line": 2,+          "column": 16+        }+      ]+    }+  ]+}
+ test/Feature/Input/Enum/decodeMany/con0/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+  test (level:L0)+}
+ test/Feature/Input/Enum/decodeMany/con0/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "test":  "L0"+  }+}
+ test/Feature/Input/Enum/decodeMany/con1/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+  test (level:L1)+}
+ test/Feature/Input/Enum/decodeMany/con1/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "test": "L1"+  }+}
+ test/Feature/Input/Enum/decodeMany/con2/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+  test (level:L2)+}
+ test/Feature/Input/Enum/decodeMany/con2/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "test": "L2"+  }+}
+ test/Feature/Input/Enum/decodeMany/con3/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+  test (level:L3)+}
+ test/Feature/Input/Enum/decodeMany/con3/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "test": "L3"+  }+}
+ test/Feature/Input/Enum/decodeMany/con4/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+  test (level:L4)+}
+ test/Feature/Input/Enum/decodeMany/con4/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "test": "L4"+  }+}
+ test/Feature/Input/Enum/decodeMany/con5/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+  test (level:L5)+}
+ test/Feature/Input/Enum/decodeMany/con5/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "test": "L5"+  }+}
+ test/Feature/Input/Enum/decodeMany/con6/query.gql view
@@ -0,0 +1,3 @@+query ValidDecoding {+  test (level:L6)+}
+ test/Feature/Input/Enum/decodeMany/con6/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "test": "L6"+  }+}
test/Feature/InputType/API.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -10,13 +9,11 @@  import           Data.ByteString.Lazy.Char8 (ByteString) import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (KIND, OBJECT)-import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType (..), ResM)+import           Data.Morpheus.Kind         (OBJECT)+import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType (..), IORes) import           Data.Text                  (Text) import           GHC.Generics               (Generic) -type instance KIND A = OBJECT- data F1Args = F1Args   { arg1 :: Text   , arg2 :: Maybe Int@@ -28,15 +25,18 @@   } deriving (Generic)  data A = A-  { a1 :: F1Args -> ResM Text-  , a2 :: F2Args -> ResM Int-  } deriving (Generic, GQLType)+  { a1 :: F1Args -> IORes Text+  , a2 :: F2Args -> IORes Int+  } deriving (Generic) +instance GQLType A where+  type KIND A = OBJECT+ newtype Query = Query   { q1 :: A   } deriving (Generic) -rootResolver :: GQLRootResolver IO Query () ()+rootResolver :: GQLRootResolver IO () () Query () () rootResolver =   GQLRootResolver     { queryResolver = return Query {q1 = A {a1 = const $ return "a1Test", a2 = const $ return 1}}
test/Feature/Schema/A2.hs view
@@ -1,17 +1,17 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric  #-}-{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies  #-}  module Feature.Schema.A2   ( A(..)   ) where -import           Data.Morpheus.Kind  (KIND, OBJECT)+import           Data.Morpheus.Kind  (OBJECT) import           Data.Morpheus.Types (GQLType (..)) import           GHC.Generics        (Generic) -type instance KIND A = OBJECT- newtype A = A   { bla :: Int-  } deriving (Generic, GQLType)+  } deriving (Generic)++instance GQLType A where+  type KIND A = OBJECT
test/Feature/Schema/API.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -10,25 +9,26 @@  import           Data.ByteString.Lazy.Char8 (ByteString) import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (KIND, OBJECT)+import           Data.Morpheus.Kind         (OBJECT) import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType (..)) import           Data.Text                  (Text) import qualified Feature.Schema.A2          as A2 (A (..)) import           GHC.Generics               (Generic) -type instance KIND A = OBJECT- data A = A   { aText :: Text   , aInt  :: Int-  } deriving (Generic, GQLType)+  } deriving (Generic) +instance GQLType A where+  type KIND A = OBJECT+ data Query = Query   { a1 :: A   , a2 :: A2.A   } deriving (Generic) -rootResolver :: GQLRootResolver IO Query () ()+rootResolver :: GQLRootResolver IO () () Query () () rootResolver =   GQLRootResolver     { queryResolver = return Query {a1 = A "" 0, a2 = A2.A 0}
test/Feature/UnionType/API.hs view
@@ -10,48 +10,52 @@  import           Data.ByteString.Lazy.Char8 (ByteString) import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (KIND, OBJECT, UNION)-import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType (..), ResM)+import           Data.Morpheus.Kind         (OBJECT, UNION)+import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType (..), IORes) import           Data.Text                  (Text) import           GHC.Generics               (Generic) -type instance KIND A = OBJECT+instance GQLType A where+  type KIND A = OBJECT -type instance KIND B = OBJECT+instance GQLType B where+  type KIND B = OBJECT -type instance KIND C = OBJECT+instance GQLType C where+  type KIND C = OBJECT -type instance KIND AOrB = UNION+instance GQLType AOrB where+  type KIND AOrB = UNION  data A = A   { aText :: Text   , aInt  :: Int-  } deriving (Generic, GQLType)+  } deriving (Generic)  data B = B   { bText :: Text   , bInt  :: Int-  } deriving (Generic, GQLType)+  } deriving (Generic)  data C = C   { cText :: Text   , cInt  :: Int-  } deriving (Generic, GQLType)+  } deriving (Generic)  data AOrB   = A' A   | B' B-  deriving (Generic, GQLType)+  deriving (Generic)  data Query = Query-  { union :: () -> ResM [AOrB]+  { union :: () -> IORes [AOrB]   , fc    :: C   } deriving (Generic) -resolveUnion :: () -> ResM [AOrB]+resolveUnion :: () -> IORes [AOrB] resolveUnion _ = return [A' A {aText = "at", aInt = 1}, B' B {bText = "bt", bInt = 2}] -rootResolver :: GQLRootResolver IO Query () ()+rootResolver :: GQLRootResolver IO () () Query () () rootResolver =   GQLRootResolver     { queryResolver = return Query {union = resolveUnion, fc = C {cText = "", cInt = 3}}
test/Feature/WrappedTypeName/API.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -10,49 +9,62 @@  import           Data.ByteString.Lazy.Char8 (ByteString) import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (KIND, OBJECT)-import           Data.Morpheus.Types        (EffectM, GQLRootResolver (..), GQLType (..), ResM)+import           Data.Morpheus.Kind         (OBJECT)+import           Data.Morpheus.Types        (Event (..), GQLRootResolver (..), GQLType (..), IOMutRes, IORes, IOSubRes) import           Data.Text                  (Text)+import           Data.Typeable              (Typeable) import           GHC.Generics               (Generic) -type instance KIND (WA a) = OBJECT+instance Typeable a => GQLType (WA a) where+  type KIND (WA a) = OBJECT -type instance KIND (Wrapped a b) = OBJECT+instance (Typeable a, Typeable b) => GQLType (Wrapped a b) where+  type KIND (Wrapped a b) = OBJECT  data Wrapped a b = Wrapped   { fieldA :: a   , fieldB :: b-  } deriving (Generic, GQLType)+  } deriving (Generic)  data WA m = WA   { aText :: () -> m Text   , aInt  :: Int-  } deriving (Generic, GQLType)+  } deriving (Generic)  data Query = Query-  { a1 :: WA ResM+  { a1 :: WA IORes   , a2 :: Maybe (Wrapped Int Int)   , a3 :: Maybe (Wrapped (Wrapped Text Int) Text)   } deriving (Generic)  data Mutation = Mutation-  { mut1 :: Maybe (WA EffectM)+  { mut1 :: Maybe (WA (IOMutRes EVENT ()))   , mut2 :: Maybe (Wrapped Int Int)   , mut3 :: Maybe (Wrapped (Wrapped Text Int) Text)   } deriving (Generic) +data EVENT =+  EVENT+  deriving (Show, Eq)+ data Subscription = Subscription-  { sub1 :: Maybe (WA EffectM)-  , sub2 :: Maybe (Wrapped Int Int)-  , sub3 :: Maybe (Wrapped (Wrapped Text Int) Text)+  { sub1 :: () -> IOSubRes EVENT () (Maybe (WA IORes))+  , sub2 :: () -> IOSubRes EVENT () (Maybe (Wrapped Int Int))+  , sub3 :: () -> IOSubRes EVENT () (Maybe (Wrapped (Wrapped Text Int) Text))   } deriving (Generic) -rootResolver :: GQLRootResolver IO Query Mutation Subscription+rootResolver :: GQLRootResolver IO EVENT () Query Mutation Subscription rootResolver =   GQLRootResolver     { queryResolver = return Query {a1 = WA {aText = const $ pure "test1", aInt = 0}, a2 = Nothing, a3 = Nothing}     , mutationResolver = return Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing}-    , subscriptionResolver = return Subscription {sub1 = Nothing, sub2 = Nothing, sub3 = Nothing}+    , subscriptionResolver =+        return+          Subscription+            { sub1 = const $ Event [EVENT] (const $ return Nothing)+            , sub2 = const $ Event [EVENT] (const $ return Nothing)+            , sub3 = const $ Event [EVENT] (const $ return Nothing)+            }     }  api :: ByteString -> IO ByteString
test/Spec.hs view
@@ -5,6 +5,7 @@   ) where  import qualified Feature.Holistic.API        as Holistic (api)+import qualified Feature.Input.Enum.API      as InputEnum (api) import qualified Feature.InputType.API       as InputType (api) import qualified Feature.Schema.API          as Schema (api) import qualified Feature.UnionType.API       as UnionType (api)@@ -19,4 +20,5 @@   inputTest <- testFeature InputType.api "Feature/InputType"   schemaTest <- testFeature Schema.api "Feature/Schema"   typeName <- testFeature TypeName.api "Feature/WrappedTypeName"-  defaultMain (testGroup "Morpheus Graphql Tests" [ioTests, unionTest, inputTest, schemaTest, typeName])+  inputEnum <- testFeature InputEnum.api "Feature/Input/Enum"+  defaultMain (testGroup "Morpheus Graphql Tests" [ioTests, unionTest, inputTest, schemaTest, typeName, inputEnum])
test/TestFeature.hs view
@@ -37,6 +37,7 @@   testCaseVariables <- maybeVariables path'   expectedValue <- getResponseBody path'   gqlResponse <- testApi $ packGQLRequest testCaseQuery testCaseVariables+    case decode gqlResponse of     Nothing -> assertFailure "Bad Response"     Just response -> return $ testCase (unpack path' ++ " | " ++ description') $ customTest expectedValue response