Merge branch 'core'

This introduces a distinction between a Full and a Core AST. Fragments and
variables are replaced when transforming from Full to Core.

2 files changed, 135 insertions, 5 deletions

diff --git a/Data/GraphQL/AST/Core.hs b/Data/GraphQL/AST/Core.hs
index 2ca3928..f0c617c 100644
--- a/Data/GraphQL/AST/Core.hs
+++ b/Data/GraphQL/AST/Core.hs
@@ -3,29 +3,36 @@ module Data.GraphQL.AST.Core where
 
 import Data.Int (Int32)
 import Data.List.NonEmpty (NonEmpty)
+import Data.String
 
 import Data.Text (Text)
 
-newtype Name = Name Text deriving (Eq,Show)
+type Name = Text
 
-newtype Document = Document (NonEmpty Operation) deriving (Eq,Show)
+type Document = NonEmpty Operation
 
-data Operation = Query (NonEmpty Field)
+data Operation = Query    (NonEmpty Field)
                | Mutation (NonEmpty Field)
                  deriving (Eq,Show)
 
-data Field = Field Name [Argument] [Field] deriving (Eq,Show)
+data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show)
+
+type Alias = Name
 
 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]
              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
new file mode 100644
index 0000000..af55772
--- /dev/null
+++ b/Data/GraphQL/AST/Transform.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Data.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 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]
+
+-- 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