444 lines
17 KiB
Haskell
Raw Normal View History

{-# LANGUAGE ExplicitForAll #-}
2020-07-11 06:34:10 +02:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
2020-10-04 18:51:21 +02:00
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Safe #-}
-- | 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
2022-10-02 11:38:53 +02:00
, operationType
2019-08-03 23:57:27 +02:00
, pretty
, type'
2022-12-25 16:38:00 +01:00
, typeSystemDefinition
, value
2019-07-14 05:58:05 +02:00
) where
2023-01-03 13:10:33 +01:00
import Data.Foldable (fold, Foldable (..))
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
import Data.Text.Lazy.Builder.Int (decimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
2020-09-30 05:14:52 +02:00
import qualified Language.GraphQL.AST.Document 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
2022-10-02 11:38:53 +02:00
| Pretty !Word
2019-08-03 23:57:27 +02:00
-- | 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.
2020-09-30 05:14:52 +02:00
document :: Formatter -> Full.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
2020-09-30 05:14:52 +02:00
executableDefinition (Full.ExecutableDefinition executableDefinition') acc =
definition formatter executableDefinition' : acc
2022-12-25 16:38:00 +01:00
executableDefinition (Full.TypeSystemDefinition typeSystemDefinition' _location) acc =
typeSystemDefinition formatter typeSystemDefinition' : acc
executableDefinition _ acc = acc -- TODO: TypeSystemExtension missing.
withLineBreak :: Formatter -> Lazy.Text.Text -> Lazy.Text.Text
withLineBreak formatter encodeDefinition
| Pretty _ <- formatter = Lazy.Text.snoc encodeDefinition '\n'
| Minified <- formatter = encodeDefinition
-- | Converts a t'Full.TypeSystemDefinition' into a string.
typeSystemDefinition :: Formatter -> Full.TypeSystemDefinition -> Lazy.Text
typeSystemDefinition formatter = \case
Full.SchemaDefinition operationDirectives operationTypeDefinitions' ->
withLineBreak formatter
$ optempty (directives formatter) operationDirectives
<> "schema "
<> bracesList formatter operationTypeDefinition (NonEmpty.toList operationTypeDefinitions')
Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
_ -> "" -- TODO: DerictiveDefinition missing.
2022-12-25 16:38:00 +01:00
where
operationTypeDefinition (Full.OperationTypeDefinition operationType' namedType')
= indentLine (incrementIndent formatter)
<> operationType formatter operationType'
<> colon formatter
<> Lazy.Text.fromStrict namedType'
2023-01-02 10:30:37 +01:00
fieldDefinition :: Formatter -> Full.FieldDefinition -> Lazy.Text.Text
fieldDefinition formatter fieldDefinition' =
let Full.FieldDefinition description' name' arguments' type'' directives' = fieldDefinition'
in optempty (description formatter) description'
<> indentLine formatter
<> Lazy.Text.fromStrict name'
<> argumentsDefinition formatter arguments'
<> colon formatter
<> type' type''
<> optempty (directives formatter) directives'
argumentsDefinition :: Formatter -> Full.ArgumentsDefinition -> Lazy.Text.Text
argumentsDefinition formatter (Full.ArgumentsDefinition arguments') =
parensCommas formatter (argumentDefinition formatter) arguments'
argumentDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text
argumentDefinition formatter definition' =
let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'
in optempty (description formatter) description'
<> Lazy.Text.fromStrict name'
<> colon formatter
<> type' type''
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
<> directives formatter directives'
2023-01-03 13:10:33 +01:00
typeDefinition :: Formatter -> Full.TypeDefinition -> Lazy.Text
typeDefinition formatter = \case
Full.ScalarTypeDefinition description' name' directives'
-> optempty (description formatter) description'
<> "scalar "
<> Lazy.Text.fromStrict name'
<> optempty (directives formatter) directives'
2023-01-03 13:10:33 +01:00
Full.ObjectTypeDefinition description' name' ifaces' directives' fields'
-> optempty (description formatter) description'
<> "type "
<> Lazy.Text.fromStrict name'
<> optempty (" " <>) (implementsInterfaces ifaces')
<> optempty (directives formatter) directives'
<> eitherFormat formatter " " ""
<> bracesList formatter (fieldDefinition nextFormatter) fields'
2023-01-02 10:30:37 +01:00
Full.InterfaceTypeDefinition description' name' directives' fields'
-> optempty (description formatter) description'
<> "interface "
<> Lazy.Text.fromStrict name'
<> optempty (directives formatter) directives'
<> eitherFormat formatter " " ""
<> bracesList formatter (fieldDefinition nextFormatter) fields'
_typeDefinition' -> "" -- TODO: Types missing.
2023-01-02 10:30:37 +01:00
where
nextFormatter = incrementIndent formatter
2023-01-03 13:10:33 +01:00
implementsInterfaces :: Foldable t => Full.ImplementsInterfaces t -> Lazy.Text
implementsInterfaces (Full.ImplementsInterfaces interfaces)
| null interfaces = mempty
| otherwise = Lazy.Text.fromStrict
$ Text.append "implements"
$ Text.intercalate " & "
$ toList interfaces
description :: Formatter -> Full.Description -> Lazy.Text.Text
description _formatter (Full.Description Nothing) = ""
description formatter (Full.Description (Just description')) =
stringValue formatter description'
-- | Converts a t'Full.ExecutableDefinition' into a string.
2020-09-30 05:14:52 +02:00
definition :: Formatter -> Full.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-09-30 05:14:52 +02:00
encodeDefinition (Full.DefinitionOperation operation)
= operationDefinition formatter operation
2020-09-30 05:14:52 +02:00
encodeDefinition (Full.DefinitionFragment fragment)
= fragmentDefinition formatter fragment
-- | Converts a 'Full.OperationDefinition into a string.
2020-09-30 05:14:52 +02:00
operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
2020-07-11 06:34:10 +02:00
operationDefinition formatter = \case
2020-09-30 05:14:52 +02:00
Full.SelectionSet sels _ -> selectionSet formatter sels
Full.OperationDefinition Full.Query name vars dirs sels _ ->
"query " <> root name vars dirs sels
Full.OperationDefinition Full.Mutation name vars dirs sels _ ->
"mutation " <> root name vars dirs sels
Full.OperationDefinition Full.Subscription name vars dirs sels _ ->
"subscription " <> root name vars dirs sels
where
-- | Converts a Query or Mutation into a string.
root :: Maybe Full.Name ->
[Full.VariableDefinition] ->
[Full.Directive] ->
Full.SelectionSet ->
Lazy.Text
root name vars dirs sels
= Lazy.Text.fromStrict (fold name)
<> optempty (variableDefinitions formatter) vars
<> optempty (directives formatter) dirs
<> eitherFormat formatter " " mempty
<> selectionSet formatter sels
variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
variableDefinitions formatter
= parensCommas formatter $ variableDefinition formatter
2020-09-30 05:14:52 +02:00
variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
variableDefinition formatter variableDefinition' =
let Full.VariableDefinition variableName variableType defaultValue' _ =
variableDefinition'
in variable variableName
2022-12-25 16:38:00 +01:00
<> colon formatter
2020-09-30 05:14:52 +02:00
<> type' variableType
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
2020-09-30 05:14:52 +02:00
defaultValue :: Formatter -> Full.ConstValue -> Lazy.Text
defaultValue formatter val
= eitherFormat formatter " = " "="
2020-05-22 10:11:48 +02:00
<> value formatter (fromConstValue val)
2020-09-30 05:14:52 +02:00
variable :: Full.Name -> Lazy.Text
2019-12-20 07:58:09 +01:00
variable var = "$" <> Lazy.Text.fromStrict var
2020-09-30 05:14:52 +02:00
selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
2019-08-03 23:57:27 +02:00
selectionSet formatter
= bracesList formatter (selection formatter)
. NonEmpty.toList
2020-09-30 05:14:52 +02:00
selectionSetOpt :: Formatter -> Full.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-09-30 05:14:52 +02:00
selection :: Formatter -> Full.Selection -> Lazy.Text
2022-12-25 16:38:00 +01:00
selection formatter = Lazy.Text.append (indentLine formatter')
. encodeSelection
2019-08-03 23:57:27 +02:00
where
2020-09-30 05:14:52 +02:00
encodeSelection (Full.FieldSelection fieldSelection) =
2022-12-25 16:38:00 +01:00
field formatter' fieldSelection
2020-09-30 05:14:52 +02:00
encodeSelection (Full.InlineFragmentSelection fragmentSelection) =
2022-12-25 16:38:00 +01:00
inlineFragment formatter' fragmentSelection
2020-09-30 05:14:52 +02:00
encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =
2022-12-25 16:38:00 +01:00
fragmentSpread formatter' fragmentSelection
formatter' = incrementIndent formatter
indentLine :: Formatter -> Lazy.Text
indentLine formatter
| Pretty indentation <- formatter = indent indentation
| otherwise = ""
incrementIndent :: Formatter -> Formatter
incrementIndent formatter
| Pretty indentation <- formatter = Pretty $ indentation + 1
| otherwise = Minified
colon :: Formatter -> Lazy.Text
colon formatter = eitherFormat formatter ": " ":"
2020-09-09 17:04:31 +02:00
-- | Converts Field into a string.
2020-09-30 05:14:52 +02:00
field :: Formatter -> Full.Field -> Lazy.Text
field formatter (Full.Field 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-09-30 05:14:52 +02:00
arguments :: Formatter -> [Full.Argument] -> Lazy.Text
arguments formatter = parensCommas formatter $ argument formatter
2020-09-30 05:14:52 +02:00
argument :: Formatter -> Full.Argument -> Lazy.Text
argument formatter (Full.Argument name value' _)
2019-12-20 07:58:09 +01:00
= Lazy.Text.fromStrict name
<> colon formatter
2020-10-04 18:51:21 +02:00
<> value formatter (Full.node value')
-- * Fragments
2020-09-30 05:14:52 +02:00
fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text
fragmentSpread formatter (Full.FragmentSpread name directives' _)
= "..." <> Lazy.Text.fromStrict name
<> optempty (directives formatter) directives'
2020-09-30 05:14:52 +02:00
inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
inlineFragment formatter (Full.InlineFragment typeCondition directives' selections _)
2020-09-07 22:01:49 +02:00
= "... on "
<> Lazy.Text.fromStrict (fold typeCondition)
<> directives formatter directives'
<> eitherFormat formatter " " mempty
2020-09-07 22:01:49 +02:00
<> selectionSet formatter selections
2020-09-30 05:14:52 +02:00
fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
fragmentDefinition formatter (Full.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
-- | Converts a 'Full.Directive' into a string.
2020-09-30 05:14:52 +02:00
directive :: Formatter -> Full.Directive -> Lazy.Text
directive formatter (Full.Directive name args _)
2019-12-20 07:58:09 +01:00
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
2020-09-30 05:14:52 +02:00
directives :: Formatter -> [Full.Directive] -> Lazy.Text
2023-01-02 10:30:37 +01:00
directives Minified values = spaces (directive Minified) values
directives formatter values
| null values = ""
| otherwise = Lazy.Text.cons ' ' $ spaces (directive formatter) values
-- | Converts a 'Full.Value' into a string.
2020-09-30 05:14:52 +02:00
value :: Formatter -> Full.Value -> Lazy.Text
value _ (Full.Variable x) = variable x
value _ (Full.Int x) = Builder.toLazyText $ decimal x
value _ (Full.Float x) = Builder.toLazyText $ realFloat x
value _ (Full.Boolean x) = booleanValue x
value _ Full.Null = "null"
value formatter (Full.String string) = stringValue formatter string
value _ (Full.Enum x) = Lazy.Text.fromStrict x
value formatter (Full.List x) = listValue formatter x
value formatter (Full.Object x) = objectValue formatter x
fromConstValue :: Full.ConstValue -> Full.Value
fromConstValue (Full.ConstInt x) = Full.Int x
fromConstValue (Full.ConstFloat x) = Full.Float x
fromConstValue (Full.ConstBoolean x) = Full.Boolean x
fromConstValue Full.ConstNull = Full.Null
fromConstValue (Full.ConstString string) = Full.String string
fromConstValue (Full.ConstEnum x) = Full.Enum x
fromConstValue (Full.ConstList x) = Full.List $ fmap fromConstValue <$> x
2020-09-30 05:14:52 +02:00
fromConstValue (Full.ConstObject x) = Full.Object $ fromConstObjectField <$> x
2020-05-22 10:11:48 +02:00
where
2020-10-04 18:51:21 +02:00
fromConstObjectField Full.ObjectField{value = value', ..} =
Full.ObjectField name (fromConstValue <$> value') location
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 merge quote string
where
merge = mappend . Builder.fromString . Full.escape
stringValue :: Formatter -> Text -> Lazy.Text
stringValue Minified string = Builder.toLazyText $ oneLine 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
listValue :: Formatter -> [Full.Node Full.Value] -> Lazy.Text
listValue formatter = bracketsCommas formatter $ value formatter . Full.node
2020-09-30 05:14:52 +02:00
objectValue :: Formatter -> [Full.ObjectField Full.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-09-30 05:14:52 +02:00
objectField :: Formatter -> Full.ObjectField Full.Value -> Lazy.Text
2020-10-04 18:51:21 +02:00
objectField formatter (Full.ObjectField name (Full.Node value' _) _) =
Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
-- | Converts a 'Full.Type' a type into a string.
2020-09-30 05:14:52 +02:00
type' :: Full.Type -> Lazy.Text
type' (Full.TypeNamed x) = Lazy.Text.fromStrict x
type' (Full.TypeList x) = listType x
type' (Full.TypeNonNull x) = nonNullType x
2020-09-30 05:14:52 +02:00
listType :: Full.Type -> Lazy.Text
listType x = brackets (type' x)
2020-09-30 05:14:52 +02:00
nonNullType :: Full.NonNullType -> Lazy.Text
nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
nonNullType (Full.NonNullTypeList x) = listType x <> "!"
2022-10-02 11:38:53 +02:00
-- | Produces lowercase operation type: query, mutation or subscription.
operationType :: Formatter -> Full.OperationType -> Lazy.Text
operationType _formatter Full.Query = "query"
operationType _formatter Full.Mutation = "mutation"
operationType _formatter Full.Subscription = "subscription"
-- * 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