Move the source code into src/

src/Data/GraphQL.hs

@@ -0,0 +1,36 @@
+-- | This module provides the functions to parse and execute @GraphQL@ queries.
+module Data.GraphQL where
+
+import Control.Monad (MonadPlus)
+
+import qualified Data.Text as T
+
+import qualified Data.Aeson as Aeson
+import Text.Megaparsec ( errorBundlePretty
+                       , parse
+                       )
+
+import Data.GraphQL.Execute
+import Data.GraphQL.Parser
+import Data.GraphQL.Schema
+
+import Data.GraphQL.Error
+
+-- | Takes a 'Schema' and text representing a @GraphQL@ request document.
+--   If the text parses correctly as a @GraphQL@ query the query is
+--   executed according to the given 'Schema'.
+--
+--   Returns the response as an @Aeson.@'Aeson.Value'.
+graphql :: MonadPlus m => Schema m -> T.Text -> m Aeson.Value
+graphql = flip graphqlSubs $ const Nothing
+
+-- | Takes a 'Schema', a variable substitution function and text
+--   representing a @GraphQL@ request document.  If the text parses
+--   correctly as a @GraphQL@ query the substitution is applied to the
+--   query and the query is then executed according to the given 'Schema'.
+--
+--   Returns the response as an @Aeson.@'Aeson.Value'.
+graphqlSubs :: MonadPlus m => Schema m -> Subs -> T.Text -> m Aeson.Value
+graphqlSubs schema f =
+    either (parseError . errorBundlePretty) (execute schema f)
+    . parse document ""

src/Data/GraphQL/AST.hs

@@ -0,0 +1,131 @@
+-- | This module defines an abstract syntax tree for the @GraphQL@ language based on
+--   <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
+--
+-- Target AST for Parser.
+
+module Data.GraphQL.AST where
+
+import Data.Int (Int32)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
+
+-- * Name
+
+type Name = Text
+
+-- * Document
+
+type Document = NonEmpty Definition
+
+-- * Operations
+
+data Definition = DefinitionOperation OperationDefinition
+                | DefinitionFragment  FragmentDefinition
+                  deriving (Eq,Show)
+
+data OperationDefinition = OperationSelectionSet SelectionSet
+                         | OperationDefinition   OperationType
+                                                 (Maybe Name)
+                                                 VariableDefinitions
+                                                 Directives
+                                                 SelectionSet
+                           deriving (Eq,Show)
+
+data OperationType = Query | Mutation deriving (Eq,Show)
+
+-- * SelectionSet
+
+type SelectionSet = NonEmpty Selection
+
+type SelectionSetOpt = [Selection]
+
+data Selection = SelectionField          Field
+               | SelectionFragmentSpread FragmentSpread
+               | SelectionInlineFragment InlineFragment
+                 deriving (Eq,Show)
+
+-- * Field
+
+data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
+             deriving (Eq,Show)
+
+type Alias = Name
+
+-- * Arguments
+
+type Arguments = [Argument]
+
+data Argument = Argument Name Value deriving (Eq,Show)
+
+-- * Fragments
+
+data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show)
+
+data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
+                      deriving (Eq,Show)
+
+data FragmentDefinition =
+  FragmentDefinition FragmentName TypeCondition Directives SelectionSet
+  deriving (Eq,Show)
+
+type FragmentName = Name
+
+type TypeCondition = Name
+
+-- Input Values
+
+data Value = ValueVariable Variable
+           | ValueInt IntValue
+           | ValueFloat FloatValue
+           | ValueString StringValue
+           | ValueBoolean BooleanValue
+           | ValueNull
+           | ValueEnum EnumValue
+           | ValueList ListValue
+           | ValueObject ObjectValue
+             deriving (Eq,Show)
+
+type IntValue = Int32
+
+-- GraphQL Float is double precison
+type FloatValue = Double
+
+type StringValue = Text
+
+type BooleanValue = Bool
+
+type EnumValue = Name
+
+type ListValue = [Value]
+
+type ObjectValue = [ObjectField]
+
+data ObjectField = ObjectField Name Value deriving (Eq,Show)
+
+-- * Variables
+
+type VariableDefinitions = [VariableDefinition]
+
+data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
+                          deriving (Eq,Show)
+
+type Variable = Name
+
+type DefaultValue = Value
+
+-- * Input Types
+
+data Type = TypeNamed   Name
+          | TypeList    Type
+          | TypeNonNull NonNullType
+            deriving (Eq,Show)
+
+data NonNullType = NonNullTypeNamed Name
+                 | NonNullTypeList  Type
+                   deriving (Eq,Show)
+
+-- * Directives
+
+type Directives = [Directive]
+
+data Directive = Directive Name [Argument] deriving (Eq,Show)

