From eca3c2d8d4d427b58c2109c277975219bad58e43 Mon Sep 17 00:00:00 2001 From: Danny Navarro Date: Sat, 30 Jan 2016 12:29:49 +0100 Subject: [PATCH] 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. --- Data/GraphQL/Execute.hs | 22 ++++++------ Data/GraphQL/Schema.hs | 23 +++++------- tests/Test/StarWars.hs | 80 +++++++++++++++++++++++------------------ 3 files changed, 66 insertions(+), 59 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 +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 --- TODO: Extract helper function from next 3 functions. - -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 + withFields inputFields <$> getDroid i +droid _ = empty -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 +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 -getHuman :: ID -> Maybe Character -getHuman "1000" = Just luke +getHeroIO :: Int -> IO Character +getHeroIO = getHero + +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