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.

2 files changed, 21 insertions, 24 deletions

diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 0af3e7f..b843f07 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -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"
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 795bb19..a4ba0ca 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -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