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.

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
+hero args =
+  case withArgument "episode" args of
+       Just (ScalarInt n) -> characterFields $ getHero n
+       _ -> const empty
 
-human :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
-human [("id", ScalarString i)] ins = flip characterFields ins =<< getHuman i
-human _ _ = 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] -> [Input] -> m Output
-droid [("id", ScalarString i)] ins = flip characterFields ins =<< getDroid i
-droid _ _ = 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
 
-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 -> 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
 
-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
+    appears' [] [] = outputTraverse (fmap OutputEnum . getEpisode) $ appearsIn char
+    appears' _ _ = empty
 
-characterFields :: Alternative f => Character -> [Input] -> f Output
-characterFields char = fmap (OutputObject . fold) . traverse (characterField char)
+characterFields :: Alternative f => Character -> ResolverO f
+characterFields = withFields . characterField