Retrieve resolver arguments from the reader

CHANGELOG.md

@@ -9,6 +9,7 @@ and this project adheres to
 ## [Unreleased]
 ### Added
 - AST for the GraphQL schema.
+- `Trans.argument`.
 
 ### Changed
 - Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.
@@ -25,6 +26,10 @@ and this project adheres to
   3 corresponding data constructors, `Field`, `InlineFragment` and
   `FragmentSpread`, instead of separate types. It simplifies pattern matching
   and doesn't make the code less typesafe.
+- `Schema.scalarA`.
+- `Schema.wrappedScalarA`.
+- `Schema.wrappedObjectA`.
+- `Schema.objectA`.
 
 ## [0.6.1.0] - 2019-12-23
 ### Fixed

docs/tutorial/tutorial.lhs

@@ -16,7 +16,6 @@ Since this file is a literate haskell file, we start by importing some dependenc
 > module Main where
 >
 > import Control.Monad.IO.Class (liftIO)
-> import Control.Monad.Trans.Except (throwE)
 > import Data.Aeson (encode)
 > import Data.ByteString.Lazy.Char8 (putStrLn)
 > import Data.List.NonEmpty (NonEmpty(..))
@@ -25,7 +24,6 @@ Since this file is a literate haskell file, we start by importing some dependenc
 >
 > import Language.GraphQL
 > import qualified Language.GraphQL.Schema as Schema
-> import Language.GraphQL.Trans (ActionT(..))
 >
 > import Prelude hiding (putStrLn)
 
@@ -70,10 +68,9 @@ For this example, we're going to be using time.
 > schema2 = time :| []
 >
 > time :: Schema.Resolver IO
-> time = Schema.scalarA "time" $ \case
+> time = Schema.scalar "time" $ do
->   [] -> do t <- liftIO getCurrentTime
+>   t <- liftIO getCurrentTime
->            return $ show t
+>   return $ show t
->   _ -> ActionT $ throwE "Invalid arguments."
 
 This defines a simple schema with one type and one field,
 which resolves to the current time.

src/Language/GraphQL/Schema.hs

@@ -6,14 +6,10 @@ module Language.GraphQL.Schema
     ( Resolver
     , Subs
     , object
-    , objectA
     , scalar
-    , scalarA
     , resolve
     , wrappedObject
-    , wrappedObjectA
     , wrappedScalar
-    , wrappedScalarA
     -- * AST Reexports
     , Field
     , Argument(..)
@@ -50,64 +46,55 @@ type Subs = HashMap Name Value
 
 -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
 object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m
-object name = objectA name . const
+object name f = Resolver name $ resolveFieldValue f resolveRight
-
--- | Like 'object' but also taking 'Argument's.
-objectA :: MonadIO m
-    => Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
-objectA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
 
--- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
+-- | Like 'object' but can be null or a list of objects.
-wrappedObjectA :: MonadIO m
+wrappedObject ::
-    => Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m
+    MonadIO m =>
-wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
+    Name ->
+    ActionT m (Type.Wrapping [Resolver m]) ->
+    Resolver m
+wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld@(Field _ _ _ sels) resolver
         = withField (traverse (`resolve` sels) resolver) fld
 
--- | Like 'object' but can be null or a list of objects.
-wrappedObject :: MonadIO m
-    => Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m
-wrappedObject name = wrappedObjectA name . const
-
 -- | A scalar represents a primitive value, like a string or an integer.
 scalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
-scalar name = scalarA name . const
+scalar name f = Resolver name $ resolveFieldValue f resolveRight
-
--- | Like 'scalar' but also taking 'Argument's.
-scalarA :: (MonadIO m, Aeson.ToJSON a)
-    => Name -> ([Argument] -> ActionT m a) -> Resolver m
-scalarA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld result = withField (return result) fld
 
--- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars.
+-- | Like 'scalar' but can be null or a list of scalars.
-wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
+wrappedScalar ::
-    => Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m
+    (MonadIO m, Aeson.ToJSON a) =>
-wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
+    Name ->
+    ActionT m (Type.Wrapping a) ->
+    Resolver m
+wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld (Type.Named result) = withField (return result) fld
     resolveRight fld Type.Null
         = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
     resolveRight fld (Type.List result) = withField (return result) fld
 
--- | Like 'scalar' but can be null or a list of scalars.
+resolveFieldValue ::
-wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
+    MonadIO m =>
-    => Name -> ActionT m (Type.Wrapping a) -> Resolver m
+    ActionT m a ->
-wrappedScalar name = wrappedScalarA name . const
+    (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value)) ->
-
+    Field ->
-resolveFieldValue :: MonadIO m
+    CollectErrsT m (HashMap Text Aeson.Value)
-    => ([Argument] -> ActionT m a)
-    -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
-    -> Field
-    -> CollectErrsT m (HashMap Text Aeson.Value)
 resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
