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:
@ -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"
|
||||
|
@ -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
|
||||
|
Reference in New Issue
Block a user