diff --git a/CHANGELOG.md b/CHANGELOG.md index 0be063e..e88559f 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index d017ddd..fcbc3eb 100644 --- a/docs/tutorial/tutorial.lhs +++ b/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 -> [] -> do t <- liftIO getCurrentTime -> return $ show t -> _ -> ActionT $ throwE "Invalid arguments." +> time = Schema.scalar "time" $ do +> t <- liftIO getCurrentTime +> return $ show t This defines a simple schema with one type and one field, which resolves to the current time. diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index facf722..a6c37db 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/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 - --- | 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 +object 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. -wrappedObjectA :: MonadIO m - => Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m -wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight +-- | 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 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 - --- | 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 +scalar 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. -wrappedScalarA :: (MonadIO m, Aeson.ToJSON a) - => Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m -wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight +-- | Like 'scalar' but can be null or a list of scalars. +wrappedScalar :: + (MonadIO m, Aeson.ToJSON a) => + 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. -wrappedScalar :: (MonadIO m, Aeson.ToJSON a) - => Name -> ActionT m (Type.Wrapping a) -> Resolver m -wrappedScalar name = wrappedScalarA name . const - -resolveFieldValue :: MonadIO m - => ([Argument] -> ActionT m a) - -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value)) - -> Field - -> CollectErrsT m (HashMap Text Aeson.Value) +resolveFieldValue :: + MonadIO m => + 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 diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs index 4232e75..3eef904 100644 --- a/src/Language/GraphQL/Trans.hs +++ b/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 diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 7b98747..e45d7ff 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/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 - [] -> character artoo - [Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4 - [Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5 - [Schema.Argument "episode" (Schema.Enum "JEDI" )] -> character $ getHero 6 - _ -> ActionT $ throwE "Invalid arguments." +hero = Schema.object "hero" $ do + episode <- argument "episode" + character $ case episode of + Schema.Enum "NEWHOPE" -> getHero 4 + Schema.Enum "EMPIRE" -> getHero 5 + Schema.Enum "JEDI" -> getHero 6 + _ -> artoo human :: MonadIO m => Schema.Resolver m -human = Schema.wrappedObjectA "human" $ \case - [Schema.Argument "id" (Schema.String i)] -> do - humanCharacter <- lift $ return $ getHuman i >>= Just - case humanCharacter of - Nothing -> return Type.Null - Just e -> Type.Named <$> character e - _ -> ActionT $ throwE "Invalid arguments." +human = Schema.wrappedObject "human" $ do + id' <- argument "id" + case id' of + Schema.String i -> do + humanCharacter <- lift $ return $ getHuman i >>= Just + case humanCharacter of + 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 - [Schema.Argument "id" (Schema.String i)] -> character =<< liftIO (getDroid i) - _ -> ActionT $ throwE "Invalid arguments." +droid = Schema.object "droid" $ do + id' <- argument "id" + 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