Introduce Tranform module

In the Transform module the Full AST will converted to Core AST.

This commit also includes a partial implementation of Fragment replacement.
This commit is contained in:
Danny Navarro 2017-01-29 18:44:03 -03:00
parent f35e1f949a
commit 693b7d18dc
No known key found for this signature in database
GPG Key ID: 81E5F99780FA6A32
5 changed files with 92 additions and 11 deletions

View File

@ -23,8 +23,9 @@ data Argument = Argument Name Value deriving (Eq,Show)
data Value = ValueInt Int32
-- GraphQL Float is double precision
| ValueFloat Double
| ValueBoolean Bool
| ValueString Text
| ValueBoolean Bool
| ValueNull
| ValueEnum Name
| ValueList [Value]
| ValueObject [ObjectField]

View File

@ -0,0 +1,86 @@
module Data.GraphQL.AST.Transform where
import Control.Applicative (empty)
import Data.Bifunctor (first)
import Data.Either (partitionEithers)
import qualified Data.List.NonEmpty as NonEmpty
-- import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Monoid (Alt(Alt,getAlt))
import Data.Foldable (foldMap)
import Data.Text (Text)
import qualified Data.GraphQL.AST as Full
import qualified Data.GraphQL.AST.Core as Core
import qualified Data.GraphQL.Schema as Schema
type Name = Text
-- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an
-- empty list is returned.
type Fragmenter = Name -> [Core.Field]
document :: Schema.Subs -> Full.Document -> Core.Document
document subs defs = operations subs fr ops
where
(fr, ops) = first foldFrags . partitionEithers . NonEmpty.toList $ defrag <$> defs
foldFrags :: [Fragmenter] -> Fragmenter
foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
-- * 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
fragmentDefinition :: Full.FragmentDefinition -> Fragmenter
fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) name' =
if name == name' then NonEmpty.toList (selection <$> sels) else empty
selection :: Full.Selection -> Core.Field
selection (Full.SelectionField _fld) = field _fld
selection (Full.SelectionFragmentSpread _) = error "Nested fragments not supported yet"
selection (Full.SelectionInlineFragment _) =
error "Inline fragments within fragments not supported yet"
field :: Full.Field -> Core.Field
field (Full.Field a n args _ sels) =
Core.Field a n (argument <$> args) (selection <$> sels)
argument :: Full.Argument -> Core.Argument
argument (Full.Argument n v) = Core.Argument n (value 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)
objectField :: Full.ObjectField -> Core.ObjectField
objectField (Full.ObjectField n v) = Core.ObjectField n (value v)
-- * Operation
operations
:: Schema.Subs
-> Fragmenter
-> [Full.OperationDefinition]
-> Core.Document
-- XXX: Replace `fromList` by proper error: at least a Query or Mutation
-- operation must be present
operations subs fr = NonEmpty.fromList . fmap (operation subs fr)
operation
:: Schema.Subs
-> Fragmenter
-> Full.OperationDefinition
-> Core.Operation
operation _subs _fr _op = undefined

View File

@ -10,17 +10,10 @@ import qualified Data.Aeson as Aeson
import qualified Data.GraphQL.AST as AST
import qualified Data.GraphQL.AST.Core as AST.Core
import qualified Data.GraphQL.AST.Transform as Transform
import Data.GraphQL.Schema (Schema)
import qualified Data.GraphQL.Schema as Schema
core :: Schema.Subs -> AST.Document -> AST.Core.Document
core subs ((AST.DefinitionOperation opDef) :| []) = error "Not implemented yet"
core _ ((AST.DefinitionFragment fragDef) :| []) =
error "Fragment definitions not supported yet"
core _ _ = error "Multiple definitions not supported yet"
-- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a
-- @GraphQL@ 'document'. The substitution is applied to the document using
-- 'rootFields', and the 'Schema''s resolvers are applied to the resulting fields.
@ -30,7 +23,7 @@ core _ _ = error "Multiple definitions not supported yet"
execute
:: Alternative f
=> Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value
execute schema subs doc = document schema $ core subs doc
execute schema subs doc = document schema $ Transform.document subs doc
document :: Alternative f => Schema f -> AST.Core.Document -> f Aeson.Value
document schema (op :| [])= operation schema op

View File

@ -26,6 +26,7 @@ library
exposed-modules: Data.GraphQL
Data.GraphQL.AST
Data.GraphQL.AST.Core
Data.GraphQL.AST.Transform
Data.GraphQL.Execute
Data.GraphQL.Encoder
Data.GraphQL.Error