5 files changed, 836 insertions, 181 deletions

diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs
index a2a53be..f7a008f 100644
--- a/src/Language/GraphQL/AST/Core.hs
+++ b/src/Language/GraphQL/AST/Core.hs
@@ -6,7 +6,6 @@ module Language.GraphQL.AST.Core
     , Field(..)
     , Fragment(..)
     , Name
-    , ObjectField(..)
     , Operation(..)
     , Selection(..)
     , TypeCondition
@@ -14,12 +13,12 @@ module Language.GraphQL.AST.Core
     ) where
 
 import Data.Int (Int32)
+import Data.HashMap.Strict (HashMap)
 import Data.List.NonEmpty (NonEmpty)
-import Data.String
+import Data.Sequence (Seq)
+import Data.String (IsString(..))
 import Data.Text (Text)
-
--- | Name
-type Name = Text
+import Language.GraphQL.AST (Alias, Name, TypeCondition)
 
 -- | GraphQL document is a non-empty list of operations.
 type Document = NonEmpty Operation
@@ -28,87 +27,21 @@ type Document = NonEmpty Operation
 --
 -- Currently only queries and mutations are supported.
 data Operation
-    = Query (Maybe Text) (NonEmpty Selection)
-    | Mutation (Maybe Text) (NonEmpty Selection)
+    = Query (Maybe Text) (Seq Selection)
+    | Mutation (Maybe Text) (Seq Selection)
     deriving (Eq, Show)
 
--- | A single GraphQL field.
---
--- Only required property of a field, is its name. Optionally it can also have
--- an alias, arguments or a list of subfields.
---
--- Given the following query:
---
--- @
--- {
---   zuck: user(id: 4) {
---     id
---     name
---   }
--- }
--- @
---
--- * "user", "id" and "name" are field names.
--- * "user" has two subfields, "id" and "name".
--- * "zuck" is an alias for "user". "id" and "name" have no aliases.
--- * "id: 4" is an argument for "name". "id" and "name don't have any
--- arguments.
-data Field = Field (Maybe Alias) Name [Argument] [Selection] deriving (Eq, Show)
-
--- | Alternative field name.
---
--- @
--- {
---   smallPic: profilePic(size: 64)
---   bigPic: profilePic(size: 1024)
--- }
--- @
---
--- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
--- used to distinquish between profile pictures with different arguments
--- (sizes).
-type Alias = Name
+-- | Single GraphQL field.
+data Field
+    = Field (Maybe Alias) Name [Argument] (Seq Selection)
+    deriving (Eq, Show)
 
 -- | Single argument.
---
--- @
--- {
---   user(id: 4) {
---     name
---   }
--- }
--- @
---
---  Here "id" is an argument for the field "user" and its value is 4.
 data Argument = Argument Name Value deriving (Eq, Show)
 
--- | Represents accordingly typed GraphQL values.
-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
-
--- | Key-value pair.
---
--- A list of 'ObjectField's represents a GraphQL object type.
-data ObjectField = ObjectField Name Value deriving (Eq, Show)
-
--- | Type condition.
-type TypeCondition = Name
-
 -- | Represents fragments and inline fragments.
 data Fragment
-    = Fragment TypeCondition (NonEmpty Selection)
+    = Fragment TypeCondition (Seq Selection)
     deriving (Eq, Show)
 
 -- | Single selection element.
@@ -116,3 +49,18 @@ data Selection
     = SelectionFragment Fragment
     | SelectionField Field
     deriving (Eq, Show)
