Change the main namespace to Language.GraphQL

2019-07-07 06:31:53 +02:00
parent 1431db7e63
commit 22d4a4e583
14 changed files with 58 additions and 68 deletions
--- a/src/Language/GraphQL/AST/Transform.hs
+++ b/src/Language/GraphQL/AST/Transform.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.AST.Transform where
+
+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.Monoid (Alt(Alt,getAlt), (<>))
+import Data.Text (Text)
+import qualified Language.GraphQL.AST as Full
+import qualified Language.GraphQL.AST.Core as Core
+import qualified Language.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]
+
+-- TODO: Replace Maybe by MonadThrow with CustomError
+document :: Schema.Subs -> Full.Document -> Maybe Core.Document
+document subs doc = operations subs fr ops
+  where
+    (fr, ops) = first foldFrags
+              . partitionEithers
+              . NonEmpty.toList
+              $ defrag subs
+            <$> doc
+
+    foldFrags :: [Fragmenter] -> Fragmenter
+    foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
+
+-- * Operation
+
+-- TODO: Replace Maybe by MonadThrow CustomError
+operations
+  :: Schema.Subs
+  -> Fragmenter
+  -> [Full.OperationDefinition]
+  -> Maybe Core.Document
+operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
+
+-- TODO: Replace Maybe by MonadThrow CustomError
+operation
+  :: Schema.Subs
+  -> Fragmenter
+  -> Full.OperationDefinition
+  -> Maybe Core.Operation
+operation subs fr (Full.OperationSelectionSet sels) =
+  operation subs fr $ Full.OperationDefinition Full.Query empty empty empty 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 subs fr) sels
+
+selection
+  :: Schema.Subs
+  -> Fragmenter
+  -> Full.Selection
+  -> Either [Core.Field] Core.Field
+selection subs fr (Full.SelectionField fld) =
+  Right $ field subs fr fld
+selection _    fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
+  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
+  :: 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 =<< NonEmpty.toList (selection subs mempty <$> sels)
+  else empty
+
+field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field
+field subs fr (Full.Field a n args _dirs sels) =
+    Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)
+  where
+    go :: Full.Selection -> [Core.Field] -> [Core.Field]
+    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>)
+    go sel =  (either id pure (selection subs fr sel) <>)
+
+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