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.
This commit is contained in:
Danny Navarro 2016-01-30 12:29:49 +01:00
parent a832991ac0
commit eca3c2d8d4
3 changed files with 66 additions and 59 deletions

View File

@ -1,10 +1,12 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE LambdaCase #-}
module Data.GraphQL.Execute where module Data.GraphQL.Execute where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>)) import Control.Applicative (Applicative, (<$>), pure)
#endif #endif
import Control.Applicative (Alternative, empty)
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
@ -13,20 +15,20 @@ import Data.GraphQL.Schema
type Response = Aeson.Value 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 execute (Schema resolv0) doc = go resolv0 =<< root doc
where where
root :: Applicative f => Document -> f Selection
root :: Document -> Maybe Selection root (Document [DefinitionOperation (Query (Node _ _ _ [sel]))]) = pure sel
root (Document [DefinitionOperation (Query (Node _ _ _ [sel]))]) = Just sel
root _ = error "root: Not implemented yet" 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)) = go resolv (SelectionField (Field _ n _ _ sfs)) =
case resolv (InputField n) of resolv (InputField n) >>= \case
(OutputScalar s) -> if null sfs (OutputScalar s) ->
then Just $ Aeson.Object [(n, Aeson.toJSON s)] if null sfs
else Nothing then (\s' -> Aeson.Object [(n, Aeson.toJSON s')]) <$> s
else empty
(OutputResolver resolv') -> (\r-> Aeson.Object [(n, r)]) <$> go resolv' (head sfs) (OutputResolver resolv') -> (\r-> Aeson.Object [(n, r)]) <$> go resolv' (head sfs)
_ -> error "go case resolv: Not implemented yet" _ -> error "go case resolv: Not implemented yet"
go _ _ = error "go: Not implemented yet" go _ _ = error "go: Not implemented yet"

View File

@ -1,27 +1,22 @@
module Data.GraphQL.Schema where module Data.GraphQL.Schema where
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Text.Show.Functions ()
import Data.Text (Text) import Data.Text (Text)
import Data.Aeson (ToJSON(toJSON)) 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 f = OutputResolver (Resolver f)
| OutputList (f [Output f])
data Output = OutputResolver Resolver | OutputScalar (f Scalar)
| OutputList [Output]
| OutputScalar Scalar
-- | OutputUnion [Output] -- | OutputUnion [Output]
-- | OutputEnum [Scalar] -- | OutputEnum [Scalar]
-- | OutputNonNull (Output) -- | OutputNonNull (Output)
| OutputError
deriving (Show)
data Input = InputScalar Scalar data Input = InputScalar Scalar
| InputField Text | InputField Text

View File

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