+
+-- | Represents accordingly typed GraphQL values.
+data Value
+    = Int Int32
+    | Float Double -- ^ GraphQL Float is double precision
+    | String Text
+    | Boolean Bool
+    | Null
+    | Enum Name
+    | List [Value]
+    | Object (HashMap Name Value)
+    deriving (Eq, Show)
+
+instance IsString Value where
+    fromString = String . fromString
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
new file mode 100644
index 0000000..afc425f
--- /dev/null
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -0,0 +1,277 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExplicitForAll #-}
+
+-- | This module defines a minifier and a printer for the @GraphQL@ language.
+module Language.GraphQL.AST.Encoder
+    ( Formatter
+    , definition
+    , directive
+    , document
+    , minified
+    , pretty
+    , type'
+    , value
+    ) where
+
+import Data.Foldable (fold)
+import Data.Monoid ((<>))
+import qualified Data.List.NonEmpty as NonEmpty (toList)
+import Data.Text.Lazy (Text)
+import qualified Data.Text.Lazy as Text.Lazy
+import Data.Text.Lazy.Builder (toLazyText)
+import Data.Text.Lazy.Builder.Int (decimal)
+import Data.Text.Lazy.Builder.RealFloat (realFloat)
+import qualified Language.GraphQL.AST as Full
+
+-- | Instructs the encoder whether the GraphQL document should be minified or
+--   pretty printed.
+--
+--   Use 'pretty' or 'minified' to construct the formatter.
+data Formatter
+    = Minified
+    | Pretty Word
+
+-- | Constructs a formatter for pretty printing.
+pretty :: Formatter
+pretty = Pretty 0
+
+-- | Constructs a formatter for minifying.
+minified :: Formatter
+minified = Minified
+
+-- | Converts a 'Full.Document' into a string.
+document :: Formatter -> Full.Document -> Text
+document formatter defs
+    | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument
+    | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n'
+  where
+    encodeDocument = NonEmpty.toList $ definition formatter <$> defs
+
+-- | Converts a 'Full.Definition' into a string.
+definition :: Formatter -> Full.Definition -> Text
+definition formatter x
+    | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n'
+    | Minified <- formatter = encodeDefinition x
+  where
+    encodeDefinition (Full.DefinitionOperation operation)
+        = operationDefinition formatter operation
+    encodeDefinition (Full.DefinitionFragment fragment)
+        = fragmentDefinition formatter fragment
+
+operationDefinition :: Formatter -> Full.OperationDefinition -> Text
+operationDefinition formatter (Full.OperationSelectionSet sels)
+    = selectionSet formatter sels
+operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
+    = "query " <> node formatter name vars dirs sels
+operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)
+    = "mutation " <> node formatter name vars dirs sels
+
+node :: Formatter
+    -> Maybe Full.Name
+    -> [Full.VariableDefinition]
+    -> [Full.Directive]
+    -> Full.SelectionSet
+    -> Text
+node formatter name vars dirs sels
+    = Text.Lazy.fromStrict (fold name)
+    <> optempty (variableDefinitions formatter) vars
+    <> optempty (directives formatter) dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
+
+variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Text
+variableDefinitions formatter
+    = parensCommas formatter $ variableDefinition formatter
+
+variableDefinition :: Formatter -> Full.VariableDefinition -> Text
+variableDefinition formatter (Full.VariableDefinition var ty dv)
+    = variable var
+    <> eitherFormat formatter ": " ":"
+    <> type' ty
+    <> maybe mempty (defaultValue formatter) dv
+
+defaultValue :: Formatter -> Full.Value -> Text
+defaultValue formatter val
+    = eitherFormat formatter " = " "="
+    <> value formatter val
+
+variable :: Full.Name -> Text
+variable var = "$" <> Text.Lazy.fromStrict var
+
+selectionSet :: Formatter -> Full.SelectionSet -> Text
+selectionSet formatter
+    = bracesList formatter (selection formatter)
+    . NonEmpty.toList
+
+selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Text
+selectionSetOpt formatter = bracesList formatter $ selection formatter
+
+selection :: Formatter -> Full.Selection -> Text
+selection formatter = Text.Lazy.append indent . f
+  where
+    f (Full.SelectionField x) = field incrementIndent x
+    f (Full.SelectionInlineFragment x) = inlineFragment incrementIndent x
+    f (Full.SelectionFragmentSpread x) = fragmentSpread incrementIndent x
+    incrementIndent
+        | Pretty n <- formatter = Pretty $ n + 1
+        | otherwise = Minified
+    indent
+        | Pretty n <- formatter = Text.Lazy.replicate (fromIntegral $ n + 1) "  "
+        | otherwise = mempty
+
+field :: Formatter -> Full.Field -> Text
+field formatter (Full.Field alias name args dirs selso)
+    = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias)
+    <> Text.Lazy.fromStrict name
+    <> optempty (arguments formatter) args
+    <> optempty (directives formatter) dirs
+    <> selectionSetOpt'
+  where
+    colon = eitherFormat formatter ": " ":"
+    selectionSetOpt'
+        | null selso = mempty
+        | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso
+
+arguments :: Formatter -> [Full.Argument] -> Text
+arguments formatter = parensCommas formatter $ argument formatter
+
+argument :: Formatter -> Full.Argument -> Text
+argument formatter (Full.Argument name v)
+    = Text.Lazy.fromStrict name
+    <> eitherFormat formatter ": " ":"
+    <> value formatter v
+
+-- * Fragments
+
+fragmentSpread :: Formatter -> Full.FragmentSpread -> Text
+fragmentSpread formatter (Full.FragmentSpread name ds)
+    = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds
+
+inlineFragment :: Formatter -> Full.InlineFragment -> Text
+inlineFragment formatter (Full.InlineFragment tc dirs sels)
+    = "... on "
+    <> Text.Lazy.fromStrict (fold tc)
+    <> directives formatter dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
+
+fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Text
+fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
+    = "fragment " <> Text.Lazy.fromStrict name
+    <> " on " <> Text.Lazy.fromStrict tc
+    <> optempty (directives formatter) dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
+
+-- * Miscellaneous
+
+-- | Converts a 'Full.Directive' into a string.
+directive :: Formatter -> Full.Directive -> Text
+directive formatter (Full.Directive name args)
+    = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args
+
+directives :: Formatter -> [Full.Directive] -> Text
+directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)
+directives Minified = spaces (directive Minified)
+
+-- | Converts a 'Full.Value' into a string.
+value :: Formatter -> Full.Value -> Text
+value _ (Full.Variable x) = variable x
+value _ (Full.Int x) = toLazyText $ decimal x
+value _ (Full.Float x) = toLazyText $ realFloat x
+value _ (Full.Boolean  x) = booleanValue x
+value _ Full.Null = mempty
+value _ (Full.String x) = stringValue $ Text.Lazy.fromStrict x
+value _ (Full.Enum x) = Text.Lazy.fromStrict x
+value formatter (Full.List x) = listValue formatter x
+value formatter (Full.Object x) = objectValue formatter x
+
+booleanValue :: Bool -> Text
+booleanValue True  = "true"
+booleanValue False = "false"
+
+stringValue :: Text -> Text
+stringValue
+    = quotes
+    . Text.Lazy.replace "\"" "\\\""
+    . Text.Lazy.replace "\\" "\\\\"
+
+listValue :: Formatter -> [Full.Value] -> Text
+listValue formatter = bracketsCommas formatter $ value formatter
+
+objectValue :: Formatter -> [Full.ObjectField] -> Text
+objectValue formatter = intercalate $ objectField formatter
+  where
+    intercalate f
+        = braces
+        . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+        . fmap f
+
+
+objectField :: Formatter -> Full.ObjectField -> Text
+objectField formatter (Full.ObjectField name v)
+    = Text.Lazy.fromStrict name <> colon <> value formatter v
+  where
+    colon
+      | Pretty _ <- formatter = ": "
+      | Minified <- formatter = ":"
+
+-- | Converts a 'Full.Type' a type into a string.
+type' :: Full.Type -> Text
+type' (Full.TypeNamed   x) = Text.Lazy.fromStrict x
+type' (Full.TypeList    x) = listType x
+type' (Full.TypeNonNull x) = nonNullType x
+
+listType :: Full.Type -> Text
+listType x = brackets (type' x)
+
+nonNullType :: Full.NonNullType -> Text
+nonNullType (Full.NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"
+nonNullType (Full.NonNullTypeList  x) = listType x <> "!"
+
+-- * Internal
+
+between :: Char -> Char -> Text -> Text
+between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close)
+
+parens :: Text -> Text
+parens = between '(' ')'
+
+brackets :: Text -> Text
+brackets = between '[' ']'
+
+braces :: Text -> Text
+braces = between '{' '}'
+
+quotes :: Text -> Text
+quotes = between '"' '"'
+
+spaces :: forall a. (a -> Text) -> [a] -> Text
+spaces f = Text.Lazy.intercalate "\SP" . fmap f
+
+parensCommas :: forall a. Formatter -> (a -> Text) -> [a] -> Text
+parensCommas formatter f
+    = parens
+    . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+    . fmap f
+
+bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text
+bracketsCommas formatter f
+    = brackets
+    . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+    . fmap f
+
+bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text
+bracesList (Pretty intendation) f xs
+    = Text.Lazy.snoc (Text.Lazy.intercalate "\n" content) '\n'
+    <> (Text.Lazy.snoc $ Text.Lazy.replicate (fromIntegral intendation) "  ") '}'
+  where
+    content = "{" : fmap f xs
+bracesList Minified f xs = braces $ Text.Lazy.intercalate "," $ fmap f xs
+
+optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b
+optempty f xs = if xs == mempty then mempty else f xs
+
+eitherFormat :: forall a. Formatter -> a -> a -> a
+eitherFormat (Pretty _) x _ = x
+eitherFormat Minified _ x = x
diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs
new file mode 100644
index 0000000..e4d64ca
--- /dev/null
+++ b/src/Language/GraphQL/AST/Lexer.hs
@@ -0,0 +1,228 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module defines a bunch of small parsers used to parse individual
+--   lexemes.
+module Language.GraphQL.AST.Lexer
+    ( Parser
+    , amp
+    , at
+    , bang
+    , blockString
+    , braces
+    , brackets
+    , colon
+    , dollar
+    , comment
+    , equals
+    , integer
+    , float
+    , lexeme
+    , name
+    , parens
+    , pipe
+    , spaceConsumer
+    , spread
+    , string
+    , symbol
+    , unicodeBOM
+    ) 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
+                       , optional
+                       , 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 ',')
+
+-- | Parser that skips comments and meaningless characters, whitespaces and
+-- commas.
+spaceConsumer :: Parser ()
+spaceConsumer = Lexer.space ignoredCharacters comment empty
+
+-- | Parser for comments.
+comment :: Parser ()
+comment = Lexer.skipLineComment "#"
+
+-- | Lexeme definition which ignores whitespaces and commas.
+lexeme :: forall a. Parser a -> Parser a
+lexeme = Lexer.lexeme spaceConsumer
+
+-- | Symbol definition which ignores whitespaces and commas.
+symbol :: T.Text -> Parser T.Text
+symbol = Lexer.symbol spaceConsumer
+
+-- | Parser for "!".
+bang :: Parser T.Text
+bang = symbol "!"
+
+-- | Parser for "$".
+dollar :: Parser T.Text
+dollar = symbol "$"
+
+-- | 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
+
+-- | Parser for the "Byte Order Mark".
+unicodeBOM :: Parser ()
+unicodeBOM = optional (char '\xfeff') >> pure ()
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
new file mode 100644
index 0000000..1505615
--- /dev/null
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | @GraphQL@ document parser.
+module Language.GraphQL.AST.Parser
+    ( document
+    ) where
+
+import Control.Applicative ( Alternative(..)
+                           , optional
+                           )
+import Data.List.NonEmpty (NonEmpty(..))
+import Language.GraphQL.AST
+import Language.GraphQL.AST.Lexer
+import Text.Megaparsec ( lookAhead
+                       , option
+                       , try
+                       , (<?>)
+                       )
+
+-- | Parser for the GraphQL documents.
+document :: Parser Document
+document = unicodeBOM >> 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 [Argument]
+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 Name
+fragmentName = but (symbol "on") *> name
+
+typeCondition :: Parser TypeCondition
+typeCondition = symbol "on" *> name
+
+-- * Input Values
+
+value :: Parser Value
+value = Variable <$> variable
+    <|> Float    <$> try float
+    <|> Int      <$> integer
+    <|> Boolean  <$> booleanValue
+    <|> Null     <$  symbol "null"
+    <|> String   <$> blockString
+    <|> String   <$> string
+    <|> Enum     <$> try enumValue
+    <|> List     <$> listValue
+    <|> Object   <$> 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 [VariableDefinition]
+variableDefinitions = parens $ some variableDefinition
+
+variableDefinition :: Parser VariableDefinition
+variableDefinition = VariableDefinition <$> variable
+                                        <*  colon
+                                        <*> type_
+                                        <*> optional defaultValue
+variable :: Parser Name
+variable = dollar *> name
+
+defaultValue :: Parser Value
+defaultValue = equals *> value
+
+-- * Input Types
+
+type_ :: Parser Type
+type_ = try (TypeNonNull <$> nonNullType)
+    <|> TypeList <$> brackets type_
+    <|> TypeNamed <$> name
+    <?> "type_ error!"
+
+nonNullType :: Parser NonNullType
+nonNullType = NonNullTypeNamed <$> name <* bang
+          <|> NonNullTypeList  <$> brackets type_  <* bang
+          <?> "nonNullType error!"
+
+-- * Directives
+
+directives :: Parser [Directive]
+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
diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs
index 3aa31b0..95cdfbb 100644
--- a/src/Language/GraphQL/AST/Transform.hs
+++ b/src/Language/GraphQL/AST/Transform.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ExplicitForAll #-}
 
 -- | After the document is parsed, before getting executed the AST is
 --   transformed into a similar, simpler AST. This module is responsible for
