graphql/src/Language/GraphQL/Encoder.hs

178 lines
5.0 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
-- | This module defines a printer for the @GraphQL@ language.
module Language.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 Language.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