graphql/src/Language/GraphQL/AST/Encoder.hs

362 lines
12 KiB
Haskell
Raw Normal View History

{-# LANGUAGE ExplicitForAll #-}
2020-07-11 06:34:10 +02:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-- | This module defines a minifier and a printer for the @GraphQL@ language.
module Language.GraphQL.AST.Encoder
2019-08-03 23:57:27 +02:00
( Formatter
, definition
2019-08-14 08:49:07 +02:00
, directive
, document
2019-08-03 23:57:27 +02:00
, minified
, pretty
, type'
, value
2019-07-14 05:58:05 +02:00
) where
2019-12-20 07:58:09 +01:00
import Data.Char (ord)
import Data.Foldable (fold)
2019-12-20 07:58:09 +01:00
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy (Text)
import qualified Data.Text.Lazy as Lazy.Text
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as Builder
2019-12-20 07:58:09 +01:00
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
2019-12-26 13:00:47 +01:00
import Language.GraphQL.AST.Document
-- | Instructs the encoder whether the GraphQL document should be minified or
-- pretty printed.
--
-- Use 'pretty' or 'minified' to construct the formatter.
data Formatter
= Minified
2019-08-03 23:57:27 +02:00
| Pretty Word
-- | Constructs a formatter for pretty printing.
2019-08-03 23:57:27 +02:00
pretty :: Formatter
pretty = Pretty 0
-- | Constructs a formatter for minifying.
2019-08-03 23:57:27 +02:00
minified :: Formatter
minified = Minified
2019-12-26 13:00:47 +01:00
-- | Converts a Document' into a string.
document :: Formatter -> Document -> Lazy.Text
document formatter defs
2019-12-20 07:58:09 +01:00
| Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
where
encodeDocument = foldr executableDefinition [] defs
executableDefinition (ExecutableDefinition executableDefinition') acc =
definition formatter executableDefinition' : acc
2019-12-26 13:00:47 +01:00
executableDefinition _ acc = acc
2020-05-22 10:11:48 +02:00
-- | Converts a t'ExecutableDefinition' into a string.
2019-12-26 13:00:47 +01:00
definition :: Formatter -> ExecutableDefinition -> Lazy.Text
definition formatter x
2019-12-20 07:58:09 +01:00
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
| Minified <- formatter = encodeDefinition x
where
2020-05-22 10:11:48 +02:00
encodeDefinition (DefinitionOperation operation)
= operationDefinition formatter operation
2020-05-22 10:11:48 +02:00
encodeDefinition (DefinitionFragment fragment)
= fragmentDefinition formatter fragment
2020-05-22 10:11:48 +02:00
-- | Converts a 'OperationDefinition into a string.
operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
2020-07-11 06:34:10 +02:00
operationDefinition formatter = \case
SelectionSet sels _ -> selectionSet formatter sels
OperationDefinition Query name vars dirs sels _ ->
2020-07-11 06:34:10 +02:00
"query " <> node formatter name vars dirs sels
OperationDefinition Mutation name vars dirs sels _ ->
2020-07-11 06:34:10 +02:00
"mutation " <> node formatter name vars dirs sels
OperationDefinition Subscription name vars dirs sels _ ->
2020-07-11 06:34:10 +02:00
"subscription " <> node formatter name vars dirs sels
2020-05-22 10:11:48 +02:00
-- | Converts a Query or Mutation into a string.
2019-12-20 07:58:09 +01:00
node :: Formatter ->
2020-05-22 10:11:48 +02:00
Maybe Name ->
[VariableDefinition] ->
[Directive] ->
SelectionSet ->
2019-12-20 07:58:09 +01:00
Lazy.Text
node formatter name vars dirs sels
2019-12-20 07:58:09 +01:00
= Lazy.Text.fromStrict (fold name)
<> optempty (variableDefinitions formatter) vars
<> optempty (directives formatter) dirs
<> eitherFormat formatter " " mempty
<> selectionSet formatter sels
2020-05-22 10:11:48 +02:00
variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text
variableDefinitions formatter
= parensCommas formatter $ variableDefinition formatter
2020-05-22 10:11:48 +02:00
variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text
variableDefinition formatter (VariableDefinition var ty defaultValue')
= variable var
<> eitherFormat formatter ": " ":"
<> type' ty
2020-05-22 10:11:48 +02:00
<> maybe mempty (defaultValue formatter) defaultValue'
2020-05-22 10:11:48 +02:00
defaultValue :: Formatter -> ConstValue -> Lazy.Text
defaultValue formatter val
= eitherFormat formatter " = " "="
2020-05-22 10:11:48 +02:00
<> value formatter (fromConstValue val)
2020-05-22 10:11:48 +02:00
variable :: Name -> Lazy.Text
2019-12-20 07:58:09 +01:00
variable var = "$" <> Lazy.Text.fromStrict var
2020-05-22 10:11:48 +02:00
selectionSet :: Formatter -> SelectionSet -> Lazy.Text
2019-08-03 23:57:27 +02:00
selectionSet formatter
= bracesList formatter (selection formatter)
. NonEmpty.toList
2020-05-22 10:11:48 +02:00
selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text
2019-08-03 23:57:27 +02:00
selectionSetOpt formatter = bracesList formatter $ selection formatter
indentSymbol :: Lazy.Text
indentSymbol = " "
indent :: (Integral a) => a -> Lazy.Text
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
2020-05-22 10:11:48 +02:00
selection :: Formatter -> Selection -> Lazy.Text
selection formatter = Lazy.Text.append indent' . encodeSelection
2019-08-03 23:57:27 +02:00
where
2020-05-22 10:11:48 +02:00
encodeSelection (Field alias name args directives' selections) =
field incrementIndent alias name args directives' selections
2020-05-22 10:11:48 +02:00
encodeSelection (InlineFragment typeCondition directives' selections) =
inlineFragment incrementIndent typeCondition directives' selections
encodeSelection (FragmentSpread name directives' _) =
fragmentSpread incrementIndent name directives'
2019-08-03 23:57:27 +02:00
incrementIndent
| Pretty indentation <- formatter = Pretty $ indentation + 1
2019-08-03 23:57:27 +02:00
| otherwise = Minified
indent'
| Pretty indentation <- formatter = indent $ indentation + 1
| otherwise = ""
colon :: Formatter -> Lazy.Text
colon formatter = eitherFormat formatter ": " ":"
2020-05-22 10:11:48 +02:00
-- | Converts Field into a string
field :: Formatter ->
2020-05-22 10:11:48 +02:00
Maybe Name ->
Name ->
[Argument] ->
[Directive] ->
[Selection] ->
Lazy.Text
field formatter alias name args dirs set
= optempty prependAlias (fold alias)
2019-12-20 07:58:09 +01:00
<> Lazy.Text.fromStrict name
<> optempty (arguments formatter) args
<> optempty (directives formatter) dirs
<> optempty selectionSetOpt' set
where
prependAlias aliasName = Lazy.Text.fromStrict aliasName <> colon formatter
selectionSetOpt' = (eitherFormat formatter " " "" <>)
. selectionSetOpt formatter
2020-05-22 10:11:48 +02:00
arguments :: Formatter -> [Argument] -> Lazy.Text
arguments formatter = parensCommas formatter $ argument formatter
2020-05-22 10:11:48 +02:00
argument :: Formatter -> Argument -> Lazy.Text
argument formatter (Argument name value')
2019-12-20 07:58:09 +01:00
= Lazy.Text.fromStrict name
<> colon formatter
<> value formatter value'
-- * Fragments
2020-05-22 10:11:48 +02:00
fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text
fragmentSpread formatter name directives'
= "..." <> Lazy.Text.fromStrict name
<> optempty (directives formatter) directives'
inlineFragment ::
Formatter ->
2020-05-22 10:11:48 +02:00
Maybe TypeCondition ->
[Directive] ->
SelectionSet ->
Lazy.Text
inlineFragment formatter tc dirs sels = "... on "
2019-12-20 07:58:09 +01:00
<> Lazy.Text.fromStrict (fold tc)
<> directives formatter dirs
<> eitherFormat formatter " " mempty
<> selectionSet formatter sels
2020-05-22 10:11:48 +02:00
fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
2019-12-20 07:58:09 +01:00
= "fragment " <> Lazy.Text.fromStrict name
<> " on " <> Lazy.Text.fromStrict tc
<> optempty (directives formatter) dirs
<> eitherFormat formatter " " mempty
<> selectionSet formatter sels
2019-08-14 08:49:07 +02:00
-- * Miscellaneous
2020-05-22 10:11:48 +02:00
-- | Converts a 'Directive' into a string.
directive :: Formatter -> Directive -> Lazy.Text
directive formatter (Directive name args)
2019-12-20 07:58:09 +01:00
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
2020-05-22 10:11:48 +02:00
directives :: Formatter -> [Directive] -> Lazy.Text
2019-08-14 08:49:07 +02:00
directives Minified = spaces (directive Minified)
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
2020-05-22 10:11:48 +02:00
-- | Converts a 'Value' into a string.
value :: Formatter -> Value -> Lazy.Text
value _ (Variable x) = variable x
value _ (Int x) = Builder.toLazyText $ decimal x
value _ (Float x) = Builder.toLazyText $ realFloat x
value _ (Boolean x) = booleanValue x
value _ Null = "null"
value formatter (String string) = stringValue formatter string
value _ (Enum x) = Lazy.Text.fromStrict x
value formatter (List x) = listValue formatter x
value formatter (Object x) = objectValue formatter x
fromConstValue :: ConstValue -> Value
fromConstValue (ConstInt x) = Int x
fromConstValue (ConstFloat x) = Float x
fromConstValue (ConstBoolean x) = Boolean x
fromConstValue ConstNull = Null
fromConstValue (ConstString string) = String string
fromConstValue (ConstEnum x) = Enum x
fromConstValue (ConstList x) = List $ fromConstValue <$> x
fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x
where
fromConstObjectField (ObjectField key value') =
ObjectField key $ fromConstValue value'
2019-12-20 07:58:09 +01:00
booleanValue :: Bool -> Lazy.Text
booleanValue True = "true"
booleanValue False = "false"
quote :: Builder.Builder
quote = Builder.singleton '\"'
oneLine :: Text -> Builder
oneLine string = quote <> Text.foldr (mappend . escape) quote string
stringValue :: Formatter -> Text -> Lazy.Text
stringValue Minified string = Builder.toLazyText
$ quote <> Text.foldr (mappend . escape) quote string
stringValue (Pretty indentation) string =
if hasEscaped string
then stringValue Minified string
else Builder.toLazyText $ encoded lines'
where
isWhiteSpace char = char == ' ' || char == '\t'
isNewline char = char == '\n' || char == '\r'
hasEscaped = Text.any (not . isAllowed)
isAllowed char =
char == '\t' || isNewline char || (char >= '\x0020' && char /= '\x007F')
tripleQuote = Builder.fromText "\"\"\""
newline = Builder.singleton '\n'
strip = Text.dropWhile isWhiteSpace . Text.dropWhileEnd isWhiteSpace
lines' = map Builder.fromText $ Text.split isNewline (Text.replace "\r\n" "\n" $ strip string)
encoded [] = oneLine string
encoded [_] = oneLine string
encoded lines'' = tripleQuote <> newline
<> transformLines lines''
<> Builder.fromLazyText (indent indentation) <> tripleQuote
transformLines = foldr transformLine mempty
transformLine "" acc = newline <> acc
transformLine line' acc
= Builder.fromLazyText (indent (indentation + 1))
<> line' <> newline <> acc
escape :: Char -> Builder
escape char'
| char' == '\\' = Builder.fromString "\\\\"
| char' == '\"' = Builder.fromString "\\\""
| char' == '\b' = Builder.fromString "\\b"
| char' == '\f' = Builder.fromString "\\f"
| char' == '\n' = Builder.fromString "\\n"
| char' == '\r' = Builder.fromString "\\r"
| char' == '\t' = Builder.fromString "\\t"
| char' < '\x0010' = unicode "\\u000" char'
| char' < '\x0020' = unicode "\\u00" char'
| otherwise = Builder.singleton char'
where
unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
2020-05-22 10:11:48 +02:00
listValue :: Formatter -> [Value] -> Lazy.Text
listValue formatter = bracketsCommas formatter $ value formatter
2020-05-22 10:11:48 +02:00
objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text
2019-08-03 23:57:27 +02:00
objectValue formatter = intercalate $ objectField formatter
where
intercalate f
= braces
2019-12-20 07:58:09 +01:00
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
2019-08-03 23:57:27 +02:00
. fmap f
2020-05-22 10:11:48 +02:00
objectField :: Formatter -> ObjectField Value -> Lazy.Text
objectField formatter (ObjectField name value') =
Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
2020-05-22 10:11:48 +02:00
-- | Converts a 'Type' a type into a string.
type' :: Type -> Lazy.Text
type' (TypeNamed x) = Lazy.Text.fromStrict x
type' (TypeList x) = listType x
type' (TypeNonNull x) = nonNullType x
2020-05-22 10:11:48 +02:00
listType :: Type -> Lazy.Text
listType x = brackets (type' x)
2020-05-22 10:11:48 +02:00
nonNullType :: NonNullType -> Lazy.Text
nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
nonNullType (NonNullTypeList x) = listType x <> "!"
-- * Internal
2019-12-20 07:58:09 +01:00
between :: Char -> Char -> Lazy.Text -> Lazy.Text
between open close = Lazy.Text.cons open . (`Lazy.Text.snoc` close)
2019-12-20 07:58:09 +01:00
parens :: Lazy.Text -> Lazy.Text
parens = between '(' ')'
2019-12-20 07:58:09 +01:00
brackets :: Lazy.Text -> Lazy.Text
brackets = between '[' ']'
2019-12-20 07:58:09 +01:00
braces :: Lazy.Text -> Lazy.Text
braces = between '{' '}'
2019-12-20 07:58:09 +01:00
spaces :: forall a. (a -> Lazy.Text) -> [a] -> Lazy.Text
spaces f = Lazy.Text.intercalate "\SP" . fmap f
2019-12-20 07:58:09 +01:00
parensCommas :: forall a. Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
parensCommas formatter f
= parens
2019-12-20 07:58:09 +01:00
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
. fmap f
2019-12-20 07:58:09 +01:00
bracketsCommas :: Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
bracketsCommas formatter f
= brackets
2019-12-20 07:58:09 +01:00
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
. fmap f
2019-12-20 07:58:09 +01:00
bracesList :: forall a. Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
2019-08-03 23:57:27 +02:00
bracesList (Pretty intendation) f xs
2019-12-20 07:58:09 +01:00
= Lazy.Text.snoc (Lazy.Text.intercalate "\n" content) '\n'
<> (Lazy.Text.snoc $ Lazy.Text.replicate (fromIntegral intendation) " ") '}'
2019-08-03 23:57:27 +02:00
where
content = "{" : fmap f xs
2019-12-20 07:58:09 +01:00
bracesList Minified f xs = braces $ Lazy.Text.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
2019-08-03 23:57:27 +02:00
eitherFormat (Pretty _) x _ = x
eitherFormat Minified _ x = x