src/Data/GraphQL/AST/Core.hs

@@ -0,0 +1,38 @@
+-- | This is the AST meant to be executed.
+module Data.GraphQL.AST.Core where
+
+import Data.Int (Int32)
+import Data.List.NonEmpty (NonEmpty)
+import Data.String
+
+import Data.Text (Text)
+
+type Name = Text
+
+type Document = NonEmpty Operation
+
+data Operation = Query    (NonEmpty Field)
+               | Mutation (NonEmpty 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
+           | 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)

src/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

src/Data/GraphQL/Encoder.hs

@@ -0,0 +1,179 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | This module defines a printer for the @GraphQL@ language.
+module Data.GraphQL.Encoder where
+
+import Data.Foldable (fold)
+import Data.Monoid ((<>))
+import qualified Data.List.NonEmpty as NonEmpty (toList)
+
+import Data.Text (Text, cons, intercalate, pack, snoc)
+
+import Data.GraphQL.AST
+
+-- * Document
+
+document :: Document -> Text
+document defs = (`snoc` '\n') . mconcat . NonEmpty.toList $ definition <$> defs
+
+definition :: Definition -> Text
+definition (DefinitionOperation x) = operationDefinition x
+definition (DefinitionFragment  x) = fragmentDefinition x
+
+operationDefinition :: OperationDefinition -> Text
+operationDefinition (OperationSelectionSet sels) = selectionSet sels
+operationDefinition (OperationDefinition Query    name vars dirs sels) =
+  "query " <> node (fold name) vars dirs sels
+operationDefinition (OperationDefinition Mutation name vars dirs sels) =
+  "mutation " <> node (fold name) vars dirs sels
+
+node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
+node name vars dirs sels =
+       name
+    <> optempty variableDefinitions vars
+    <> optempty directives dirs
+    <> selectionSet sels
+
+variableDefinitions :: [VariableDefinition] -> Text
+variableDefinitions = parensCommas variableDefinition
+
+variableDefinition :: VariableDefinition -> Text
+variableDefinition (VariableDefinition var ty dv) =
+    variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv
+
+defaultValue :: DefaultValue -> Text
+defaultValue val = "=" <> value val
+
+variable :: Variable -> Text
+variable var = "$" <> var
+
+selectionSet :: SelectionSet -> Text
+selectionSet = bracesCommas selection . NonEmpty.toList
+
+selectionSetOpt :: SelectionSetOpt -> Text
+selectionSetOpt = bracesCommas selection
+
+selection :: Selection -> Text
+selection (SelectionField          x) = field x
+selection (SelectionInlineFragment x) = inlineFragment x
+selection (SelectionFragmentSpread x) = fragmentSpread x
+
+field :: Field -> Text
+field (Field alias name args dirs selso) =
+       optempty (`snoc` ':') (fold alias)
+    <> name
+    <> optempty arguments args
+    <> optempty directives dirs
+    <> optempty selectionSetOpt selso
+
+arguments :: [Argument] -> Text
+arguments = parensCommas argument
+
+argument :: Argument -> Text
+argument (Argument name v) = name <> ":" <> value v
+
+-- * Fragments
+
+fragmentSpread :: FragmentSpread -> Text
+fragmentSpread (FragmentSpread name ds) =
+    "..." <> name <> optempty directives ds
+
+inlineFragment :: InlineFragment -> Text
+inlineFragment (InlineFragment tc dirs sels) =
+    "... on " <> fold tc
+              <> directives dirs
+              <> selectionSet sels
+
+fragmentDefinition :: FragmentDefinition -> Text
+fragmentDefinition (FragmentDefinition name tc dirs sels) =
+    "fragment " <> name <> " on " <> tc
+                <> optempty directives dirs
+                <> selectionSet sels
+
+-- * Values
+
+value :: Value -> Text
+value (ValueVariable x) = variable x
+-- TODO: This will be replaced with `decimal` Builder
+value (ValueInt      x) = pack $ show x
+-- TODO: This will be replaced with `decimal` Builder
+value (ValueFloat    x) = pack $ show x
+value (ValueBoolean  x) = booleanValue x
+value ValueNull         = mempty
+value (ValueString   x) = stringValue x
+value (ValueEnum     x) = x
+value (ValueList     x) = listValue x
+value (ValueObject   x) = objectValue x
+
+booleanValue :: Bool -> Text
+booleanValue True  = "true"
+booleanValue False = "false"
+
+-- TODO: Escape characters
+stringValue :: Text -> Text
+stringValue = quotes
+
+listValue :: ListValue -> Text
+listValue = bracketsCommas value
+
+objectValue :: ObjectValue -> Text
+objectValue = bracesCommas objectField
+
+objectField :: ObjectField -> Text
+objectField (ObjectField name v) = name <> ":" <> value v
+
+-- * Directives
+
+directives :: [Directive] -> Text
+directives = spaces directive
+
+directive :: Directive -> Text
+directive (Directive name args) = "@" <> name <> optempty arguments args
+
+-- * Type Reference
+
+type_ :: Type -> Text
+type_ (TypeNamed   x) = x
+type_ (TypeList    x) = listType x
+type_ (TypeNonNull x) = nonNullType x
+
+listType :: Type -> Text
+listType x = brackets (type_ x)
+
+nonNullType :: NonNullType -> Text
+nonNullType (NonNullTypeNamed x) = x <> "!"
+nonNullType (NonNullTypeList  x) = listType x <> "!"
+
+-- * Internal
+
+spaced :: Text -> Text
+spaced = cons '\SP'
+
+between :: Char -> Char -> Text -> Text
+between open close = cons open . (`snoc` close)
+
+parens :: Text -> Text
+parens = between '(' ')'
+
+brackets :: Text -> Text
+brackets = between '[' ']'
+
+braces :: Text -> Text
+braces = between '{' '}'
+
+quotes :: Text -> Text
+quotes = between '"' '"'
+
+spaces :: (a -> Text) -> [a] -> Text
+spaces f = intercalate "\SP" . fmap f
+
+parensCommas :: (a -> Text) -> [a] -> Text
+parensCommas f = parens . intercalate "," . fmap f
+
+bracketsCommas :: (a -> Text) -> [a] -> Text
+bracketsCommas f = brackets . intercalate "," . fmap f
+
+bracesCommas :: (a -> Text) -> [a] -> Text
+bracesCommas f = braces . intercalate "," . fmap f
+
+optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b
+optempty f xs = if xs == mempty then mempty else f xs

