Introduce monad transformer for resolvers
Now the errors in the resolvers can be handled and 3 tests throwing errors pass now. Another test fail but it requires distinguisching nullable and non-nullable values.
This commit is contained in:
parent
1017b728d9
commit
91679650b5
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 4035f9ebd6df2085ad80f5918fc5a65f22b2699f620f7f03c2a3e58ac84827d6
|
||||
-- hash: 83313d55668f177f44fe72b0e590759e61e44093406bd0e7d41af66dd9199c92
|
||||
|
||||
name: graphql
|
||||
version: 0.3
|
||||
|
|
@ -47,6 +47,7 @@ library
|
|||
Data.GraphQL.Parser
|
||||
Data.GraphQL.Schema
|
||||
Language.GraphQL.Lexer
|
||||
Language.GraphQL.Trans
|
||||
other-modules:
|
||||
Paths_graphql
|
||||
hs-source-dirs:
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
||||
-- functions for defining and manipulating Schemas.
|
||||
module Data.GraphQL.Schema
|
||||
|
|
@ -25,12 +25,9 @@ module Data.GraphQL.Schema
|
|||
, Value(..)
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Control.Monad (MonadPlus)
|
||||
import Control.Monad (MonadPlus(..))
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.State ( get
|
||||
, put
|
||||
)
|
||||
import Control.Monad.Trans.Except (runExceptT)
|
||||
import Data.Foldable ( find
|
||||
, fold
|
||||
)
|
||||
|
|
@ -42,7 +39,7 @@ import Data.HashMap.Strict (HashMap)
|
|||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Language.GraphQL.Trans
|
||||
import Data.GraphQL.AST.Core
|
||||
|
||||
-- | A GraphQL schema.
|
||||
|
|
@ -63,104 +60,93 @@ type Arguments = [Argument]
|
|||
type Subs = Name -> Maybe Value
|
||||
|
||||
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
|
||||
object :: MonadPlus m => Name -> [Resolver m] -> Resolver m
|
||||
object name resolvers = objectA name $ \case
|
||||
[] -> resolvers
|
||||
_ -> empty
|
||||
object :: MonadPlus m => Name -> ActionT m [Resolver m] -> Resolver m
|
||||
object name = objectA name . const
|
||||
|
||||
-- | Like 'object' but also taking 'Argument's.
|
||||
objectA
|
||||
:: MonadPlus m
|
||||
=> Name -> (Arguments -> [Resolver m]) -> Resolver m
|
||||
objectA name f = Resolver name go
|
||||
objectA :: MonadPlus m
|
||||
=> Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
|
||||
objectA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
go fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld
|
||||
|
||||
resolveRight fld@(Field _ _ _ flds) resolver = withField name (resolve resolver flds) fld
|
||||
|
||||
-- | Create a named 'Resolver' from a list of 'Resolver's.
|
||||
object' :: MonadPlus m => Name -> m [Resolver m] -> Resolver m
|
||||
object' name resolvs = objectA' name $ \case
|
||||
[] -> resolvs
|
||||
_ -> empty
|
||||
object' :: MonadPlus m => Name -> ActionT m [Resolver m] -> Resolver m
|
||||
object' name = objectA' name . const
|
||||
|
||||
-- | Like 'object'' but also taking 'Argument's.
|
||||
objectA'
|
||||
:: MonadPlus m
|
||||
=> Name -> (Arguments -> m [Resolver m]) -> Resolver m
|
||||
objectA' name f = Resolver name go
|
||||
objectA' :: MonadPlus m
|
||||
=> Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
|
||||
objectA' name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
go fld@(Field _ _ args flds) = do
|
||||
resolvs <- lift $ f args
|
||||
withField name (resolve resolvs flds) fld
|
||||
resolveRight fld@(Field _ _ _ flds) resolver = withField name (resolve resolver flds) fld
|
||||
|
||||
-- | A scalar represents a primitive value, like a string or an integer.
|
||||
scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> a -> Resolver m
|
||||
scalar name s = scalarA name $ \case
|
||||
[] -> pure s
|
||||
_ -> empty
|
||||
scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
|
||||
scalar name = scalarA name . const
|
||||
|
||||
-- | Like 'scalar' but also taking 'Argument's.
|
||||
scalarA
|
||||
:: (MonadPlus m, Aeson.ToJSON a)
|
||||
=> Name -> (Arguments -> m a) -> Resolver m
|
||||
scalarA name f = Resolver name go
|
||||
scalarA :: (MonadPlus m, Aeson.ToJSON a)
|
||||
=> Name -> (Arguments -> ActionT m a) -> Resolver m
|
||||
scalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
go fld@(Field _ _ args []) = withField name (lift $ f args) fld
|
||||
go _ = empty
|
||||
resolveRight fld@(Field _ _ _ []) result = withField name (return result) fld
|
||||
resolveRight _ _ = mzero
|
||||
|
||||
array :: MonadPlus m => Name -> [[Resolver m]] -> Resolver m
|
||||
array name resolvers = arrayA name $ \case
|
||||
[] -> resolvers
|
||||
_ -> empty
|
||||
array :: MonadPlus m => Name -> ActionT m [[Resolver m]] -> Resolver m
|
||||
array name = arrayA name . const
|
||||
|
||||
-- | Like 'array' but also taking 'Argument's.
|
||||
arrayA
|
||||
:: MonadPlus m
|
||||
=> Name -> (Arguments -> [[Resolver m]]) -> Resolver m
|
||||
arrayA name f = Resolver name go
|
||||
arrayA :: MonadPlus m
|
||||
=> Name -> (Arguments -> ActionT m [[Resolver m]]) -> Resolver m
|
||||
arrayA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
go fld@(Field _ _ args sels) = withField name (traverse (`resolve` sels) $ f args) fld
|
||||
resolveRight fld@(Field _ _ _ sels) resolver
|
||||
= withField name (traverse (`resolve` sels) resolver) fld
|
||||
|
||||
-- | Like 'object'' but taking lists of 'Resolver's instead of a single list.
|
||||
array' :: MonadPlus m => Name -> m [[Resolver m]] -> Resolver m
|
||||
array' name resolvs = arrayA' name $ \case
|
||||
[] -> resolvs
|
||||
_ -> empty
|
||||
array' :: MonadPlus m => Name -> ActionT m [[Resolver m]] -> Resolver m
|
||||
array' name = arrayA' name . const
|
||||
|
||||
-- | Like 'array'' but also taking 'Argument's.
|
||||
arrayA'
|
||||
:: MonadPlus m
|
||||
=> Name -> (Arguments -> m [[Resolver m]]) -> Resolver m
|
||||
arrayA' name f = Resolver name go
|
||||
arrayA' :: MonadPlus m
|
||||
=> Name -> (Arguments -> ActionT m [[Resolver m]]) -> Resolver m
|
||||
arrayA' name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
go fld@(Field _ _ args sels) = do
|
||||
resolvs <- lift $ f args
|
||||
withField name (traverse (`resolve` sels) resolvs) fld
|
||||
resolveRight fld@(Field _ _ _ sels) resolver
|
||||
= withField name (traverse (`resolve` sels) resolver) fld
|
||||
|
||||
-- | Represents one of a finite set of possible values.
|
||||
-- Used in place of a 'scalar' when the possible responses are easily enumerable.
|
||||
enum :: MonadPlus m => Name -> m [Text] -> Resolver m
|
||||
enum name enums = enumA name $ \case
|
||||
[] -> enums
|
||||
_ -> empty
|
||||
enum :: MonadPlus m => Name -> ActionT m [Text] -> Resolver m
|
||||
enum name = enumA name . const
|
||||
|
||||
-- | Like 'enum' but also taking 'Argument's.
|
||||
enumA :: MonadPlus m => Name -> (Arguments -> m [Text]) -> Resolver m
|
||||
enumA name f = Resolver name go
|
||||
enumA :: MonadPlus m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
|
||||
enumA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
go fld@(Field _ _ args []) = withField name (lift $ f args) fld
|
||||
go _ = empty
|
||||
resolveRight fld resolver = withField name (return resolver) fld
|
||||
|
||||
resolveFieldValue :: MonadPlus m
|
||||
=> ([Argument] -> ActionT m a)
|
||||
-> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
|
||||
-> Field
|
||||
-> CollectErrsT m (HashMap Text Aeson.Value)
|
||||
resolveFieldValue f resolveRight fld@(Field alias name args _) = do
|
||||
result <- lift $ runExceptT . runActionT $ f args
|
||||
either resolveLeft (resolveRight fld) result
|
||||
where
|
||||
resolveLeft err = do
|
||||
_ <- addErrMsg err
|
||||
return $ HashMap.singleton (fromMaybe name alias) Aeson.Null
|
||||
|
||||
-- | Helper function to facilitate 'Argument' handling.
|
||||
withField :: (MonadPlus m, Aeson.ToJSON a)
|
||||
=> Name -> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
|
||||
withField name v (Field alias _ _ _) = do
|
||||
collection <- HashMap.singleton aliasOrName . Aeson.toJSON <$> runAppendErrs v
|
||||
errors <- get
|
||||
if null errors
|
||||
then return collection
|
||||
-- TODO: Report error when Non-Nullable type for field argument.
|
||||
else put [] >> return (HashMap.singleton aliasOrName Aeson.Null)
|
||||
=> Name -> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
|
||||
withField name v (Field alias _ _ _)
|
||||
= HashMap.singleton aliasOrName . Aeson.toJSON <$> runAppendErrs v
|
||||
{- TODO: Report error when Non-Nullable type for field argument.
|
||||
else return (HashMap.singleton aliasOrName Aeson.Null) -}
|
||||
where
|
||||
aliasOrName = fromMaybe name alias
|
||||
|
||||
|
|
@ -168,10 +154,10 @@ withField name v (Field alias _ _ _) = do
|
|||
-- 'Resolver' to each 'Field'. Resolves into a value containing the
|
||||
-- resolved 'Field', or a null value and error information.
|
||||
resolve :: MonadPlus m
|
||||
=> [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
|
||||
=> [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
|
||||
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
|
||||
where
|
||||
tryResolvers fld = maybe empty (tryResolver fld) (find (compareResolvers fld) resolvers) <|> errmsg fld
|
||||
tryResolvers fld = mplus (maybe mzero (tryResolver fld) $ find (compareResolvers fld) resolvers) $ errmsg fld
|
||||
compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
|
||||
tryResolver fld (Resolver _ resolver) = resolver fld
|
||||
errmsg (Field alias name _ _) = do
|
||||
|
|
|
|||
|
|
@ -0,0 +1,35 @@
|
|||
module Language.GraphQL.Trans where
|
||||
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Control.Monad (MonadPlus(..))
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import Data.Text (Text)
|
||||
|
||||
newtype ActionT m a = ActionT { runActionT :: ExceptT Text m a }
|
||||
|
||||
instance Functor m => Functor (ActionT m) where
|
||||
fmap f = ActionT . fmap f . runActionT
|
||||
|
||||
instance Monad m => Applicative (ActionT m) where
|
||||
pure = ActionT . pure
|
||||
(ActionT f) <*> (ActionT x) = ActionT $ f <*> x
|
||||
|
||||
instance Monad m => Monad (ActionT m) where
|
||||
return = pure
|
||||
(ActionT action) >>= f = ActionT $ action >>= runActionT . f
|
||||
|
||||
instance MonadTrans ActionT where
|
||||
lift = ActionT . lift
|
||||
|
||||
instance MonadIO m => MonadIO (ActionT m) where
|
||||
liftIO = lift . liftIO
|
||||
|
||||
instance Monad m => Alternative (ActionT m) where
|
||||
empty = ActionT empty
|
||||
(ActionT x) <|> (ActionT y) = ActionT $ x <|> y
|
||||
|
||||
instance Monad m => MonadPlus (ActionT m) where
|
||||
mzero = empty
|
||||
mplus = (<|>)
|
||||
|
|
@ -2,10 +2,12 @@
|
|||
module Test.StarWars.Data where
|
||||
|
||||
import Data.Monoid (mempty)
|
||||
import Control.Applicative (Alternative, (<|>), empty, liftA2)
|
||||
import Control.Applicative (liftA2)
|
||||
import Control.Monad (MonadPlus(..))
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Maybe (catMaybes)
|
||||
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.Trans
|
||||
|
||||
-- * Data
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
|
||||
|
|
@ -50,8 +52,8 @@ appearsIn :: Character -> [Int]
|
|||
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
||||
appearsIn (Right x) = _appearsIn . _humanChar $ x
|
||||
|
||||
secretBackstory :: Character -> Text
|
||||
secretBackstory = error "secretBackstory is secret."
|
||||
secretBackstory :: MonadPlus m => Character -> ActionT m Text
|
||||
secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
|
||||
|
||||
typeName :: Character -> Text
|
||||
typeName = either (const "Droid") (const "Human")
|
||||
|
|
@ -148,30 +150,30 @@ getHero _ = artoo
|
|||
getHeroIO :: Int -> IO Character
|
||||
getHeroIO = pure . getHero
|
||||
|
||||
getHuman :: Alternative f => ID -> f Character
|
||||
getHuman :: MonadPlus m => ID -> m Character
|
||||
getHuman = fmap Right . getHuman'
|
||||
|
||||
getHuman' :: Alternative f => ID -> f Human
|
||||
getHuman' :: MonadPlus m => ID -> m Human
|
||||
getHuman' "1000" = pure luke'
|
||||
getHuman' "1001" = pure vader
|
||||
getHuman' "1002" = pure han
|
||||
getHuman' "1003" = pure leia
|
||||
getHuman' "1004" = pure tarkin
|
||||
getHuman' _ = empty
|
||||
getHuman' _ = mzero
|
||||
|
||||
getDroid :: Alternative f => ID -> f Character
|
||||
getDroid :: MonadPlus m => ID -> m Character
|
||||
getDroid = fmap Left . getDroid'
|
||||
|
||||
getDroid' :: Alternative f => ID -> f Droid
|
||||
getDroid' :: MonadPlus m => ID -> m Droid
|
||||
getDroid' "2000" = pure threepio
|
||||
getDroid' "2001" = pure artoo'
|
||||
getDroid' _ = empty
|
||||
getDroid' _ = mzero
|
||||
|
||||
getFriends :: Character -> [Character]
|
||||
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
|
||||
getFriends char = catMaybes $ liftA2 mplus getDroid getHuman <$> friends char
|
||||
|
||||
getEpisode :: Alternative f => Int -> f Text
|
||||
getEpisode :: MonadPlus m => Int -> m Text
|
||||
getEpisode 4 = pure "NEWHOPE"
|
||||
getEpisode 5 = pure "EMPIRE"
|
||||
getEpisode 6 = pure "JEDI"
|
||||
getEpisode _ = empty
|
||||
getEpisode _ = mzero
|
||||
|
|
|
|||
|
|
@ -2,8 +2,10 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Test.StarWars.QueryTests (test) where
|
||||
|
||||
import qualified Data.Aeson as Aeson (Value(Null), toJSON)
|
||||
import Data.Aeson (object, (.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Aeson ( object
|
||||
, (.=)
|
||||
)
|
||||
import Data.Text (Text)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
|
|
@ -258,20 +260,26 @@ test = testGroup "Star Wars Query Tests"
|
|||
]
|
||||
, testGroup "Errors in resolvers"
|
||||
[ testCase "error on secretBackstory" . testQuery
|
||||
[r| query HeroNameQuery {
|
||||
hero {
|
||||
name
|
||||
[r|
|
||||
query HeroNameQuery {
|
||||
hero {
|
||||
name
|
||||
secretBackstory
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object ["data" .= object [
|
||||
"hero" .= [r2d2Name, secretBackstory]
|
||||
]
|
||||
, "errors" .= object [
|
||||
"message" .= Aeson.toJSON [secretText]
|
||||
, "path" .= Aeson.toJSON [[ "hero" :: Text, "secretBackstory" :: Text ]]
|
||||
]]
|
||||
}
|
||||
|]
|
||||
$ object
|
||||
[ "data" .= object
|
||||
[ "hero" .= object
|
||||
[ "name" .= ("R2-D2" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
, "errors" .=
|
||||
[ object
|
||||
["message" .= ("secretBackstory is secret." :: Text)]
|
||||
]
|
||||
]
|
||||
, testCase "Error in a list" . testQuery
|
||||
[r| query HeroNameQuery {
|
||||
hero {
|
||||
|
|
@ -283,17 +291,31 @@ test = testGroup "Star Wars Query Tests"
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object ["data" .= object [
|
||||
"hero" .= [r2d2Name, "friends" .= [
|
||||
object [lukeName, secretBackstory]
|
||||
, object [hanName, secretBackstory]
|
||||
, object [leiaName, secretBackstory]
|
||||
]]
|
||||
$ object ["data" .= object
|
||||
[ "hero" .= object
|
||||
[ "name" .= ("R2-D2" :: Text)
|
||||
, "friends" .=
|
||||
[ object
|
||||
[ "name" .= ("Luke Skywalker" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
, object
|
||||
[ "name" .= ("Han Solo" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
, object
|
||||
[ "name" .= ("Leia Organa" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
, "errors" .=
|
||||
[ object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
, object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
, object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
]
|
||||
]
|
||||
, "errors" .= object [
|
||||
"message" .= Aeson.toJSON [secretText, secretText, secretText]
|
||||
, "path" .= Aeson.toJSON [secretPath 0, secretPath 1, secretPath 2]
|
||||
]]
|
||||
, testCase "error on secretBackstory with alias" . testQuery
|
||||
[r| query HeroNameQuery {
|
||||
mainHero: hero {
|
||||
|
|
@ -302,14 +324,18 @@ test = testGroup "Star Wars Query Tests"
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object ["data" .= object [
|
||||
"mainHero" .= [r2d2Name, "story" .= ()]
|
||||
$ object
|
||||
[ "data" .= object
|
||||
[ "mainHero" .= object
|
||||
[ "name" .= ("R2-D2" :: Text)
|
||||
, "story" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
, "errors" .=
|
||||
[ object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
]
|
||||
]
|
||||
]
|
||||
, "errors" .= object [
|
||||
"message" .= Aeson.toJSON [secretText]
|
||||
, "path" .= Aeson.toJSON [[ "mainHero" :: Text, "story" :: Text ]]
|
||||
]]
|
||||
]
|
||||
]
|
||||
where
|
||||
lukeName = "name" .= ("Luke Skywalker" :: Text)
|
||||
|
|
@ -319,9 +345,6 @@ test = testGroup "Star Wars Query Tests"
|
|||
c3poName = "name" .= ("C-3PO" :: Text)
|
||||
tatooine = "homePlanet" .= ("Tatooine" :: Text)
|
||||
alderaan = "homePlanet" .= ("Alderaan" :: Text)
|
||||
secretBackstory = "secretBackstory" .= ()
|
||||
secretText = "secretBackstory is secret" :: Text
|
||||
secretPath n = ("hero", "friends", n, "secretBackstory") :: (Text, Text, Int, Text)
|
||||
|
||||
testQuery :: Text -> Aeson.Value -> Assertion
|
||||
testQuery q expected = graphql schema q @?= Just expected
|
||||
|
|
|
|||
|
|
@ -2,17 +2,17 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Test.StarWars.Schema where
|
||||
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Control.Monad (MonadPlus)
|
||||
import Control.Monad (MonadPlus(..))
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
|
||||
import Data.GraphQL.Schema ( Schema
|
||||
, Resolver
|
||||
, Argument(..)
|
||||
, Value(..)
|
||||
)
|
||||
import qualified Data.GraphQL.Schema as Schema
|
||||
|
||||
import Language.GraphQL.Trans
|
||||
import Test.StarWars.Data
|
||||
|
||||
-- * Schema
|
||||
|
|
@ -28,25 +28,25 @@ hero = Schema.objectA "hero" $ \case
|
|||
[Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4
|
||||
[Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5
|
||||
[Argument "episode" (ValueEnum "JEDI" )] -> character $ getHero 6
|
||||
_ -> empty
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
human :: MonadPlus m => Resolver m
|
||||
human = Schema.objectA "human" $ \case
|
||||
[Argument "id" (ValueString i)] -> character =<< getHuman i
|
||||
_ -> empty
|
||||
[Argument "id" (ValueString i)] -> character =<< lift (getHuman i)
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
droid :: MonadPlus m => Resolver m
|
||||
droid = Schema.objectA "droid" $ \case
|
||||
[Argument "id" (ValueString i)] -> character =<< getDroid i
|
||||
_ -> empty
|
||||
[Argument "id" (ValueString i)] -> character =<< lift (getDroid i)
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
character :: MonadPlus m => Character -> [Resolver m]
|
||||
character char =
|
||||
[ Schema.scalar "id" $ id_ char
|
||||
, Schema.scalar "name" $ name char
|
||||
, Schema.array "friends" $ character <$> getFriends char
|
||||
, Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char
|
||||
, Schema.scalar "secretBackstory" $ secretBackstory char
|
||||
, Schema.scalar "homePlanet" $ either mempty homePlanet char
|
||||
, Schema.scalar "__typename" $ typeName char
|
||||
]
|
||||
character :: MonadPlus m => Character -> ActionT m [Resolver m]
|
||||
character char = return
|
||||
[ Schema.scalar "id" $ return $ id_ char
|
||||
, Schema.scalar "name" $ return $ name char
|
||||
, Schema.array "friends" $ traverse character $ getFriends char
|
||||
, Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char
|
||||
, Schema.scalar "secretBackstory" $ secretBackstory char
|
||||
, Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
|
||||
, Schema.scalar "__typename" $ return $ typeName char
|
||||
]
|
||||
|
|
|
|||
Loading…
Reference in New Issue