From b7a72591fd08df9df678e5e7db3304b5a2e75ae9 Mon Sep 17 00:00:00 2001 From: Danny Navarro Date: Sun, 12 Feb 2017 15:19:13 -0300 Subject: [PATCH] Support variables in AST transformation --- Data/GraphQL/AST/Core.hs | 4 ++ Data/GraphQL/AST/Transform.hs | 83 ++++++++++++++++++++++------------- Data/GraphQL/Schema.hs | 3 +- 3 files changed, 57 insertions(+), 33 deletions(-) diff --git a/Data/GraphQL/AST/Core.hs b/Data/GraphQL/AST/Core.hs index 3424d20..f0c617c 100644 --- a/Data/GraphQL/AST/Core.hs +++ b/Data/GraphQL/AST/Core.hs @@ -3,6 +3,7 @@ module Data.GraphQL.AST.Core where import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty) +import Data.String import Data.Text (Text) @@ -31,4 +32,7 @@ data Value = ValueInt Int32 | ValueObject [ObjectField] deriving (Eq,Show) +instance IsString Value where + fromString = ValueString . fromString + data ObjectField = ObjectField Name Value deriving (Eq,Show) diff --git a/Data/GraphQL/AST/Transform.hs b/Data/GraphQL/AST/Transform.hs index 3dac757..d4b1150 100644 --- a/Data/GraphQL/AST/Transform.hs +++ b/Data/GraphQL/AST/Transform.hs @@ -4,10 +4,10 @@ import Control.Applicative (empty) import Control.Monad ((<=<)) import Data.Bifunctor (first) import Data.Either (partitionEithers) +import Data.Foldable (fold, foldMap) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (maybeToList) import Data.Monoid (Alt(Alt,getAlt)) -import Data.Foldable (foldMap) import Data.Text (Text) @@ -25,7 +25,11 @@ type Fragmenter = Name -> [Core.Field] document :: Schema.Subs -> Full.Document -> Maybe Core.Document document subs defs = operations subs fr ops where - (fr, ops) = first foldFrags . partitionEithers . NonEmpty.toList $ defrag <$> defs + (fr, ops) = first foldFrags + . partitionEithers + . NonEmpty.toList + $ defrag subs + <$> defs foldFrags :: [Fragmenter] -> Fragmenter foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs @@ -46,53 +50,70 @@ operation -> Maybe Core.Operation operation subs fr (Full.OperationSelectionSet sels) = operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels -operation _subs fr (Full.OperationDefinition ot _n _vars _dirs sels) = +-- TODO: Validate Variable definitions with substituter +operation subs fr (Full.OperationDefinition ot _n _vars _dirs sels) = case ot of Full.Query -> Core.Query <$> node Full.Mutation -> Core.Mutation <$> node where - node = traverse (hush <=< selection fr) sels + node = traverse (hush <=< selection subs fr) sels -selection :: Fragmenter -> Full.Selection -> Maybe (Either [Core.Field] Core.Field) -selection fr (Full.SelectionField _fld) = Right <$> field fr _fld -selection fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) = Just . Left $ fr n -selection _ (Full.SelectionInlineFragment _) = error "Inline fragments not supported yet" +selection + :: Schema.Subs + -> Fragmenter + -> Full.Selection + -> Maybe (Either [Core.Field] Core.Field) +selection subs fr (Full.SelectionField fld) = + Right <$> field subs fr fld +selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) = + Just . Left $ fr n +selection _ _ (Full.SelectionInlineFragment _) = + error "Inline fragments not supported yet" -- * Fragment replacement -- | Extract Fragments into a single Fragmenter function and a Operation -- Definition. -defrag :: Full.Definition -> Either Fragmenter Full.OperationDefinition -defrag (Full.DefinitionOperation op) = Right op -defrag (Full.DefinitionFragment fragDef) = Left $ fragmentDefinition fragDef +defrag + :: Schema.Subs + -> Full.Definition + -> Either Fragmenter Full.OperationDefinition +defrag _ (Full.DefinitionOperation op) = + Right op +defrag subs (Full.DefinitionFragment fragDef) = + Left $ fragmentDefinition subs fragDef -fragmentDefinition :: Full.FragmentDefinition -> Fragmenter -fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) name' = +fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter +fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' = -- TODO: Support fragments within fragments. Fold instead of map. if name == name' - then either id pure =<< maybeToList =<< NonEmpty.toList (selection mempty <$> sels) + then either id pure =<< maybeToList + =<< NonEmpty.toList (selection subs mempty <$> sels) else empty -field :: Fragmenter -> Full.Field -> Maybe Core.Field -field fr (Full.Field a n args _ sels) = - Core.Field a n (argument <$> args) <$> traverse (hush <=< selection fr) sels +field :: Schema.Subs -> Fragmenter -> Full.Field -> Maybe Core.Field +field subs fr (Full.Field a n args _dirs sels) = + Core.Field a n (fold $ argument subs `traverse` args) + <$> traverse (hush <=< selection subs fr) sels -argument :: Full.Argument -> Core.Argument -argument (Full.Argument n v) = Core.Argument n (value v) +argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument +argument subs (Full.Argument n v) = Core.Argument n <$> value subs v -value :: Full.Value -> Core.Value -value (Full.ValueVariable _) = error "Variables within fragments not supported yet" -value (Full.ValueInt i) = Core.ValueInt i -value (Full.ValueFloat f) = Core.ValueFloat f -value (Full.ValueString x) = Core.ValueString x -value (Full.ValueBoolean b) = Core.ValueBoolean b -value Full.ValueNull = Core.ValueNull -value (Full.ValueEnum e) = Core.ValueEnum e -value (Full.ValueList l) = Core.ValueList (value <$> l) -value (Full.ValueObject o) = Core.ValueObject (objectField <$> o) +value :: Schema.Subs -> Full.Value -> Maybe Core.Value +value subs (Full.ValueVariable n) = subs n +value _ (Full.ValueInt i) = pure $ Core.ValueInt i +value _ (Full.ValueFloat f) = pure $ Core.ValueFloat f +value _ (Full.ValueString x) = pure $ Core.ValueString x +value _ (Full.ValueBoolean b) = pure $ Core.ValueBoolean b +value _ Full.ValueNull = pure Core.ValueNull +value _ (Full.ValueEnum e) = pure $ Core.ValueEnum e +value subs (Full.ValueList l) = + Core.ValueList <$> traverse (value subs) l +value subs (Full.ValueObject o) = + Core.ValueObject <$> traverse (objectField subs) o -objectField :: Full.ObjectField -> Core.ObjectField -objectField (Full.ObjectField n v) = Core.ObjectField n (value v) +objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField +objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v hush :: Either a b -> Maybe b hush = either (const Nothing) Just diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs index 548c4eb..4acc4ac 100644 --- a/Data/GraphQL/Schema.hs +++ b/Data/GraphQL/Schema.hs @@ -48,7 +48,7 @@ type Fields = [Field] type Arguments = [Argument] -- | Variable substitution function. -type Subs = Text -> Maybe Text +type Subs = Name -> Maybe Value -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. object :: Alternative f => Name -> Resolvers f -> Resolver f @@ -110,7 +110,6 @@ withField name f (Field alias name' _ _) = where aliasOrName = fromMaybe name alias - -- | Takes a list of 'Resolver's and a list of 'Field's and applies each -- 'Resolver' to each 'Field'. Resolves into a value containing the -- resolved 'Field', or a null value and error information.