src/Data/GraphQL/Error.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Data.GraphQL.Error
+  ( parseError
+  , CollectErrsT
+  , addErr
+  , addErrMsg
+  , runCollectErrs
+  , runAppendErrs
+  ) where
+
+import qualified Data.Aeson as Aeson
+import Data.Text (Text, pack)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State ( StateT
+                                 , modify
+                                 , runStateT
+                                 )
+
+-- | Wraps a parse error into a list of errors.
+parseError :: Applicative f => String -> f Aeson.Value
+parseError s =
+  pure $ Aeson.object [("errors", Aeson.toJSON [makeErrorMsg $ pack s])]
+
+-- | A wrapper to pass error messages around.
+type CollectErrsT m = StateT [Aeson.Value] m
+
+-- | Adds an error to the list of errors.
+addErr :: Monad m => Aeson.Value -> CollectErrsT m ()
+addErr v = modify (v :)
+
+makeErrorMsg :: Text -> Aeson.Value
+makeErrorMsg s = Aeson.object [("message", Aeson.toJSON s)]
+
+-- | Convenience function for just wrapping an error message.
+addErrMsg :: Monad m => Text -> CollectErrsT m ()
+addErrMsg = addErr . makeErrorMsg
+
+-- | Appends the given list of errors to the current list of errors.
+appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m ()
+appendErrs errs = modify (errs ++)
+
+-- | Runs the given query computation, but collects the errors into an error
+--   list, which is then sent back with the data.
+runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value
+runCollectErrs res = do
+    (dat, errs) <- runStateT res []
+    if null errs
+       then return $ Aeson.object [("data", dat)]
+       else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)]
+
+-- | Runs the given computation, collecting the errors and appending them
+--   to the previous list of errors.
+runAppendErrs :: Monad m => CollectErrsT m a -> CollectErrsT m a
+runAppendErrs f = do
+    (v, errs) <- lift $ runStateT f []
+    appendErrs errs
+    return v