@@ -7,130 +8,143 @@ module Language.GraphQL.AST.Transform
     ( document
     ) where
 
-import Control.Applicative (empty)
-import Data.Bifunctor (first)
-import Data.Either (partitionEithers)
-import Data.Foldable (fold, foldMap)
-import Data.List.NonEmpty (NonEmpty)
+import Control.Arrow (first)
+import Control.Monad (foldM, unless)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
+import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import qualified Data.List.NonEmpty as NonEmpty
-import Data.Monoid (Alt(Alt,getAlt), (<>))
+import Data.Sequence (Seq, (<|), (><))
 import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.AST.Core as Core
 import qualified Language.GraphQL.Schema as Schema
 
--- | Replaces a fragment name by a list of 'Core.Field'. If the name doesn't
---   match an empty list is returned.
-type Fragmenter = Core.Name -> [Core.Field]
+-- | Associates a fragment name with a list of 'Core.Field's.
+data Replacement = Replacement
+    { fragments :: HashMap Core.Name (Seq Core.Selection)
+    , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
+    }
+
+type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
 
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
 document :: Schema.Subs -> Full.Document -> Maybe Core.Document
-document subs doc = operations subs fr ops
+document subs document' =
+    flip runReaderT subs
+        $ evalStateT (collectFragments >> operations operationDefinitions)
+        $ Replacement HashMap.empty fragmentTable
   where
