summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--graphql.cabal3
-rw-r--r--src/Data/GraphQL/Schema.hs138
-rw-r--r--src/Language/GraphQL/Trans.hs35
-rw-r--r--tests/Test/StarWars/Data.hs28
-rw-r--r--tests/Test/StarWars/QueryTests.hs91
-rw-r--r--tests/Test/StarWars/Schema.hs40
6 files changed, 191 insertions, 144 deletions
diff --git a/graphql.cabal b/graphql.cabal
index 1d40c1c..04536c7 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -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:
diff --git a/src/Data/GraphQL/Schema.hs b/src/Data/GraphQL/Schema.hs
index 0ff94f8..919235e 100644
--- a/src/Data/GraphQL/Schema.hs
+++ b/src/Data/GraphQL/Schema.hs
@@ -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
diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs
new file mode 100644
index 0000000..f0fcefb
--- /dev/null
+++ b/src/Language/GraphQL/Trans.hs
@@ -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 = (<|>)
diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs
index a710dd8..1305de3 100644
--- a/tests/Test/StarWars/Data.hs
+++ b/tests/Test/StarWars/Data.hs
@@ -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
diff --git a/tests/Test/StarWars/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs
index 736f5b4..8dde8c2 100644
--- a/tests/Test/StarWars/QueryTests.hs
+++ b/tests/Test/StarWars/QueryTests.hs
@@ -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
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index 09344fc..0abda7b 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -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
-
-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
- ]
+ [Argument "id" (ValueString i)] -> character =<< lift (getDroid i)
+ _ -> ActionT $ throwE "Invalid arguments."
+
+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
+ ]
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 22:39:55 +0000