src/Data/GraphQL/Execute.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | This module provides the function to execute a @GraphQL@ request --
+--   according to a 'Schema'.
+module Data.GraphQL.Execute (execute) where
+
+import Control.Monad (MonadPlus(..))
+import Data.GraphQL.Error
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty((:|)))
+import qualified Data.Aeson as Aeson
+import qualified Data.GraphQL.AST as AST
+import qualified Data.GraphQL.AST.Core as AST.Core
+import qualified Data.GraphQL.AST.Transform as Transform
+import Data.GraphQL.Schema (Schema)
+import qualified Data.GraphQL.Schema as Schema
+
+-- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a
+--   @GraphQL@ 'document'. The substitution is applied to the document using
+--  'rootFields', and the 'Schema''s resolvers are applied to the resulting fields.
+--
+--   Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
+--   errors wrapped in an /errors/ field.
+execute
+  :: (MonadPlus m)
+  => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value
+execute schema subs doc = do
+    coreDocument <- maybe mzero pure (Transform.document subs doc)
+    document schema coreDocument
+
+document :: MonadPlus m => Schema m -> AST.Core.Document -> m Aeson.Value
+document schema (op :| []) = operation schema op
+document _ _ = error "Multiple operations not supported yet"
+
+operation :: MonadPlus m => Schema m -> AST.Core.Operation -> m Aeson.Value
+operation schema (AST.Core.Query flds)
+    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
+operation schema (AST.Core.Mutation flds)
+    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))

src/Data/GraphQL/Parser.hs

