Overhaul Schema DSL

Aside of making the definition of Schemas easier, it takes care of
issues like nested aliases which previously wasn't possible. The naming
of the DSL functions is still provisional.

1 files changed, 39 insertions, 53 deletions

diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index 57c1b24..1cd8f42 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -1,17 +1,7 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Test.StarWars.Schema where
 
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative (pure)
-import Data.Traversable (traverse)
-#endif
-import Control.Applicative (Alternative, empty)
-import Data.Foldable (fold)
-
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text)
+import Control.Applicative ((<|>), Alternative, empty)
 
 import Data.GraphQL.Schema
 
@@ -23,47 +13,43 @@ import Test.StarWars.Data
 schema :: (Alternative m, Monad m) => Schema m
 schema = Schema query
 
-query :: (Alternative m, Monad m) => QueryRoot m
-query (InputField "hero"  args ins) = hero  args ins
-query (InputField "human" args ins) = human args ins
-query (InputField "droid" args ins) = droid args ins
-query _ = empty
+query :: (Alternative m, Monad m) => ResolverM m
+query fld =
+      withField "hero"  hero  fld
+  <|> withField "human" human fld
+  <|> withField "droid" droid fld
 
-hero :: Alternative f => [Argument] -> [Input] -> f Output
+hero :: Alternative f => [Argument] -> ResolverO f
 hero [] = characterFields artoo
-hero [("episode", ScalarInt n)] = characterFields $ getHero n
-hero _ = const empty
-
-human :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
-human [("id", ScalarString i)] ins = flip characterFields ins =<< getHuman i
-human _ _ = empty
-
-droid :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
-droid [("id", ScalarString i)] ins = flip characterFields ins =<< getDroid i
-droid _ _ = empty
-
-episode :: Alternative f => Int -> f Output
-episode 4 = pure $ OutputEnum "NEWHOPE"
-episode 5 = pure $ OutputEnum "EMPIRE"
-episode 6 = pure $ OutputEnum "JEDI"
-episode _ = empty
-
-characterField :: Alternative f => Character -> Input -> f (HashMap Text Output)
-characterField char (InputField "id" [] [])  =
-   pure . HashMap.singleton "id" . OutputScalar . ScalarString . id_ $ char
-characterField char (InputField "name" [] []) =
-   pure . HashMap.singleton "name" . OutputScalar . ScalarString . name $ char
-characterField char (InputField "friends" [] ins) =
-     fmap (HashMap.singleton "friends" . OutputList)
-   . traverse (`characterFields` ins)
-   . getFriends
-   $ char
-characterField char (InputField "appearsIn" [] []) =
-     fmap (HashMap.singleton "appearsIn" . OutputList)
-   . traverse episode
-   . appearsIn
-   $ char
-characterField _ _ = empty
-
-characterFields :: Alternative f => Character -> [Input] -> f Output
-characterFields char = fmap (OutputObject . fold) . traverse (characterField char)
+hero args =
+  case withArgument "episode" args of
+       Just (ScalarInt n) -> characterFields $ getHero n
+       _ -> const empty
+
+human :: (Alternative m, Monad m) => [Argument] -> ResolverO m
+human args flds =
+  case withArgument "id" args of
+       Just (ScalarString i) -> flip characterFields flds =<< getHuman i
+       _ -> empty
+
+droid :: (Alternative m, Monad m) => [Argument] -> ResolverO m
+droid args flds =
+   case withArgument "id" args of
+        Just (ScalarString i) -> flip characterFields flds =<< getDroid i
+        _ -> empty
+
+characterField :: Alternative f => Character -> ResolverM f
+characterField char fld =
+      withFieldFinal "id"        (OutputScalar . ScalarString . id_ $ char) fld
+  <|> withFieldFinal "name"      (OutputScalar . ScalarString . name $ char) fld
+  <|> withField      "friends"   friends' fld
+  <|> withField      "appearsIn" appears' fld
+  where
+    friends' [] flds = outputTraverse (`characterFields` flds) $ getFriends char
+    friends' _ _ = empty
+
+    appears' [] [] = outputTraverse (fmap OutputEnum . getEpisode) $ appearsIn char
+    appears' _ _ = empty
+
+characterFields :: Alternative f => Character -> ResolverO f
+characterFields = withFields . characterField