-    (fr, ops) = first foldFrags
-              . partitionEithers
-              . NonEmpty.toList
-              $ defrag subs
-            <$> doc
-
-    foldFrags :: [Fragmenter] -> Fragmenter
-    foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
+    (fragmentTable, operationDefinitions) = foldr defragment mempty document'
+    defragment (Full.DefinitionOperation definition) acc =
+        (definition :) <$> acc
+    defragment (Full.DefinitionFragment definition) acc =
+        let (Full.FragmentDefinition name _ _ _) = definition
+         in first (HashMap.insert name definition) acc
 
 -- * Operation
 
 -- TODO: Replace Maybe by MonadThrow CustomError
-operations
-  :: Schema.Subs
-  -> Fragmenter
-  -> [Full.OperationDefinition]
-  -> Maybe Core.Document
-operations subs fr = NonEmpty.nonEmpty . fmap (operation subs fr)
-
-operation
-  :: Schema.Subs
-  -> Fragmenter
-  -> Full.OperationDefinition
-  -> Core.Operation
-operation subs fr (Full.OperationSelectionSet sels) =
-  operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
+operations :: [Full.OperationDefinition] -> TransformT Core.Document
+operations operations' = do
+    coreOperations <- traverse operation operations'
+    lift . lift $ NonEmpty.nonEmpty coreOperations
+
+operation :: Full.OperationDefinition -> TransformT Core.Operation
+operation (Full.OperationSelectionSet sels) =
+    operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
 -- TODO: Validate Variable definitions with substituter