@@ -0,0 +1,183 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Data.GraphQL.Parser where
+
+import Control.Applicative ( Alternative(..)
+                           , optional
+                           )
+import Data.GraphQL.AST
+import Language.GraphQL.Lexer
+import Data.List.NonEmpty (NonEmpty(..))
+import Text.Megaparsec ( lookAhead
+                       , option
+                       , try
+                       , (<?>)
+                       )
+
+document :: Parser Document
+document = spaceConsumer >> lexeme (manyNE definition)
+
+definition :: Parser Definition
+definition = DefinitionOperation <$> operationDefinition
+         <|> DefinitionFragment  <$> fragmentDefinition
+         <?> "definition error!"
+
+operationDefinition :: Parser OperationDefinition
+operationDefinition = OperationSelectionSet <$> selectionSet
+                  <|> OperationDefinition   <$> operationType
+                                            <*> optional name
+                                            <*> opt variableDefinitions
+                                            <*> opt directives
+                                            <*> selectionSet
+                  <?> "operationDefinition error"
+
+operationType :: Parser OperationType
+operationType = Query <$ symbol "query"
+    <|> Mutation <$ symbol "mutation"
+    <?> "operationType error"
+
+-- * SelectionSet
+
+selectionSet :: Parser SelectionSet
+selectionSet = braces $ manyNE selection
+
+selectionSetOpt :: Parser SelectionSetOpt
+selectionSetOpt = braces $ some selection
+
+selection :: Parser Selection
+selection = SelectionField          <$> field
+        <|> try (SelectionFragmentSpread <$> fragmentSpread)
+        <|> SelectionInlineFragment <$> inlineFragment
+        <?> "selection error!"
+
+-- * Field
+
+field :: Parser Field
+field = Field <$> optional alias
+              <*> name
+              <*> opt arguments
+              <*> opt directives
+              <*> opt selectionSetOpt
+
+alias :: Parser Alias
+alias = try $ name <* colon
+
+-- * Arguments
+
+arguments :: Parser Arguments
+arguments = parens $ some argument
+
+argument :: Parser Argument
+argument = Argument <$> name <* colon <*> value
+
+-- * Fragments
+
+fragmentSpread :: Parser FragmentSpread
+fragmentSpread = FragmentSpread <$  spread
+                                <*> fragmentName
+                                <*> opt directives
+
+inlineFragment :: Parser InlineFragment
+inlineFragment = InlineFragment <$  spread
+                                <*> optional typeCondition
+                                <*> opt directives
+                                <*> selectionSet
+
+fragmentDefinition :: Parser FragmentDefinition
+fragmentDefinition = FragmentDefinition
+                 <$  symbol "fragment"
+                 <*> name
+                 <*> typeCondition
+                 <*> opt directives
+                 <*> selectionSet
+
+fragmentName :: Parser FragmentName
+fragmentName = but (symbol "on") *> name
+
+typeCondition :: Parser TypeCondition
+typeCondition = symbol "on" *> name
+
+-- * Input Values
+
+value :: Parser Value
+value = ValueVariable <$> variable
+    <|> ValueFloat    <$> try float
+    <|> ValueInt      <$> integer
+    <|> ValueBoolean  <$> booleanValue
+    <|> ValueNull     <$  symbol "null"
+    <|> ValueString   <$> string
+    <|> ValueString   <$> blockString
+    <|> ValueEnum     <$> try enumValue
+    <|> ValueList     <$> listValue
+    <|> ValueObject   <$> objectValue
+    <?> "value error!"
+  where
+    booleanValue :: Parser Bool
+    booleanValue = True  <$ symbol "true"
+               <|> False <$ symbol "false"
+
+    enumValue :: Parser Name
+    enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
+
+    listValue :: Parser [Value]
+    listValue = brackets $ some value
+
+    objectValue :: Parser [ObjectField]
+    objectValue = braces $ some objectField
+
+objectField :: Parser ObjectField
+objectField = ObjectField <$> name <* symbol ":" <*> value
+
+-- * Variables
+
+variableDefinitions :: Parser VariableDefinitions
+variableDefinitions = parens $ some variableDefinition
+
+variableDefinition :: Parser VariableDefinition
+variableDefinition = VariableDefinition <$> variable
+                                        <*  colon
+                                        <*> type_
+                                        <*> optional defaultValue
+variable :: Parser Variable
+variable = dollar *> name
+
+defaultValue :: Parser DefaultValue
+defaultValue = equals *> value
+
+-- * Input Types
+
+type_ :: Parser Type
+type_ = try (TypeNamed <$> name <* but "!")
+    <|> TypeList       <$> brackets type_
+    <|> TypeNonNull    <$> nonNullType
+    <?> "type_ error!"
+
+nonNullType :: Parser NonNullType
+nonNullType = NonNullTypeNamed <$> name <* bang
+          <|> NonNullTypeList  <$> brackets type_  <* bang
+          <?> "nonNullType error!"
+
+-- * Directives
+
+directives :: Parser Directives
+directives = some directive
+
+directive :: Parser Directive
+directive = Directive
+        <$  at
+        <*> name
+        <*> opt arguments
+
+-- * Internal
+
+opt :: Monoid a => Parser a -> Parser a
+opt = option mempty
+
+-- Hack to reverse parser success
+but :: Parser a -> Parser ()
+but pn = False <$ lookAhead pn <|> pure True >>= \case
+    False -> empty
+    True  -> pure ()
+
+manyNE :: Alternative f => f a -> f (NonEmpty a)
+manyNE p = (:|) <$> p <*> many p

src/Data/GraphQL/Schema.hs

