Initial implementation of AST.Full -> AST.Core

This focused mainly on fragments.

Data/GraphQL.hs

@@ -19,7 +19,7 @@ import Data.GraphQL.Error
 --   executed according to the given 'Schema'.
 --
 --   Returns the response as an @Aeson.@'Aeson.Value'.
-graphql :: Alternative m => Schema m -> Text -> m Aeson.Value
+graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value
 graphql = flip graphqlSubs $ const Nothing
 
 -- | Takes a 'Schema', a variable substitution function and text
@@ -28,7 +28,7 @@ graphql = flip graphqlSubs $ const Nothing
 --   query and the query is then executed according to the given 'Schema'.
 --
 --   Returns the response as an @Aeson.@'Aeson.Value'.
-graphqlSubs :: Alternative m => Schema m -> Subs -> Text -> m Aeson.Value
+graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value
 graphqlSubs schema f =
     either parseError (execute schema f)
   . Attoparsec.parseOnly document

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
+  -- TODO: Support fragments within fragments. Fold instead of map.
+  if name == name'
+  then either id pure =<< maybeToList =<< NonEmpty.toList (selection mempty <$> 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)
+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

Data/GraphQL/Execute.hs

@@ -2,7 +2,7 @@
 --   according to a 'Schema'.
 module Data.GraphQL.Execute (execute) where
 
-import Control.Applicative (Alternative)
+import Control.Applicative (Alternative, empty)
 import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty (NonEmpty((:|)))
 
@@ -21,9 +21,9 @@ import qualified Data.GraphQL.Schema as Schema
 --   Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
 --   errors wrapped in an /errors/ field.
 execute
-  :: Alternative f
+  :: (Alternative f, Monad f)
   => Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value
-execute schema subs doc = document schema $ Transform.document subs doc
+execute schema subs doc = document schema =<< maybe empty pure (Transform.document subs doc)
 
 document :: Alternative f => Schema f -> AST.Core.Document -> f Aeson.Value
 document schema (op :| [])= operation schema op