-operation subs fr (Full.OperationDefinition Full.Query name _vars _dirs sels) =
-    Core.Query name $ appendSelection subs fr sels
-operation subs fr (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
-    Core.Mutation name $ appendSelection subs fr sels
-
-selection
-  :: Schema.Subs
-  -> Fragmenter
-  -> Full.Selection
-  -> Either [Core.Selection] Core.Selection
-selection subs fr (Full.SelectionField fld)
-    = Right $ Core.SelectionField $ field subs fr fld
-selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread name _))
-    = Left $ Core.SelectionField <$> fr name
-selection subs fr  (Full.SelectionInlineFragment fragment)
+operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =
+    Core.Query name <$> appendSelection sels
+operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
+    Core.Mutation name <$> appendSelection sels
+
+selection ::
+    Full.Selection ->
+    TransformT (Either (Seq Core.Selection) Core.Selection)
+selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld
+selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do
+    fragments' <- gets fragments
+    Left <$> maybe lookupDefinition liftJust (HashMap.lookup name fragments')
+  where
+    lookupDefinition :: TransformT (Seq Core.Selection)
+    lookupDefinition = do
+        fragmentDefinitions' <- gets fragmentDefinitions
+        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
+        fragmentDefinition found
+selection (Full.SelectionInlineFragment fragment)
     | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
         = Right
-        $ Core.SelectionFragment
-        $ Core.Fragment typeCondition
-        $ appendSelection subs fr selectionSet
+        . Core.SelectionFragment
+        . Core.Fragment typeCondition
+        <$> appendSelection selectionSet
     | (Full.InlineFragment Nothing _ selectionSet) <- fragment
-        = Left $ NonEmpty.toList $ appendSelection subs fr selectionSet
+        = Left <$> appendSelection selectionSet
 
 -- * 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'
-    | name == name' = selection' <$> do
-        selections <- NonEmpty.toList $ selection subs mempty <$> sels
-        either id pure selections
-    | otherwise = empty
+-- | Extract fragment definitions into a single 'HashMap'.
+collectFragments :: TransformT ()
+collectFragments = do
+    fragDefs <- gets fragmentDefinitions
+    let nextValue = head $ HashMap.elems fragDefs
+    unless (HashMap.null fragDefs) $ do
+        _ <- fragmentDefinition nextValue
+        collectFragments
+
+fragmentDefinition ::
+    Full.FragmentDefinition ->
+    TransformT (Seq Core.Selection)
+fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do
+    modify deleteFragmentDefinition
+    newValue <- appendSelection selections
+    modify $ insertFragment newValue
+    liftJust newValue
   where
-    selection' (Core.SelectionField field') = field'
-    selection' _ = error "Fragments within fragments are not supported yet"
+    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =
+        Replacement fragments' $ HashMap.delete name fragmentDefinitions'
+    insertFragment newValue (Replacement fragments' fragmentDefinitions') =
+        let newFragments = HashMap.insert name newValue fragments'
+         in Replacement newFragments fragmentDefinitions'
+
+field :: Full.Field -> TransformT Core.Field
+field (Full.Field a n args _dirs sels) = do
+    arguments <- traverse argument args
+    selection' <- appendSelection sels
+    return $ Core.Field a n arguments selection'
+
+argument :: Full.Argument -> TransformT Core.Argument
+argument (Full.Argument n v) = Core.Argument n <$> value v
+
+value :: Full.Value -> TransformT Core.Value
+value (Full.Variable n) = do
+    substitute' <- lift ask
+    lift . lift $ substitute' n
+value (Full.Int i) = pure $ Core.Int i
+value (Full.Float f) = pure $ Core.Float f
+value (Full.String x) = pure $ Core.String x
+value (Full.Boolean b) = pure $ Core.Boolean b
+value Full.Null = pure   Core.Null
+value (Full.Enum e) = pure $ Core.Enum e
+value (Full.List l) =
+    Core.List <$> traverse value l
+value (Full.Object o) =
+    Core.Object . HashMap.fromList <$> traverse objectField o
+
+objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)
+objectField (Full.ObjectField n v) = (n,) <$> value v
 
-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)
+appendSelection ::
+    Traversable t =>
+    t Full.Selection ->
+    TransformT (Seq Core.Selection)
+appendSelection = foldM go mempty
   where
-    go :: Full.Selection -> [Core.Selection] -> [Core.Selection]
-    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> 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
+    go acc sel = append acc <$> selection sel
+    append acc (Left list) = list >< acc
+    append acc (Right one) = one <| acc
 
-appendSelection ::
-    Schema.Subs ->
-    Fragmenter ->
-    NonEmpty Full.Selection ->
-    NonEmpty Core.Selection
-appendSelection subs fr = NonEmpty.fromList
-    . foldr (either (++) (:) . selection subs fr) []
+liftJust :: forall a. a -> TransformT a
+liftJust = lift . lift . Just