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.

3 files changed, 67 insertions, 60 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
diff --git a/tests/Test/StarWars.hs b/tests/Test/StarWars.hs
index ec8fadd..bdd1991 100644
--- a/tests/Test/StarWars.hs
+++ b/tests/Test/StarWars.hs
@@ -4,14 +4,15 @@
 module Test.StarWars where
 
 #if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
+import Control.Applicative (Applicative, (<$>), pure)
+import Data.Traversable (traverse)
 #endif
-import Control.Applicative ((<|>), liftA2)
+import Control.Applicative (Alternative, (<|>), empty, liftA2)
 import Data.Maybe (catMaybes)
-import Data.Text (Text)
 
 import qualified Data.Aeson as Aeson
 import Data.Attoparsec.Text (parseOnly)
+import Data.Text (Text)
 
 import Test.Tasty (TestTree)
 import Test.Tasty.HUnit
@@ -40,38 +41,45 @@ test = testCase "R2-D2" $ execute schema heroQuery @?= expected
 
 type ID = Text
 
-schema :: Schema
+schema :: Alternative f => Schema f
 schema = Schema query
 
-query ::  QueryRoot
-query (InputField "hero")  = OutputResolver hero
-query (InputField "human") = OutputResolver human
-query (InputField "droid") = OutputResolver droid
-query _ = OutputError
-
--- TODO: Extract helper function from next 3 functions.
+query :: Alternative f => QueryRoot f
+query (InputField "hero")  = pure $ OutputResolver hero
+query (InputField "human") = pure $ OutputResolver human
+query (InputField "droid") = pure $ OutputResolver droid
+query _ = empty
 
-hero :: Resolver
+hero :: Alternative f => Resolver f
 hero (InputList (InputScalar (ScalarInt ep) : inputFields)) =
-    maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getHero ep
+    withFields inputFields  <$> getHero ep
 hero (InputField fld) = characterOutput fld artoo
-hero _ = OutputError
+hero _ = empty
 
-human :: Resolver
+human :: Alternative f => Resolver f
 human (InputList (InputScalar (ScalarID i) : inputFields)) =
-    maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getHuman i
-human _ = OutputError
+    withFields inputFields <$> getHuman i
+human _ = empty
 
-droid :: Resolver
+droid :: Alternative f => Resolver f
 droid (InputList (InputScalar (ScalarID i) : inputFields)) =
-    maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getDroid i
-droid _ = OutputError
-
-characterOutput :: Text -> Character -> Output
-characterOutput "id"      char = OutputScalar . ScalarString $ id_  char
-characterOutput "name"    char = OutputScalar . ScalarString $ name char
-characterOutput "friends" char = OutputList $ OutputResolver . (\c (InputField f) -> characterOutput f c) <$> getFriends char
-characterOutput _ _ = OutputError
+    withFields inputFields <$> getDroid i
+droid _ = empty
+
+characterOutput :: Alternative f => Text -> Character -> f (Output f)
+characterOutput "id" char =
+    pure $ OutputScalar . pure . ScalarString $ id_  char
+characterOutput "name" char =
+    pure $ OutputScalar . pure . ScalarString $ name char
+characterOutput "friends" char =
+    -- TODO: Cleanup
+    pure . OutputList . pure $ OutputResolver . (\c (InputField f) ->
+      characterOutput f c) <$> getFriends char
+characterOutput _ _ = empty
+
+withFields :: Alternative f => [Input] -> Character -> Output f
+withFields inputFields char =
+    OutputList . traverse (`characterOutput` char) $ fields inputFields
 
 -- * Data
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@@ -106,23 +114,25 @@ artoo = Character
 
 -- ** Helper functions
 
-getHero :: Int -> Maybe Character
-getHero 5 = Just luke
-getHero _ = Just artoo
+getHero :: Applicative f => Int -> f Character
+getHero 5 = pure luke
+getHero _ = pure artoo
+
+getHeroIO :: Int -> IO Character
+getHeroIO = getHero
 
-getHuman :: ID -> Maybe Character
-getHuman "1000" = Just luke
+getHuman :: Alternative f => ID -> f Character
+getHuman "1000" = pure luke
 -- getHuman "1001" = "vader"
 -- getHuman "1002" = "han"
 -- getHuman "1003" = "leia"
 -- getHuman "1004" = "tarkin"
-getHuman _      = Nothing
+getHuman _      = empty
 
-getDroid :: ID -> Maybe Character
+getDroid :: Alternative f => ID -> f Character
 -- getDroid "2000" = "threepio"
-getDroid "2001" = Just artoo
-getDroid _ = Nothing
-
+getDroid "2001" = pure artoo
+getDroid _ = empty
 
 getFriends :: Character -> [Character]
 getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char