From 8ee50727bde4779ba5c3aa98f74e669ada66bb26 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Wed, 17 Feb 2016 18:13:10 +0100
Subject: 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 | 92 ++++++++++++++++++-------------------------
 1 file changed, 39 insertions(+), 53 deletions(-)

(limited to 'tests/Test/StarWars/Schema.hs')

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
-- 
cgit v1.2.3