Rewrite argument list to argument map

CHANGELOG.md

@@ -30,6 +30,8 @@ and this project adheres to
 - `Schema.wrappedScalarA`.
 - `Schema.wrappedObjectA`.
 - `Schema.objectA`.
+- `AST.Argument`. Replaced with `AST.Arguments` which holds all arguments as a
+  key/value map.
 
 ## [0.6.1.0] - 2019-12-23
 ### Fixed

semaphoreci.sh

@@ -8,7 +8,12 @@ setup() {
 	then
 		curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C $SEMAPHORE_CACHE_DIR '*/stack'
 	fi
+	if [ -e "$SEMAPHORE_CACHE_DIR/graphql.cabal" ]
+	then
+            cp -a $SEMAPHORE_CACHE_DIR/graphql.cabal graphql.cabal
+        fi
 	$STACK --no-terminal setup
+        cp -a graphql.cabal $SEMAPHORE_CACHE_DIR/graphql.cabal
 }
 
 setup_test() {

src/Language/GraphQL/AST/Core.hs

@@ -1,7 +1,6 @@
 -- | This is the AST meant to be executed.
 module Language.GraphQL.AST.Core
     ( Alias
-    , Argument(..)
     , Arguments(..)
     , Directive(..)
     , Document
@@ -35,16 +34,19 @@ data Operation
 
 -- | Single GraphQL field.
 data Field
-    = Field (Maybe Alias) Name [Argument] (Seq Selection)
+    = Field (Maybe Alias) Name Arguments (Seq Selection)
     deriving (Eq, Show)
 
--- | Single argument.
-data Argument = Argument Name Value deriving (Eq, Show)
-
 -- | Argument list.
 newtype Arguments = Arguments (HashMap Name Value)
     deriving (Eq, Show)
 
+instance Semigroup Arguments where
+    (Arguments x) <> (Arguments y) = Arguments $ x <> y
+
+instance Monoid Arguments where
+    mempty = Arguments mempty
+
 -- | Directive.
 data Directive = Directive Name Arguments
     deriving (Eq, Show)

src/Language/GraphQL/Execute/Transform.hs

@@ -60,7 +60,6 @@ operations operations' = do
 operation :: Full.OperationDefinition -> TransformT Core.Operation
 operation (Full.SelectionSet sels)
     = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
--- TODO: Validate Variable definitions with substituter
 operation (Full.OperationDefinition Full.Query name _vars _dirs sels)
     = Core.Query name <$> appendSelection sels
 operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
@@ -73,7 +72,7 @@ selection ::
     TransformT (Either (Seq Core.Selection) Core.Selection)
 selection (Full.Field alias name arguments' directives' selections) =
     maybe (Left mempty) (Right . Core.SelectionField) <$> do
-        fieldArguments <- traverse argument arguments'
+        fieldArguments <- arguments arguments'
         fieldSelections <- appendSelection selections
         fieldDirectives <- Directive.selection <$> directives directives'
         let field' = Core.Field alias name fieldArguments fieldSelections
@@ -147,12 +146,9 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
 arguments :: [Full.Argument] -> TransformT Core.Arguments
 arguments = fmap Core.Arguments . foldM go HashMap.empty
   where
-    go arguments' argument' = do
+    go arguments' (Full.Argument name value') = do
-        (Core.Argument name value') <- argument argument'
+        substitutedValue <- value value'
-        return $ HashMap.insert name value' arguments'
+        return $ HashMap.insert name substitutedValue arguments'
-
-argument :: Full.Argument -> TransformT Core.Argument
-argument (Full.Argument n v) = Core.Argument n <$> value v
 
 value :: Full.Value -> TransformT Core.Value
 value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift

src/Language/GraphQL/Schema.hs

@@ -12,7 +12,6 @@ module Language.GraphQL.Schema
     , wrappedScalar
     -- * AST Reexports
     , Field
-    , Argument(..)
     , Value(..)
     ) where
 
@@ -90,11 +89,7 @@ resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
     result <- lift $ reader . runExceptT . runActionT $ f
     either resolveLeft (resolveRight fld) result
       where
-        reader = flip runReaderT
+        reader = flip runReaderT $ Context {arguments=args}
-            $ 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

@@ -1,7 +1,7 @@
 -- | Monad transformer stack used by the @GraphQL@ resolvers.
 module Language.GraphQL.Trans
     ( ActionT(..)
-    , Context(Context)
+    , Context(..)
     , argument
     ) where
 
@@ -11,7 +11,6 @@ import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Except (ExceptT)
 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)
@@ -19,7 +18,9 @@ import Language.GraphQL.AST.Core
 import Prelude hiding (lookup)
 
 -- | Resolution context holds resolver arguments.
-newtype Context = Context (HashMap Name Value)
+newtype Context = Context
+    { arguments :: Arguments
+    }
 
 -- | Monad transformer stack used by the resolvers to provide error handling
 --   and resolution context (resolver arguments).
@@ -57,7 +58,7 @@ instance Monad m => MonadPlus (ActionT m) where
 --   be optional then).
 argument :: MonadIO m => Name -> ActionT m Value
 argument argumentName = do
-    argumentValue <- ActionT $ lift $ asks lookup
+    argumentValue <- ActionT $ lift $ asks $ lookup . arguments
     pure $ fromMaybe Null argumentValue
   where
-    lookup (Context argumentMap) = HashMap.lookup argumentName argumentMap
+    lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap