Generalize Maybe type constructor to any Monad

This allows schema definitions with side-effects for any type with a
Monadic/Alternative implementation like IO for example.
This commit is contained in:
Danny Navarro
2016-01-30 12:29:49 +01:00
parent a832991ac0
commit eca3c2d8d4
3 changed files with 66 additions and 59 deletions

View File

@ -1,10 +1,12 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE LambdaCase #-}
module Data.GraphQL.Execute where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Control.Applicative (Applicative, (<$>), pure)
#endif
import Control.Applicative (Alternative, empty)
import qualified Data.Aeson as Aeson
@ -13,20 +15,20 @@ import Data.GraphQL.Schema
type Response = Aeson.Value
execute :: Schema -> Document -> Maybe Response
execute :: (Alternative f, Monad f) => Schema f -> Document -> f Response
execute (Schema resolv0) doc = go resolv0 =<< root doc
where
root :: Document -> Maybe Selection
root (Document [DefinitionOperation (Query (Node _ _ _ [sel]))]) = Just sel
root :: Applicative f => Document -> f Selection
root (Document [DefinitionOperation (Query (Node _ _ _ [sel]))]) = pure sel
root _ = error "root: Not implemented yet"
go :: Resolver -> Selection -> Maybe Response
go :: (Alternative f, Monad f) => Resolver f -> Selection -> f Response
go resolv (SelectionField (Field _ n _ _ sfs)) =
case resolv (InputField n) of
(OutputScalar s) -> if null sfs
then Just $ Aeson.Object [(n, Aeson.toJSON s)]
else Nothing
resolv (InputField n) >>= \case
(OutputScalar s) ->
if null sfs
then (\s' -> Aeson.Object [(n, Aeson.toJSON s')]) <$> s
else empty
(OutputResolver resolv') -> (\r-> Aeson.Object [(n, r)]) <$> go resolv' (head sfs)
_ -> error "go case resolv: Not implemented yet"
go _ _ = error "go: Not implemented yet"

View File

@ -1,27 +1,22 @@
module Data.GraphQL.Schema where
import Data.Maybe (catMaybes)
import Text.Show.Functions ()
import Data.Text (Text)
import Data.Aeson (ToJSON(toJSON))
-- TODO: Support side-effects
data Schema f = Schema (QueryRoot f) -- (Maybe MutationRoot)
data Schema = Schema QueryRoot -- (Maybe MutationRoot)
type QueryRoot f = Resolver f
type QueryRoot = Resolver
type Resolver f = Input -> f (Output f)
type Resolver = Input -> Output
data Output = OutputResolver Resolver
| OutputList [Output]
| OutputScalar Scalar
-- | OutputUnion [Output]
-- | OutputEnum [Scalar]
-- | OutputNonNull (Output)
| OutputError
deriving (Show)
data Output f = OutputResolver (Resolver f)
| OutputList (f [Output f])
| OutputScalar (f Scalar)
-- | OutputUnion [Output]
-- | OutputEnum [Scalar]
-- | OutputNonNull (Output)
data Input = InputScalar Scalar
| InputField Text