1 files changed, 41 insertions, 29 deletions

diff --git a/Data/GraphQL/AST/Transform.hs b/Data/GraphQL/AST/Transform.hs
index 89a79e6..3dac757 100644
--- a/Data/GraphQL/AST/Transform.hs
+++ b/Data/GraphQL/AST/Transform.hs
@@ -1,10 +1,11 @@
 module Data.GraphQL.AST.Transform where
 
 import Control.Applicative (empty)
+import Control.Monad ((<=<))
 import Data.Bifunctor (first)
 import Data.Either (partitionEithers)
 import qualified Data.List.NonEmpty as NonEmpty
--- import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Maybe (maybeToList)
 import Data.Monoid (Alt(Alt,getAlt))
 import Data.Foldable (foldMap)
 
@@ -20,7 +21,8 @@ type Name = Text
 --   empty list is returned.
 type Fragmenter = Name -> [Core.Field]
 
-document :: Schema.Subs -> Full.Document -> Core.Document
+-- TODO: Replace Maybe by Either CustomError
+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
@@ -28,6 +30,34 @@ document subs defs = operations subs fr ops
     foldFrags :: [Fragmenter] -> Fragmenter
     foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
 
+-- * Operation
+
+operations
+  :: Schema.Subs
+  -> Fragmenter
+  -> [Full.OperationDefinition]
+  -> Maybe Core.Document
+operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
+
+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
+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
+
+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"
+
 -- * Fragment replacement
 
 -- | Extract Fragments into a single Fragmenter function and a Operation
@@ -38,17 +68,14 @@ 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"
+  -- TODO: Support fragments within fragments. Fold instead of map.
+  if name == name'
+  then either id pure =<< maybeToList =<< NonEmpty.toList (selection mempty <$> sels)
+  else empty
 
-field :: Full.Field -> Core.Field
-field (Full.Field a n args _ sels) =
-  Core.Field a n (argument <$> args) (selection <$> sels)
+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)
@@ -67,20 +94,5 @@ 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
+hush :: Either a b -> Maybe b
+hush = either (const Nothing) Just