From 4ab4660d364cc62c9e23d2cdc85abc3f7dc6dc8d Mon Sep 17 00:00:00 2001 From: Danny Navarro Date: Fri, 3 Feb 2017 21:48:26 -0300 Subject: [PATCH] Initial implementation of AST.Full -> AST.Core This focused mainly on fragments. --- Data/GraphQL.hs | 4 +- Data/GraphQL/AST/Transform.hs | 70 ++++++++++++++++++++--------------- Data/GraphQL/Execute.hs | 6 +-- 3 files changed, 46 insertions(+), 34 deletions(-) diff --git a/Data/GraphQL.hs b/Data/GraphQL.hs index dd411e5..dfe9362 100644 --- a/Data/GraphQL.hs +++ b/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 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 + -- 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 diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs index 869753a..52537a4 100644 --- a/Data/GraphQL/Execute.hs +++ b/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