180 lines
5.0 KiB
Haskell
180 lines
5.0 KiB
Haskell
{-# 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
|