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.

1 files changed, 12 insertions, 10 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"