diff options
Diffstat (limited to 'Data/GraphQL/AST/Transform.hs')
| -rw-r--r-- | Data/GraphQL/AST/Transform.hs | 91 |
1 files changed, 56 insertions, 35 deletions
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 - -fragmentDefinition :: Full.FragmentDefinition -> Fragmenter -fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) name' = +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 :: 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 - -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) +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 :: Schema.Subs -> Full.Argument -> Maybe Core.Argument +argument subs (Full.Argument n v) = Core.Argument n <$> value subs v + +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 :: 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 |