diff options
Diffstat (limited to 'Data/GraphQL/Schema.hs')
| -rw-r--r-- | Data/GraphQL/Schema.hs | 74 |
1 files changed, 36 insertions, 38 deletions
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs index 2198362..aa25046 100644 --- a/Data/GraphQL/Schema.hs +++ b/Data/GraphQL/Schema.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating Schemas. @@ -14,15 +13,14 @@ module Data.GraphQL.Schema , arrayA , enum , enumA - , resolvers + , resolve -- * AST Reexports , Field , Argument(..) , Value(..) ) where -import Control.Applicative (Alternative((<|>), empty)) -import Data.Bifunctor (first) +import Control.Applicative (Alternative( empty)) import Data.Foldable (fold) import Data.List.NonEmpty (NonEmpty) import Data.Maybe (fromMaybe) @@ -32,10 +30,8 @@ import qualified Data.Aeson as Aeson import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) -import qualified Data.Text as T (unwords) import Data.GraphQL.AST.Core -import Data.GraphQL.Error -- | A GraphQL schema. -- @f@ is usually expected to be an instance of 'Alternative'. @@ -43,24 +39,31 @@ type Schema f = NonEmpty (Resolver f) -- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information -- (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'. -type Resolver f = Field -> CollectErrsT f Aeson.Object +type Resolver f = Field -> f Aeson.Object + +type Resolvers f = [Resolver f] + +type Fields = [Field] + +type Arguments = [Argument] -- | Variable substitution function. type Subs = Text -> Maybe Text -object :: Alternative f => Name -> [Resolver f] -> Resolver f -object name resolvs = objectA name $ \case - [] -> resolvs - _ -> empty +-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. +object :: Alternative f => Name -> Resolvers f -> Resolver f +object name resolvers = objectA name $ \case + [] -> resolvers + _ -> empty -- | Like 'object' but also taking 'Argument's. objectA :: Alternative f - => Name -> ([Argument] -> [Resolver f]) -> Resolver f -objectA name f fld@(Field _ _ args sels) = withField name (resolvers (f args) sels) fld + => Name -> (Arguments -> Resolvers f) -> Resolver f +objectA name f fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld -- | A scalar represents a primitive value, like a string or an integer. -scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f +scalar :: (Alternative f, Aeson.ToJSON a) => Name -> a -> Resolver f scalar name s = scalarA name $ \case [] -> pure s _ -> empty @@ -68,21 +71,21 @@ scalar name s = scalarA name $ \case -- | Like 'scalar' but also taking 'Argument's. scalarA :: (Alternative f, Aeson.ToJSON a) - => Name -> ([Argument] -> f a) -> Resolver f -scalarA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld + => Name -> (Arguments -> f a) -> Resolver f +scalarA name f fld@(Field _ _ args []) = withField name (f args) fld scalarA _ _ _ = empty -array :: Alternative f => Text -> [[Resolver f]] -> Resolver f -array name resolvs = arrayA name $ \case - [] -> resolvs +array :: Alternative f => Name -> [Resolvers f] -> Resolver f +array name resolvers = arrayA name $ \case + [] -> resolvers _ -> empty -- | Like 'array' but also taking 'Argument's. arrayA :: Alternative f - => Text -> ([Argument] -> [[Resolver f]]) -> Resolver f + => Text -> (Arguments -> [Resolvers f]) -> Resolver f arrayA name f fld@(Field _ _ args sels) = - withField name (joinErrs $ traverse (`resolvers` sels) $ f args) fld + withField name (traverse (`resolve` sels) $ f args) fld -- | Represents one of a finite set of possible values. -- Used in place of a 'scalar' when the possible responses are easily enumerable. @@ -93,30 +96,25 @@ enum name enums = enumA name $ \case -- | Like 'enum' but also taking 'Argument's. enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f -enumA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld +enumA name f fld@(Field _ _ args []) = withField name (f args) fld enumA _ _ _ = empty -- | Helper function to facilitate 'Argument' handling. withField :: (Alternative f, Aeson.ToJSON a) - => Name -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value) + => Name -> f a -> Field -> f (HashMap Text Aeson.Value) withField name f (Field alias name' _ _) = - if name == name' - then fmap (first $ HashMap.singleton aliasOrName . Aeson.toJSON) f - else empty - where - aliasOrName = fromMaybe name' alias + if name == name' + then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) f + else empty + where + aliasOrName = fromMaybe name alias + -- | Takes a list of 'Resolver's and a list of 'Field's and applies each -- 'Resolver' to each 'Field'. Resolves into a value containing the -- resolved 'Field', or a null value and error information. -resolvers :: Alternative f => [Resolver f] -> [Field] -> CollectErrsT f Aeson.Value -resolvers resolvs = - fmap (first Aeson.toJSON . fold) - . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvs) <|> errmsg fld) - where - errmsg (Field alias name _ _) = addErrMsg msg $ (errWrap . pure) val - where - val = HashMap.singleton aliasOrName Aeson.Null - msg = T.unwords ["field", name, "not resolved."] - aliasOrName = fromMaybe name alias +resolve :: Alternative f => Resolvers f -> Fields -> f Aeson.Value +resolve resolvers = + fmap (Aeson.toJSON . fold) + . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers)) |