@@ -0,0 +1,168 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+-- | This module provides a representation of a @GraphQL@ Schema in addition to
+--   functions for defining and manipulating Schemas.
+module Data.GraphQL.Schema
+  ( Schema
+  , Resolver
+  , Subs
+  , object
+  , object'
+  , objectA
+  , objectA'
+  , scalar
+  , scalarA
+  , array
+  , array'
+  , arrayA
+  , arrayA'
+  , enum
+  , enumA
+  , resolve
+  -- * AST Reexports
+  , Field
+  , Argument(..)
+  , Value(..)
+  ) where
+
+import Control.Applicative (Alternative(..))
+import Control.Monad (MonadPlus)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State ( get
+                                 , put
+                                 )
+import Data.Foldable (fold)
+import Data.GraphQL.Error
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe (fromMaybe)
+import Data.Monoid (Alt(..))
+import qualified Data.Aeson as Aeson
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Text as T
+
+import Data.GraphQL.AST.Core
+
+-- | A GraphQL schema.
+--   @f@ is usually expected to be an instance of 'Alternative'.
+type Schema m = NonEmpty (Resolver m)
+
+-- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
+--   (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'.
+type Resolver m = Field -> CollectErrsT m Aeson.Object
+
+type Resolvers m = [Resolver m]
+
+type Fields = [Field]
+
+type Arguments = [Argument]
+
+-- | Variable substitution function.
+type Subs = Name -> Maybe Value
+
+-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
+object :: MonadPlus m => Name -> Resolvers m -> Resolver m
+object name resolvers = objectA name $ \case
+  [] -> resolvers
+  _  -> empty
+
+-- | Like 'object' but also taking 'Argument's.
+objectA
+  :: MonadPlus m
+  => Name -> (Arguments -> Resolvers m) -> Resolver m
+objectA name f fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld
+
+
+-- | Create a named 'Resolver' from a list of 'Resolver's.
+object' :: MonadPlus m => Name -> m (Resolvers m) -> Resolver m
+object' name resolvs = objectA' name $ \case
+     [] -> resolvs
+     _  -> empty
+
+-- | Like 'object'' but also taking 'Argument's.
+objectA'
+  :: MonadPlus m
+  => Name -> (Arguments -> m (Resolvers m)) -> Resolver m
+objectA' name f fld@(Field _ _ args flds) = do
+    resolvs <- lift $ f args
+    withField name (resolve resolvs flds) fld
+
+-- | A scalar represents a primitive value, like a string or an integer.
+scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> a -> Resolver m
+scalar name s = scalarA name $ \case
+    [] -> pure s
+    _  -> empty
+
+-- | Like 'scalar' but also taking 'Argument's.
+scalarA
+  :: (MonadPlus m, Aeson.ToJSON a)
+  => Name -> (Arguments -> m a) -> Resolver m
+scalarA name f fld@(Field _ _ args []) = withField name (lift $ f args) fld
+scalarA _ _ _ = empty
+
+array :: MonadPlus m => Name -> [Resolvers m] -> Resolver m
+array name resolvers = arrayA name $ \case
+    [] -> resolvers
+    _  -> empty
+
+-- | Like 'array' but also taking 'Argument's.
+arrayA
+  :: MonadPlus m
+  => Name -> (Arguments -> [Resolvers m]) -> Resolver m
+arrayA name f fld@(Field _ _ args sels) =
+     withField name (traverse (`resolve` sels) $ f args) fld
+
+-- | Like 'object'' but taking lists of 'Resolver's instead of a single list.
+array' :: MonadPlus m => Name -> m [Resolvers m] -> Resolver m
+array' name resolvs = arrayA' name $ \case
+    [] -> resolvs
+    _  -> empty
+
+-- | Like 'array'' but also taking 'Argument's.
+arrayA'
+  :: MonadPlus m
+  => Name -> (Arguments -> m [Resolvers m]) -> Resolver m
+arrayA' name f fld@(Field _ _ args sels) = do
+     resolvs <- lift $ f args
+     withField name (traverse (`resolve` sels) resolvs) fld
+
+-- | Represents one of a finite set of possible values.
+--   Used in place of a 'scalar' when the possible responses are easily enumerable.
+enum :: MonadPlus m => Name -> m [T.Text] -> Resolver m
+enum name enums = enumA name $ \case
+     [] -> enums
+     _  -> empty
+
+-- | Like 'enum' but also taking 'Argument's.
+enumA :: MonadPlus m => Name -> (Arguments -> m [T.Text]) -> Resolver m
+enumA name f fld@(Field _ _ args []) = withField name (lift $ f args) fld
+enumA _ _ _ = empty
+
+-- | Helper function to facilitate 'Argument' handling.
+withField :: (MonadPlus m, Aeson.ToJSON a)
+          => Name -> CollectErrsT m a -> Field -> CollectErrsT m (HashMap T.Text Aeson.Value)
+withField name v (Field alias name' _ _)
+    | name == name' = do
+        collection <- HashMap.singleton aliasOrName . Aeson.toJSON <$> runAppendErrs v
+        errors <- get
+        if null errors
+           then return collection
+           -- TODO: Report error when Non-Nullable type for field argument.
+           else put [] >> return (HashMap.singleton aliasOrName Aeson.Null)
+    | otherwise = empty
+  where
+    aliasOrName = fromMaybe name alias
+
+-- | Takes a list of 'Resolver's and a list of 'Field's and applies each
+--   'Resolver' to each 'Field'. Resolves into a value containing the
+--   resolved 'Field', or a null value and error information.
+resolve :: MonadPlus m => Resolvers m -> Fields -> CollectErrsT m Aeson.Value
+resolve resolvers =
+    fmap (Aeson.toJSON . fold)
+  . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers) <|> errmsg fld)
+  where
+    errmsg (Field alias name _ _) = do
+        addErrMsg $ T.unwords ["field", name, "not resolved."]
+        return $ HashMap.singleton aliasOrName Aeson.Null
+          where
+            aliasOrName = fromMaybe name alias