-    result <- lift $ reader . runExceptT . runActionT $ f args
+    result <- lift $ reader . runExceptT . runActionT $ f
     either resolveLeft (resolveRight fld) result
       where
-        reader = flip runReaderT $ Context mempty
+        reader = flip runReaderT
+            $ Context
+            $ HashMap.fromList
+            $ argumentToTuple <$> args
+        argumentToTuple (Argument name value) = (name, value)
         resolveLeft err = do
             _ <- addErrMsg err
             return $ HashMap.singleton (aliasOrName fld) Aeson.Null

src/Language/GraphQL/Trans.hs

@@ -2,6 +2,7 @@
 module Language.GraphQL.Trans
     ( ActionT(..)
     , Context(Context)
+    , argument
     ) where
 
 import Control.Applicative (Alternative(..))
@@ -9,10 +10,13 @@ import Control.Monad (MonadPlus(..))
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Except (ExceptT)
-import Control.Monad.Trans.Reader (ReaderT)
+import Control.Monad.Trans.Reader (ReaderT, asks)
 import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
-import Language.GraphQL.AST.Core (Name, Value)
+import Language.GraphQL.AST.Core
+import Prelude hiding (lookup)
 
 -- | Resolution context holds resolver arguments.
 newtype Context = Context (HashMap Name Value)
@@ -47,3 +51,13 @@ instance Monad m => Alternative (ActionT m) where
 instance Monad m => MonadPlus (ActionT m) where
     mzero = empty
     mplus = (<|>)
+
+-- | Retrieves an argument by its name. If the argument with this name couldn't
+--   be found, returns 'Value.Null' (i.e. the argument is assumed to
+--   be optional then).
+argument :: MonadIO m => Name -> ActionT m Value
+argument argumentName = do
+    argumentValue <- ActionT $ lift $ asks lookup
+    pure $ fromMaybe Null argumentValue
+  where
+    lookup (Context argumentMap) = HashMap.lookup argumentName argumentMap

tests/Test/StarWars/Schema.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Test.StarWars.Schema
     ( character
@@ -8,9 +7,9 @@ module Test.StarWars.Schema
     , schema
     ) where
 
+import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.Except (throwE)
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.IO.Class (MonadIO(..))
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe (catMaybes)
 import qualified Language.GraphQL.Schema as Schema
@@ -24,26 +23,31 @@ schema :: MonadIO m => NonEmpty (Schema.Resolver m)
 schema = hero :| [human, droid]
 
 hero :: MonadIO m => Schema.Resolver m
-hero = Schema.objectA "hero" $ \case
+hero = Schema.object "hero" $ do
-  [] -> character artoo
+  episode <- argument "episode"
-  [Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4
+  character $ case episode of
-  [Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5
+      Schema.Enum "NEWHOPE" -> getHero 4
-  [Schema.Argument "episode" (Schema.Enum "JEDI"   )] -> character $ getHero 6
+      Schema.Enum "EMPIRE" -> getHero 5
-  _ -> ActionT $ throwE "Invalid arguments."
+      Schema.Enum "JEDI" -> getHero 6
+      _ -> artoo
 
 human :: MonadIO m => Schema.Resolver m
-human = Schema.wrappedObjectA "human" $ \case
+human = Schema.wrappedObject "human" $ do
-  [Schema.Argument "id" (Schema.String i)] -> do
+    id' <- argument "id"
-      humanCharacter <- lift $ return $ getHuman i >>= Just
+    case id' of
-      case humanCharacter of
+        Schema.String i -> do
-        Nothing -> return Type.Null
+            humanCharacter <- lift $ return $ getHuman i >>= Just
-        Just e -> Type.Named <$> character e
+            case humanCharacter of
-  _ -> ActionT $ throwE "Invalid arguments."
+                Nothing -> return Type.Null
+                Just e -> Type.Named <$> character e
+        _ -> ActionT $ throwE "Invalid arguments."
 
 droid :: MonadIO m => Schema.Resolver m
-droid = Schema.objectA "droid" $ \case
+droid = Schema.object "droid" $ do
-   [Schema.Argument "id" (Schema.String i)] -> character =<< liftIO (getDroid i)
+    id' <- argument "id"
-   _ -> ActionT $ throwE "Invalid arguments."
+    case id' of
+        Schema.String i -> character =<< liftIO (getDroid i)
+        _ -> ActionT $ throwE "Invalid arguments."
 
 character :: MonadIO m => Character -> ActionT m [Schema.Resolver m]
 character char = return