src/Language/GraphQL/Lexer.hs

@@ -0,0 +1,215 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.Lexer 
+    ( Parser
+    , amp
+    , at
+    , bang
+    , blockString
+    , braces
+    , brackets
+    , colon
+    , dollar
+    , comment
+    , equals
+    , integer
+    , float
+    , lexeme
+    , name
+    , parens
+    , pipe
+    , spaceConsumer
+    , spread
+    , string
+    , symbol
+    ) where
+
+import Control.Applicative ( Alternative(..)
+                           , liftA2
+                           )
+import Data.Char ( chr
+                 , digitToInt
+                 , isAsciiLower
+                 , isAsciiUpper
+                 , ord
+                 )
+import Data.Foldable (foldl')
+import Data.List (dropWhileEnd)
+import Data.Proxy (Proxy(..))
+import Data.Void (Void)
+import Text.Megaparsec ( Parsec
+                       , between
+                       , chunk
+                       , chunkToTokens
+                       , notFollowedBy
+                       , oneOf
+                       , option
+                       , satisfy
+                       , sepBy
+                       , skipSome
+                       , takeP
+                       , takeWhile1P
+                       , try
+                       )
+import Text.Megaparsec.Char ( char
+                            , digitChar
+                            , space1
+                            )
+import qualified Text.Megaparsec.Char.Lexer as Lexer
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+
+-- | Standard parser.
+-- Accepts the type of the parsed token.
+type Parser = Parsec Void T.Text
+
+ignoredCharacters :: Parser ()
+ignoredCharacters = space1 <|> skipSome (char ',')
+
+spaceConsumer :: Parser ()
+spaceConsumer = Lexer.space ignoredCharacters comment empty
+
+-- | Parser for comments.
+comment :: Parser ()
+comment = Lexer.skipLineComment "#"
+
+lexeme :: forall a. Parser a -> Parser a
+lexeme = Lexer.lexeme spaceConsumer
+
+symbol :: T.Text -> Parser T.Text
+symbol = Lexer.symbol spaceConsumer
+
+-- | Parser for "!".
+bang :: Parser Char
+bang = char '!'
+
+-- | Parser for "$".
+dollar :: Parser Char
+dollar = char '$'
+
+-- | Parser for "@".
+at :: Parser Char
+at = char '@'
+
+-- | Parser for "&".
+amp :: Parser T.Text
+amp = symbol "&"
+
+-- | Parser for ":".
+colon :: Parser T.Text
+colon = symbol ":"
+
+-- | Parser for "=".
+equals :: Parser T.Text
+equals = symbol "="
+
+-- | Parser for the spread operator (...).
+spread :: Parser T.Text
+spread = symbol "..."
+
+-- | Parser for "|".
+pipe :: Parser T.Text
+pipe = symbol "|"
+
+-- | Parser for an expression between "(" and ")".
+parens :: forall a. Parser a -> Parser a
+parens = between (symbol "(") (symbol ")")
+
+-- | Parser for an expression between "[" and "]".
+brackets :: forall a. Parser a -> Parser a
+brackets = between (symbol "[") (symbol "]")
+
+-- | Parser for an expression between "{" and "}".
+braces :: forall a. Parser a -> Parser a
+braces = between (symbol "{") (symbol "}")
+
+-- | Parser for strings.
+string :: Parser T.Text
+string = between "\"" "\"" stringValue
+  where
+    stringValue = T.pack <$> many stringCharacter
+    stringCharacter = satisfy isStringCharacter1
+        <|> escapeSequence
+    isStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter
+
+-- | Parser for block strings.
+blockString :: Parser T.Text
+blockString = between "\"\"\"" "\"\"\"" stringValue
+  where
+    stringValue = do
+        byLine <- sepBy (many blockStringCharacter) lineTerminator
+        let indentSize = foldr countIndent 0 $ tail byLine
+            withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)
+            withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent
+
+        return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
+    removeEmptyLine [] = True
+    removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)
+    removeEmptyLine _ = False
+    blockStringCharacter
+        = takeWhile1P Nothing isWhiteSpace
+        <|> takeWhile1P Nothing isBlockStringCharacter1
+        <|> escapeTripleQuote
+        <|> try (chunk "\"" <* notFollowedBy (chunk "\"\""))
+    escapeTripleQuote = chunk "\\" >>= flip option (chunk "\"\"")
+    isBlockStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter
+    countIndent [] acc = acc
+    countIndent (x:_) acc
+        | T.null x = acc
+        | not (isWhiteSpace $ T.head x) = acc
+        | acc == 0 = T.length x
+        | otherwise = min acc $ T.length x
+    removeIndent _ [] = []
+    removeIndent n (x:chunks) = T.drop n x : chunks
+
+-- | Parser for integers.
+integer :: Integral a => Parser a
+integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal
+
+-- | Parser for floating-point numbers.
+float :: Parser Double
+float = Lexer.signed (pure ()) $ lexeme Lexer.float
+
+-- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/).
+name :: Parser T.Text
+name = do
+    firstLetter <- nameFirstLetter
+    rest <- many $ nameFirstLetter <|> digitChar
+    _ <- spaceConsumer
+    return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
+      where
+        nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
+
+isChunkDelimiter :: Char -> Bool
+isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']
+
+isWhiteSpace :: Char -> Bool
+isWhiteSpace = liftA2 (||) (== ' ') (== '\t')
+
+lineTerminator :: Parser T.Text
+lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"
+
+isSourceCharacter :: Char -> Bool
+isSourceCharacter = isSourceCharacter' . ord
+  where
+    isSourceCharacter' code = code >= 0x0020
+                           || code == 0x0009
+                           || code == 0x000a
+                           || code == 0x000d
+
+escapeSequence :: Parser Char
+escapeSequence = do
+    _ <- char '\\'
+    escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']
+    case escaped of
+        'b' -> return '\b'
+        'f' -> return '\f'
+        'n' -> return '\n'
+        'r' -> return '\r'
+        't' -> return '\t'
+        'u' -> chr . foldl' step 0
+                   . chunkToTokens (Proxy :: Proxy T.Text)
+                 <$> takeP Nothing 4
+        _ -> return escaped
+  where
+    step accumulator = (accumulator * 16 +) . digitToInt