aihc-parser-6.0.0.0: src/Aihc/Parser/Pretty.hs
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- |
-- Module : Aihc.Parser.Pretty
-- Description : Pretty-printing of AST to Haskell source code
--
-- This module provides pretty-printing of parsed AST back to valid Haskell
-- source code. It is used for round-trip testing and code generation.
--
-- The 'Pretty' instances from 'Prettyprinter' are provided for the main
-- AST types, allowing direct use of 'pretty' from @Prettyprinter@.
--
-- __Parenthesization__ is handled by the 'Aihc.Parser.Parens' module, which
-- inserts 'EParen', 'PParen', 'TParen', and 'CmdPar' nodes at all required
-- positions. The Pretty instances call the paren-insertion pass before
-- formatting, so the formatting code here does not need to worry about
-- operator precedence or context-sensitive parenthesization.
--
-- Import this module to bring the 'Pretty' instances into scope. The exported
-- helpers render AST nodes without first inserting additional parentheses,
-- which is useful for tests that need to inspect parenthesization directly.
--
-- __Provided instances:__ 'Pretty' for 'Module', 'Expr', 'Pattern', 'Type'.
module Aihc.Parser.Pretty
( prettyExpr,
prettyPattern,
prettyType,
)
where
import Aihc.Parser.Parens (addDeclParens, addExprParens, addModuleParens, addPatternParens, addTypeParens)
import Aihc.Parser.Syntax
import Data.Maybe (catMaybes, isJust)
import Data.Text (Text)
import Data.Text qualified as T
import Prettyprinter
( Doc,
Pretty (pretty),
align,
braces,
brackets,
column,
comma,
concatWith,
flatAlt,
group,
hang,
hardline,
hsep,
line,
line',
nest,
nesting,
parens,
punctuate,
semi,
softline,
vsep,
(<+>),
)
-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Aihc.Parser.Shorthand (Shorthand(..))
-- >>> import Aihc.Parser.Syntax
-- >>> import Prettyprinter (defaultLayoutOptions, layoutPretty)
-- >>> import Prettyprinter.Render.String (renderString)
-- >>> let renderDoc = renderString . layoutPretty defaultLayoutOptions
-- __Line breaks.__ A construct that can fit on one line uses 'group' with
-- soft breaks ('line', 'line'', or 'spacedLine'). If the construct does not
-- fit, each soft break becomes a line break. Layout blocks ('do', 'case',
-- 'let', 'where', guards, and declaration lists) use 'hardline' and
-- 'hardVsep'. A 'group' that contains a hard line break does not become flat.
-- Thus a layout block always stops the enclosing groups from becoming flat,
-- and text that follows a block cannot move into the block.
-- | Put each document on a new line. Unlike 'vsep', the breaks stay line
-- breaks in a 'group'. Use this for layout blocks.
hardVsep :: [Doc ann] -> Doc ann
hardVsep = concatWith (\x y -> x <> hardline <> y)
-- | A soft break that keeps one space before the next token when it breaks.
-- In a flat 'group', it is one space.
spacedLine :: Doc ann
spacedLine = flatAlt (hardline <> " ") " "
-- | An empty document that stops each enclosing 'group' from becoming flat.
-- Use it at the end of a layout block that has no closing token, for example
-- a multi-way @if@. Text on the same line after such a block goes into the
-- block, so the enclosing construct must break the line.
noFlat :: Doc ann
noFlat = flatAlt mempty hardline
-- | Wrap a document in braces with interior spaces: @{ content }@.
-- Unlike 'braces' which produces @{content}@, this version avoids the
-- @{-@ block-comment ambiguity that occurs when the content starts with a
-- minus sign (e.g. a negated literal pattern in a let binding).
spacedBraces :: Doc ann -> Doc ann
spacedBraces d = "{" <+> d <+> "}"
prettyRawText :: Text -> Doc ann
prettyRawText raw
| T.isInfixOf "\n" raw = nesting $ \level -> nest (negate level) (prettyHardLines raw)
| otherwise = pretty raw
-- | Print text that can contain newlines. Each newline stays a line break in
-- a 'group'. The 'Pretty' instance for 'Text' uses 'line', which a flat
-- 'group' changes to a space.
prettyHardLines :: Text -> Doc ann
prettyHardLines = hardVsep . map pretty . T.splitOn "\n"
prettySpliceBody :: Expr -> Doc ann
prettySpliceBody = prettyExpr
-- | Pretty instance for Module - renders to valid Haskell source code.
instance Pretty Module where
pretty = prettyModuleDoc . addModuleParens
-- | Pretty instance for Expr - renders to valid Haskell source code.
instance Pretty Expr where
pretty = prettyExpr . addExprParens
-- | Pretty instance for Pattern - renders to valid Haskell source code.
instance Pretty Pattern where
pretty = prettyPattern . addPatternParens
-- | Pretty instance for Decl - renders to valid Haskell source code.
instance Pretty Decl where
pretty decl = hardVsep (prettyDeclLines (addDeclParens decl))
-- | Pretty instance for Type - renders to valid Haskell source code.
instance Pretty Type where
pretty = prettyType . addTypeParens
instance Pretty Name where
pretty = pretty . renderName
instance Pretty UnqualifiedName where
pretty = pretty . renderUnqualifiedName
prettyModuleDoc :: Module -> Doc ann
prettyModuleDoc modu =
hardVsep (pragmaLines <> headerLines <> importLines <> declLines)
where
pragmaLines =
map
(\ext -> "{-# LANGUAGE" <+> pretty (extensionSettingName ext) <+> "#-}")
(moduleLanguagePragmas modu)
headerLines =
case moduleName modu of
Just name ->
[ hsep
( ["module", pretty name]
<> maybe [] (\p -> [prettyPragma p]) (moduleWarningPragma modu)
<> maybe [] (\specs -> [prettyExportSpecList specs]) (moduleExports modu)
<> ["where"]
)
]
Nothing -> []
importLines = map prettyImportDecl (moduleImports modu)
declLines = concatMap prettyDeclLines (moduleDecls modu)
prettyExportSpecList :: [ExportSpec] -> Doc ann
prettyExportSpecList specs =
parens (prettyCommaFill (map prettyExportSpec specs))
prettyExportSpec :: ExportSpec -> Doc ann
prettyExportSpec spec =
case spec of
ExportAnn _ sub -> prettyExportSpec sub
ExportModule mWarning modName -> prettyExportWarning mWarning ("module" <+> pretty modName)
ExportVar mWarning namespace name ->
prettyExportWarning mWarning (prettyNamespacePrefix namespace <> prettyName name)
ExportAbs mWarning namespace name ->
prettyExportWarning mWarning (prettyNamespacePrefix namespace <> prettyName name)
ExportAll mWarning namespace name ->
prettyExportWarning mWarning (prettyNamespacePrefix namespace <> prettyName name <> "(..)")
ExportWith mWarning namespace name members ->
prettyExportWarning
mWarning
(prettyNamespacePrefix namespace <> prettyName name <> parens (hsep (punctuate comma (map prettyExportMember members))))
ExportWithAll mWarning namespace name wildcardIndex members ->
prettyExportWarning
mWarning
(prettyNamespacePrefix namespace <> prettyName name <> parens (hsep (punctuate comma (insertWildcard wildcardIndex (map prettyExportMember members)))))
prettyExportWarning :: Maybe Pragma -> Doc ann -> Doc ann
prettyExportWarning mWarning doc =
case mWarning of
Nothing -> doc
Just p -> hsep [prettyPragma p, doc]
prettyImportDecl :: ImportDecl -> Doc ann
prettyImportDecl decl =
let renderPostQualified =
importDeclQualifiedPost decl
&& importDeclQualified decl
in hsep
( ["import"]
<> ["safe" | importDeclSafe decl]
<> maybe [] (\p -> [prettyPragma p]) (importDeclSourcePragma decl)
<> ["qualified" | importDeclQualified decl && not renderPostQualified]
<> maybe [] (\level -> [prettyImportLevel level]) (importDeclLevel decl)
<> maybe [] (\pkg -> [prettyQuotedText pkg]) (importDeclPackage decl)
<> [pretty (importDeclModule decl)]
<> ["qualified" | importDeclQualified decl && renderPostQualified]
<> maybe [] (\alias -> ["as", pretty alias]) (importDeclAs decl)
<> maybe [] (\spec -> [prettyImportSpec spec]) (importDeclSpec decl)
)
prettyImportLevel :: ImportLevel -> Doc ann
prettyImportLevel level =
case level of
ImportLevelQuote -> "quote"
ImportLevelSplice -> "splice"
-- | Pretty-print a top-level declaration splice.
-- The expression is printed as-is; explicit TH splices appear as @$expr@ or
-- @$(expr)@ through the normal 'ETHSplice' pretty-printer.
-- Nested continuation lines keep infix operators from starting in top-level
-- layout column one, where GHC can read them as a new declaration.
prettyDeclSpliceExpr :: Expr -> Doc ann
prettyDeclSpliceExpr = nest 2 . prettyExpr
prettyQuotedText :: Text -> Doc ann
prettyQuotedText txt = "\"" <> pretty txt <> "\""
prettyImportSpec :: ImportSpec -> Doc ann
prettyImportSpec spec =
hsep
( ["hiding" | importSpecHiding spec]
<> [parens (prettyCommaFill (map prettyImportItem (importSpecItems spec)))]
)
prettyImportItem :: ImportItem -> Doc ann
prettyImportItem item =
case item of
ImportAnn _ sub -> prettyImportItem sub
ImportItemVar namespace name -> prettyNamespacePrefix namespace <> prettyBinderUName name
ImportItemAbs namespace name -> prettyNamespacePrefix namespace <> prettyConstructorUName name
ImportItemAll namespace name -> prettyNamespacePrefix namespace <> prettyConstructorUName name <> "(..)"
ImportItemWith namespace name members ->
prettyNamespacePrefix namespace <> prettyConstructorUName name <> parens (hsep (punctuate comma (map prettyExportMember members)))
ImportItemAllWith namespace name wildcardIndex members ->
prettyNamespacePrefix namespace <> prettyConstructorUName name <> parens (hsep (punctuate comma (insertWildcard wildcardIndex (map prettyExportMember members))))
insertWildcard :: Int -> [Doc ann] -> [Doc ann]
insertWildcard wildcardIndex members =
let (before, after) = splitAt wildcardIndex members
in before <> [".."] <> after
prettyExportMember :: IEBundledMember -> Doc ann
prettyExportMember (IEBundledMember namespace name) =
prettyMemberNamespacePrefix namespace <> prettyBundledMemberName name
prettyNamespacePrefix :: Maybe IEEntityNamespace -> Doc ann
prettyNamespacePrefix namespace =
case namespace of
Just ns -> prettyNamespace ns <> " "
Nothing -> mempty
prettyNamespace :: IEEntityNamespace -> Doc ann
prettyNamespace namespace =
case namespace of
IEEntityNamespaceType -> "type"
IEEntityNamespacePattern -> "pattern"
IEEntityNamespaceData -> "data"
prettyMemberNamespacePrefix :: Maybe IEBundledNamespace -> Doc ann
prettyMemberNamespacePrefix namespace =
case namespace of
Just ns -> prettyMemberNamespace ns <> " "
Nothing -> mempty
prettyMemberNamespace :: IEBundledNamespace -> Doc ann
prettyMemberNamespace namespace =
case namespace of
IEBundledNamespaceType -> "type"
IEBundledNamespaceData -> "data"
prettyDeclLines :: Decl -> [Doc ann]
prettyDeclLines decl =
case decl of
DeclAnn _ sub -> prettyDeclLines sub
DeclValue valueDecl -> prettyValueDeclLines valueDecl
DeclImplicitParam name expr whereDecls ->
[pretty name <+> "=" <+> prettyExpr expr <> prettyIndentedWhereClause whereDecls]
DeclTypeSig names ty -> [hsep [hsep (punctuate comma (map prettyBinderName names)), "::", prettyType ty]]
DeclPatSyn patSynDecl -> [prettyPatSynDecl patSynDecl]
DeclPatSynSig names ty -> [hsep ["pattern", hsep (punctuate comma (map prettyConstructorUName names)), "::", prettyType ty]]
DeclStandaloneKindSig name kind -> [hsep ["type", prettyConstructorUName name, "::", prettyType kind]]
DeclFixity assoc mNamespace prec ops ->
[ hsep
( [prettyFixityAssoc assoc]
<> maybe [] (pure . pretty . show) prec
<> maybe [] (pure . prettyNamespace) mNamespace
<> punctuate comma (map prettyInfixOp ops)
)
]
DeclRoleAnnotation ann -> [prettyRoleAnnotation ann]
DeclTypeSyn synDecl ->
[hsep (["type"] <> prettyDeclBinderHead [] (typeSynHead synDecl) <> ["=", prettyType (typeSynBody synDecl)])]
DeclData dataDecl -> [prettyDataDecl dataDecl]
DeclTypeData dataDecl -> [prettyTypeDataDecl dataDecl]
DeclNewtype newtypeDecl -> [prettyNewtypeDecl newtypeDecl]
DeclClass classDecl -> [prettyClassDecl classDecl]
DeclInstance instanceDecl -> [prettyInstanceDecl instanceDecl]
DeclStandaloneDeriving derivingDecl -> [prettyStandaloneDeriving derivingDecl]
DeclDefault tys -> ["default" <+> parens (hsep (punctuate comma (map prettyType tys)))]
DeclForeign foreignDecl -> [prettyForeignDecl foreignDecl]
DeclSplice body -> [prettyDeclSpliceExpr body]
DeclTypeFamilyDecl tf -> [prettyTypeFamilyDecl tf]
DeclDataFamilyDecl df -> [prettyDataFamilyDecl df]
DeclTypeFamilyInst tfi -> [prettyTopTypeFamilyInst tfi]
DeclDataFamilyInst dfi -> [prettyTopDataFamilyInst dfi]
DeclPragma pragma -> [prettyPragma pragma]
DeclRules rules -> prettyRulesLines rules
-- | A @RULES@ pragma, one rule per line. Every rule after the first starts
-- with an explicit semicolon in the first column, so the rules are separated
-- whether or not an enclosing layout context supplies semicolons, and the
-- closing @#-}@ stands in the first column so that it ends any layout
-- context a rule opened.
prettyRulesLines :: [RuleDecl] -> [Doc ann]
prettyRulesLines rules =
["{-# RULES"]
<> zipWith prettyRuleLine [0 :: Int ..] rules
<> ["#-}"]
where
prettyRuleLine index rule
| index == 0 = nest 2 (prettyRuleDecl rule)
| otherwise = nest 2 (";" <+> prettyRuleDecl rule)
prettyRuleDecl :: RuleDecl -> Doc ann
prettyRuleDecl rule =
hsep
( [pretty (show (ruleName rule))]
<> maybe [] (pure . prettyRuleActivation) (ruleActivation rule)
<> foralls
<> [prettyExpr (ruleLhs rule), "=", prettyExpr (ruleRhs rule)]
)
where
foralls =
case (ruleTypeBinders rule, ruleBinders rule) of
([], []) -> []
([], binders) -> [ruleForall (map prettyRuleBinder binders)]
(typeBinders, binders) -> [ruleForall (map prettyTyVarBinder typeBinders), ruleForall (map prettyRuleBinder binders)]
ruleForall binders = hsep ("forall" : binders) <> "."
prettyRuleActivation :: RuleActivation -> Doc ann
prettyRuleActivation activation =
case activation of
RuleActiveAfter phase -> brackets (pretty phase)
RuleActiveBefore phase -> brackets ("~" <> pretty phase)
RuleNeverActive -> brackets "~"
prettyRuleBinder :: RuleBinder -> Doc ann
prettyRuleBinder binder =
case ruleBinderType binder of
Nothing -> prettyBinderName (ruleBinderName binder)
Just ty -> parens (prettyBinderName (ruleBinderName binder) <+> "::" <+> prettyType ty)
prettyRoleAnnotation :: RoleAnnotation -> Doc ann
prettyRoleAnnotation ann =
hsep
( [ "type",
"role",
prettyConstructorUName (roleAnnotationName ann)
]
<> map prettyRole (roleAnnotationRoles ann)
)
prettyRole :: Role -> Doc ann
prettyRole role =
case role of
RoleNominal -> "nominal"
RoleRepresentational -> "representational"
RolePhantom -> "phantom"
RoleInfer -> "_"
prettyValueDeclLines :: ValueDecl -> [Doc ann]
prettyValueDeclLines valueDecl =
case valueDecl of
PatternBind multTag pat rhs -> [prettyMultiplicityTag multTag <> prettyPattern pat <+> prettyRhs rhs]
FunctionBind name matches ->
concatMap (prettyFunctionMatchLines name) matches
-- | Pretty-print a value declaration on a single line.
prettyValueDeclSingleLine :: ValueDecl -> Doc ann
prettyValueDeclSingleLine valueDecl =
case valueDecl of
PatternBind multTag pat rhs -> prettyMultiplicityTag multTag <> prettyPattern pat <+> prettyRhs rhs
FunctionBind name matches ->
hsep (punctuate semi (map (prettyFunctionMatch name) matches))
prettyMultiplicityTag :: MultiplicityTag -> Doc ann
prettyMultiplicityTag NoMultiplicityTag = mempty
prettyMultiplicityTag LinearMultiplicityTag = "%1" <+> mempty
prettyMultiplicityTag (ExplicitMultiplicityTag ty) = "%" <> prettyType ty <+> mempty
-- | Pretty-print a pattern synonym declaration.
prettyPatSynDecl :: PatSynDecl -> Doc ann
prettyPatSynDecl ps =
hsep
( ["pattern"]
<> prettyPatSynLhs (patSynDeclName ps) (patSynDeclArgs ps)
<> [dirArrow (patSynDeclDir ps)]
<> [prettyPattern (patSynDeclPat ps)]
<> prettyPatSynWhere (patSynDeclName ps) (patSynDeclDir ps)
)
where
dirArrow PatSynBidirectional = "="
dirArrow PatSynUnidirectional = "<-"
dirArrow (PatSynExplicitBidirectional _) = "<-"
prettyPatSynLhs :: UnqualifiedName -> PatSynArgs -> [Doc ann]
prettyPatSynLhs name args =
case args of
PatSynPrefixArgs vars ->
prettyConstructorUName name : map pretty vars
PatSynInfixArgs lhs rhs ->
[pretty lhs, prettyInfixOp name, pretty rhs]
PatSynRecordArgs fields ->
[prettyConstructorUName name <+> braces (hsep (punctuate comma (map pretty fields)))]
prettyPatSynWhere :: UnqualifiedName -> PatSynDir -> [Doc ann]
prettyPatSynWhere _ PatSynBidirectional = []
prettyPatSynWhere _ PatSynUnidirectional = []
prettyPatSynWhere _ (PatSynExplicitBidirectional []) = ["where", spacedBraces mempty]
prettyPatSynWhere name (PatSynExplicitBidirectional matches) =
["where" <> nest 2 (hardline <> hardVsep (map (prettyFunctionMatch name) matches))]
prettyFunctionMatchLines :: UnqualifiedName -> Match -> [Doc ann]
prettyFunctionMatchLines name match =
case matchRhs match of
UnguardedRhs {} -> [prettyFunctionMatch name match]
GuardedRhss _ grhss mWhereDecls ->
[ prettyFunctionHead name (matchHeadForm match) (matchPats match)
<> nest
2
( hardline
<> hardVsep
( map prettyGuardedRhsBlock grhss
<> [prettyWhereClauseBare mWhereDecls | isJust mWhereDecls]
)
)
]
prettyFunctionMatch :: UnqualifiedName -> Match -> Doc ann
prettyFunctionMatch name match =
prettyFunctionHead name (matchHeadForm match) (matchPats match) <+> prettyRhs (matchRhs match)
prettyFunctionHead :: UnqualifiedName -> MatchHeadForm -> [Pattern] -> Doc ann
prettyFunctionHead name headForm pats =
case headForm of
MatchHeadPrefix ->
hsep (prettyBinderUName name : map prettyPattern pats)
MatchHeadInfix ->
case pats of
lhs : rhsPat : tailPats ->
let infixHead = prettyPattern lhs <+> prettyInfixOp name <+> prettyPattern rhsPat
in case tailPats of
[] -> infixHead
_ -> hsep (parens infixHead : map prettyPattern tailPats)
_ ->
hsep (prettyBinderUName name : map prettyPattern pats)
prettyRhs :: Rhs Expr -> Doc ann
prettyRhs rhs =
case rhs of
UnguardedRhs _ body whereDecls ->
"="
<+> prettyExpr body
<> prettyIndentedWhereClause whereDecls
GuardedRhss _ guards whereDecls ->
nest 2 (hardline <> prettyGuardedRhssBlock guards whereDecls)
prettyWhereClauseBare :: Maybe [Decl] -> Doc ann
prettyWhereClauseBare Nothing = mempty
prettyWhereClauseBare (Just []) = "where" <+> spacedBraces mempty
prettyWhereClauseBare (Just decls) =
"where" <> nest 2 (hardline <> hardVsep (concatMap prettyDeclLines decls))
prettyIndentedWhereClause :: Maybe [Decl] -> Doc ann
prettyIndentedWhereClause Nothing = mempty
prettyIndentedWhereClause whereDecls = nest 2 (hardline <> prettyWhereClauseBare whereDecls)
prettyTHDeclQuote :: [Decl] -> Doc ann
prettyTHDeclQuote [] = "[d| |]"
prettyTHDeclQuote decls =
"[d|"
<> nest 2 (hardline <> hardVsep (concatMap prettyDeclLines decls))
<+> "|]"
-- | Infix type-family heads use @l \`Op\` r@ with a 'NameConId' operator (e.g.
-- @\`And\`@), so 'isSymbolicTypeName' is false; 'TypeHeadInfix' already marks
-- this shape as infix.
typeFamilyInfixAppView :: Type -> Maybe (Name, TypePromotion, Type, Type)
typeFamilyInfixAppView ty =
case peelTypeAnn ty of
TInfix lhs op promoted rhs -> Just (op, promoted, lhs, rhs)
_ -> Nothing
-- | Pretty-print a type. The AST is assumed to already have TParen nodes
-- in the correct positions (inserted by 'addTypeParens').
--
-- >>> let ty = TApp (TCon "Proxy" Unpromoted) (TParen (TFun ArrowUnrestricted (TCon "A" Unpromoted) (TCon "B" Unpromoted))) in (renderDoc (prettyType ty), show (shorthand ty))
-- ("Proxy (A -> B)","TApp (TCon \"Proxy\") (TParen (TFun (TCon \"A\") (TCon \"B\")))")
--
-- | Check if a type, when pretty-printed, would start with a
-- promotion tick. This is used to decide whether a promoted list or
-- tuple needs a space after the opening tick to avoid lexer confusion
-- (e.g. ''[ '[' ... ]'' is invalid, whereas ''[ '[ ... ]'' is valid).
startsWithTick :: Type -> Bool
startsWithTick (TAnn _ sub) = startsWithTick sub
startsWithTick (TList Promoted _) = True
startsWithTick (TCon _ Promoted) = True
startsWithTick (TTuple _ Promoted _) = True
startsWithTick (TTypeLit (TypeLitChar _ _)) = True
startsWithTick (TApp f _) = startsWithTick f
startsWithTick (TInfix lhs _ _ _) = startsWithTick lhs
startsWithTick _ = False
prettyType :: Type -> Doc ann
prettyType ty =
case ty of
TAnn _ sub -> prettyType sub
TVar name -> pretty name
TCon name promoted ->
let rendered = renderName name
base
| isSymbolicTypeName name = parens (pretty rendered)
| otherwise = pretty rendered
promoteTick
| T.any (== '\'') rendered = "' "
| otherwise = "'"
in if promoted == Promoted then promoteTick <> base else base
TBuiltinCon con promoted ->
let base = prettyBuiltinCon con
in if promoted == Promoted then "'" <> base else base
TImplicitParam name inner -> pretty name <+> "::" <+> prettyType inner
TTypeLit lit -> prettyTypeLiteral lit
TStar spelling -> pretty spelling
TQuasiQuote quoter body -> prettyQuasiQuote quoter body
TForall telescope inner ->
prettyForallTelescope telescope <+> prettyType inner
-- Before infix detection: required grouping from the parser ('TParen',
-- @(a :+: b) -> c@, constraints, nested @(c => t)@).
TParen inner -> parens (prettyType inner)
TInfix lhs op promoted rhs ->
prettyType lhs
<+> (if promoted == Promoted then "'" else mempty)
<> prettyNameInfixOp op
<+> prettyType rhs
TApp f x ->
prettyType f <+> prettyType x
TTypeApp f x ->
prettyType f <+> prettyTypeAppArg x
TFun arrowKind a b ->
-- When the arrows do not fit, each argument after the first starts a
-- new line with its arrow.
group (prettyType a <> nest 2 (prettyArrowTail arrowKind b))
TTuple tupleFlavor promoted elems ->
let elemsDoc = hsep (punctuate comma (map prettyType elems))
tupleDoc = prettyTupleBody tupleFlavor elemsDoc
in case (promoted, elems) of
(Promoted, h : _) | startsWithTick h -> "' " <> tupleDoc
(Promoted, _) -> "'" <> tupleDoc
_ -> tupleDoc
TUnboxedSum elems ->
hsep ["(#", hsep (punctuate " |" (map prettyType elems)), "#)"]
TList promoted elems ->
let elemsDoc = hsep (punctuate comma (map prettyType elems))
listDoc = brackets elemsDoc
in case (promoted, elems) of
(Promoted, h : _) | startsWithTick h -> "' " <> listDoc
(Promoted, _) -> "'" <> listDoc
_ -> listDoc
TKindSig ty' kind ->
prettyType ty' <+> "::" <+> prettyType kind
TContext constraints inner ->
case constraints of
[] -> prettyType inner
cs -> withContext cs (prettyType inner)
TSplice body -> "$" <> prettySpliceBody body
TWildcard -> "_"
-- | The arrows and arguments of a function type after its first argument.
prettyArrowTail :: ArrowKind -> Type -> Doc ann
prettyArrowTail arrowKind ty =
line
<> prettyArrowKind arrowKind
<+> case ty of
TAnn _ sub -> continue sub
_ -> continue ty
where
continue t =
case t of
TFun nextKind a b -> prettyType a <> prettyArrowTail nextKind b
TAnn _ sub -> continue sub
_ -> prettyType t
-- | A context and the item that it applies to. When they do not fit, the
-- item starts a new line after the @=>@.
withContext :: [Type] -> Doc ann -> Doc ann
withContext constraints doc =
case constraints of
[] -> doc
_ -> group (prettyContext constraints <> nest 2 (line <> "=>" <+> doc))
prettyArrowKind :: ArrowKind -> Doc ann
prettyArrowKind ArrowUnrestricted = "->"
prettyArrowKind ArrowLinear = "%1" <+> "->"
prettyArrowKind (ArrowExplicit ty) = "%" <> prettyType ty <+> "->"
-- | Print a built-in constructor such as @(,)@, @(# , #)@, @(->)@, @[]@,
-- or @(:)@.
prettyBuiltinCon :: BuiltinCon -> Doc ann
prettyBuiltinCon con =
case con of
BuiltinTuple tupleFlavor arity ->
let commas = mconcat (replicate (max 0 (arity - 1)) comma)
in case tupleFlavor of
Boxed -> parens commas
Unboxed -> "(#" <> commas <> "#)"
BuiltinArrow -> "(->)"
BuiltinList -> "[]"
BuiltinCons -> "(:)"
prettyContext :: [Type] -> Doc ann
prettyContext constraints =
case constraints of
[] -> mempty
[single] -> prettyType single
_ -> parens (hsep (punctuate comma (map prettyType constraints)))
prettyTypeLiteral :: TypeLiteral -> Doc ann
prettyTypeLiteral lit =
case lit of
TypeLitInteger _ repr -> pretty repr
TypeLitSymbol _ repr -> prettyRawText repr
TypeLitChar _ repr -> pretty repr
-- | Pretty-print a pattern. The AST is assumed to already have PParen nodes
-- in the correct positions (inserted by 'addPatternParens').
--
-- >>> let pat = PAs "xs" (PParen (PNegLit (LitInt 1 TInteger "1"))) in (renderDoc (prettyPattern pat), show (shorthand pat))
-- ("xs@(-1)","PAs UnqualifiedName {\"xs\"} (PParen (PNegLit (LitInt 1 TInteger)))")
prettyPattern :: Pattern -> Doc ann
prettyPattern pat =
case pat of
PAnn _ sub -> prettyPattern sub
PVar name -> prettyBinderUName name
PTypeBinder binder -> prettyTyVarBinder binder
PTypeSyntax TypeSyntaxExplicitNamespace ty -> "type" <+> prettyType ty
PTypeSyntax TypeSyntaxInTerm ty -> prettyType ty
PWildcard -> "_"
PLit lit -> prettyLiteral lit
PQuasiQuote quoter body -> prettyQuasiQuote quoter body
PTuple Unboxed [] -> "(# #)"
PTuple tupleFlavor elems -> prettyTupleBody tupleFlavor (hsep (punctuate comma (map prettyPattern elems)))
PUnboxedSum altIdx arity inner ->
let slots = [if i == altIdx then prettyPattern inner else mempty | i <- [0 .. arity - 1]]
in hsep ["(#", prettyBarSeparated slots, "#)"]
PList elems -> brackets (hsep (punctuate comma (map prettyPattern elems)))
PCon con typeArgs args -> hsep ([prettyPrefixName con] <> map prettyInvisibleTypeArg typeArgs <> map prettyPattern args)
PBuiltinCon con typeArgs args ->
hsep ([prettyBuiltinCon con] <> map prettyInvisibleTypeArg typeArgs <> map prettyPattern args)
PInfix lhs op rhs -> prettyPattern lhs <+> prettyNameInfixOp op <+> prettyPattern rhs
PView viewExpr inner ->
group (prettyExpr viewExpr <> nest 1 (line <> "->" <+> prettyPattern inner))
PAs name inner -> prettyBinderUName name <> "@" <> prettyPattern inner
PStrict inner -> "!" <> prettyPattern inner
PIrrefutable inner -> "~" <> prettyPattern inner
PNegLit lit -> "-" <> prettyLiteral lit
PNPlusK name lit -> prettyBinderUName name <+> "+" <+> prettyLiteral lit
PParen inner -> parens (prettyPattern inner)
PRecord con fields hasWildcard ->
prettyPrefixName con
<+> braces
( hsep
( punctuate
comma
( [prettyPatternFieldBinding field | field <- fields]
++ [".." | hasWildcard]
)
)
)
PTypeSig inner ty -> prettyPattern inner <+> "::" <+> prettyType ty
PSplice body -> "$" <> prettySpliceBody body
-- | Pretty print a pattern field binding.
prettyPatternFieldBinding :: RecordField Pattern -> Doc ann
prettyPatternFieldBinding field =
if recordFieldPun field
then pretty (recordFieldName field)
else pretty (recordFieldName field) <+> "=" <+> prettyPattern (recordFieldValue field)
prettyLiteral :: Literal -> Doc ann
prettyLiteral lit =
case peelLiteralAnn lit of
LitInt _ _ repr -> pretty repr
LitFloat _ _ repr -> pretty repr
LitChar _ repr -> pretty repr
LitCharHash _ repr -> pretty repr
LitString _ repr -> prettyRawText repr
LitStringHash _ repr -> prettyRawText repr
LitAnn {} -> error "unreachable"
prettyDataDecl :: DataDecl -> Doc ann
prettyDataDecl decl =
case dataDeclConstructors decl of
ctors
| any isGadtCon ctors ->
headDoc <+> prettyGadtConBlock ctors (dataDeclDeriving decl)
_ ->
prettyDataBody headDoc (dataDeclConstructors decl) (dataDeclDeriving decl)
where
headParts =
["data"]
<> maybe [] (pure . prettyPragma) (dataDeclCTypePragma decl)
<> prettyDeclBinderHead (dataDeclContext decl) (dataDeclHead decl)
<> kindPart
headDoc = hsep headParts
kindPart = maybe [] (\k -> ["::", prettyType k]) (dataDeclKind decl)
-- | The constructors and deriving clauses after a data declaration head. When
-- they do not fit, each constructor and each deriving clause starts a new
-- line.
prettyDataBody :: Doc ann -> [DataConDecl] -> [DerivingClause] -> Doc ann
prettyDataBody headDoc ctors derivingClauses =
group (headDoc <> nest 2 (ctorDocs <> derivingDocs))
where
ctorDocs =
mconcat
[ line <> separator <+> prettyDataCon ctor
| (separator, ctor) <- zip ("=" : repeat "|") ctors
]
derivingDocs = mconcat [line <> hsep (derivingPart clause) | clause <- derivingClauses]
prettyTypeDataDecl :: DataDecl -> Doc ann
prettyTypeDataDecl decl =
case dataDeclConstructors decl of
ctors
| any isGadtCon ctors -> headDoc <+> prettyGadtConBlock ctors []
_ -> prettyDataBody headDoc (dataDeclConstructors decl) []
where
headParts =
["type data"]
<> prettyDeclBinderHead (dataDeclContext decl) (dataDeclHead decl)
<> kindPart
headDoc = hsep headParts
kindPart = maybe [] (\k -> ["::", prettyType k]) (dataDeclKind decl)
isGadtCon :: DataConDecl -> Bool
isGadtCon (DataConAnn _ inner) = isGadtCon inner
isGadtCon (GadtCon {}) = True
isGadtCon _ = False
prettyNewtypeDecl :: NewtypeDecl -> Doc ann
prettyNewtypeDecl decl =
case newtypeDeclConstructor decl of
Just ctor
| isGadtCon ctor ->
headDoc <+> prettyGadtConBlock [ctor] (newtypeDeclDeriving decl)
_ ->
prettyDataBody headDoc (maybe [] pure (newtypeDeclConstructor decl)) (newtypeDeclDeriving decl)
where
headParts =
["newtype"]
<> maybe [] (pure . prettyPragma) (newtypeDeclCTypePragma decl)
<> prettyDeclBinderHead (newtypeDeclContext decl) (newtypeDeclHead decl)
<> kindPart
headDoc = hsep headParts
kindPart = maybe [] (\k -> ["::", prettyType k]) (newtypeDeclKind decl)
derivingParts :: [DerivingClause] -> [Doc ann]
derivingParts = concatMap derivingPart
prettyGadtConBlock :: [DataConDecl] -> [DerivingClause] -> Doc ann
prettyGadtConBlock ctors derivingClauses =
"where"
<> nest 2 (hardline <> hardVsep (map prettyDataCon ctors <> derivingParts derivingClauses))
derivingPart :: DerivingClause -> [Doc ann]
derivingPart (DerivingClause strategy classes) =
["deriving"] <> strategyPart strategy <> classesPart classes <> viaPart strategy
where
strategyPart Nothing = []
strategyPart (Just (DerivingVia _)) = []
strategyPart (Just strategy') = [prettyDerivingStrategy strategy']
classesPart (Left name) = [prettyName name]
classesPart (Right []) = ["()"]
classesPart (Right classTypes) = [parens (hsep (punctuate comma (map prettyType classTypes)))]
viaPart (Just (DerivingVia ty)) = ["via", prettyType ty]
viaPart _ = []
prettyDeclBinderHead :: [Type] -> BinderHead UnqualifiedName -> [Doc ann]
prettyDeclBinderHead constraints head' =
contextPrefix constraints
<> prettyDeclHeadNameAndParams head'
where
prettyDeclHeadNameAndParams binderHead =
case binderHead of
PrefixBinderHead name params ->
[prettyConstructorUName name] <> map prettyTyVarBinder params
InfixBinderHead lhs name rhs tailPrms ->
let infixHead = prettyTyVarBinder lhs <+> prettyInfixOp name <+> prettyTyVarBinder rhs
in case tailPrms of
[] -> [infixHead]
_ -> parens infixHead : map prettyTyVarBinder tailPrms
prettyTyVarBinder :: TyVarBinder -> Doc ann
prettyTyVarBinder binder =
visibleDoc
where
coreDoc =
case (tyVarBinderSpecificity binder, tyVarBinderKind binder) of
(TyVarBInferred, Nothing) -> braces (pretty (tyVarBinderName binder))
(TyVarBInferred, Just kind) -> braces (pretty (tyVarBinderName binder) <+> "::" <+> prettyType kind)
(TyVarBSpecified, Nothing) -> pretty (tyVarBinderName binder)
(TyVarBSpecified, Just kind) -> parens (pretty (tyVarBinderName binder) <+> "::" <+> prettyType kind)
visibleDoc =
case tyVarBinderVisibility binder of
TyVarBVisible -> coreDoc
TyVarBInvisible -> "@" <> coreDoc
contextPrefix :: [Type] -> [Doc ann]
contextPrefix constraints =
case constraints of
[] -> []
_ -> [prettyContext constraints, "=>"]
forallTyVarBinderPrefix :: [TyVarBinder] -> [Doc ann]
forallTyVarBinderPrefix [] = []
forallTyVarBinderPrefix binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]
prettyForallTelescope :: ForallTelescope -> Doc ann
prettyForallTelescope telescope =
"forall"
<+> hsep (map prettyTyVarBinder (forallTelescopeBinders telescope))
<> case forallTelescopeVisibility telescope of
ForallInvisible -> "."
ForallVisible -> " ->"
prettyInvisibleTypeArg :: Type -> Doc ann
prettyInvisibleTypeArg = prettyTypeAppArg
prettyTypeAppArg :: Type -> Doc ann
prettyTypeAppArg ty
| typeStartsWithSplice ty = "@" <> parens (prettyType ty)
| otherwise = "@" <> prettyType ty
typeStartsWithSplice :: Type -> Bool
typeStartsWithSplice ty =
case ty of
TAnn _ sub -> typeStartsWithSplice sub
TSplice {} -> True
_ -> False
prettyDataCon :: DataConDecl -> Doc ann
prettyDataCon ctor =
case ctor of
DataConAnn _ inner -> prettyDataCon inner
PrefixCon forallVars constraints name fields ->
hsep (dataConQualifierPrefix forallVars constraints <> [prettyConstructorUName name] <> map prettyBangType fields)
InfixCon forallVars constraints lhs op rhs ->
hsep
( dataConQualifierPrefix forallVars constraints
<> [prettyBangType lhs, prettyInfixOp op, prettyBangType rhs]
)
RecordCon forallVars constraints name fields ->
hsep (dataConQualifierPrefix forallVars constraints <> [prettyConstructorUName name])
<+> braces (prettyRecordFields fields)
GadtCon foralls constraints names body ->
prettyGadtCon foralls constraints names body
TupleCon forallVars constraints Boxed fields ->
hsep (dataConQualifierPrefix forallVars constraints)
<+> parens (hsep (punctuate comma (map prettyBangType fields)))
TupleCon forallVars constraints Unboxed fields ->
hsep (dataConQualifierPrefix forallVars constraints)
<+> "(#"
<+> hsep (punctuate comma (map prettyBangType fields))
<+> "#)"
UnboxedSumCon forallVars constraints pos arity field ->
hsep (dataConQualifierPrefix forallVars constraints)
<+> "(#"
<+> hsep (replicate (pos - 1) "|" <> [prettyBangType field] <> replicate (arity - pos) "|")
<+> "#)"
ListCon forallVars constraints ->
hsep (dataConQualifierPrefix forallVars constraints <> ["[]"])
prettyGadtCon :: [ForallTelescope] -> [Type] -> [UnqualifiedName] -> GadtBody -> Doc ann
prettyGadtCon forallBinders constraints names body =
hsep
( [hsep (punctuate comma (map prettyConstructorUName names)), "::"]
<> forallPart
<> contextPart
<> [prettyGadtBody body]
)
where
forallPart = map prettyForallTelescope forallBinders
contextPart
| null constraints = []
| otherwise = [prettyContext constraints, "=>"]
prettyGadtBody :: GadtBody -> Doc ann
prettyGadtBody body =
case body of
GadtPrefixBody args resultTy ->
case args of
[] -> prettyType resultTy
(firstArg, firstKind) : rest ->
group
( prettyBangType firstArg
<> nest
2
( mconcat
[ line <> prettyArrowKind kind <+> doc
| (kind, doc) <- zip (firstKind : map snd rest) (map (prettyBangType . fst) rest <> [prettyType resultTy])
]
)
)
GadtRecordBody fields resultTy ->
braces (prettyRecordFields fields) <+> "->" <+> prettyType resultTy
prettyRecordFields :: [FieldDecl] -> Doc ann
prettyRecordFields fields =
prettyCommaBlock
( [ hsep $
[hsep (punctuate comma (map prettyFieldName (fieldNames fld)))]
<> maybe [] (\mult -> ["%" <> prettyType mult]) (fieldMultiplicity fld)
<> [ "::",
prettyRecordFieldBangType (fieldType fld)
]
| fld <- fields
]
)
where
prettyFieldName :: UnqualifiedName -> Doc ann
prettyFieldName = prettyFunctionBinder
dataConQualifierPrefix :: [TyVarBinder] -> [Type] -> [Doc ann]
dataConQualifierPrefix forallVars constraints = forallTyVarBinderPrefix forallVars <> contextPrefix constraints
-- | Pretty print a BangType. The type already has TParen nodes where needed.
prettyBangType :: BangType -> Doc ann
prettyBangType bt =
hsep (map prettyPragma (bangPragmas bt) <> [strictOrLazyDoc])
where
strictOrLazyDoc
| bangStrict bt = "!" <> prettyType (bangType bt)
| bangLazy bt = "~" <> prettyType (bangType bt)
| otherwise = prettyType (bangType bt)
prettyRecordFieldBangType :: BangType -> Doc ann
prettyRecordFieldBangType bt =
hsep (map prettyPragma (bangPragmas bt) <> [strictOrLazyDoc])
where
strictOrLazyDoc
| bangStrict bt = "!" <> prettyType (bangType bt)
| bangLazy bt = "~" <> prettyType (bangType bt)
| otherwise = prettyType (bangType bt)
prettyClassDecl :: ClassDecl -> Doc ann
prettyClassDecl decl =
let headDoc =
let classHead = hsep (prettyNamedBinderHead (classDeclHead decl) <> prettyClassFundeps (classDeclFundeps decl))
in "class"
<+> case classDeclContext decl of
Nothing -> classHead
Just constraints -> group (prettyContext constraints <> nest 2 (line <> "=>" <+> classHead))
in case classDeclItems decl of
[] -> headDoc
items ->
headDoc
<+> "where"
<> nest 2 (hardline <> hardVsep (concatMap prettyClassItemLines items))
prettyClassFundeps :: [FunctionalDependency] -> [Doc ann]
prettyClassFundeps deps =
case deps of
[] -> []
_ -> ["|", hsep (punctuate comma (map prettyFunctionalDependency deps))]
prettyFunctionalDependency :: FunctionalDependency -> Doc ann
prettyFunctionalDependency dep =
hsep
[ hsep (map pretty (functionalDependencyDeterminers dep)),
"->",
hsep (map pretty (functionalDependencyDetermined dep))
]
prettyTypeFamilyInjectivity :: TypeFamilyInjectivity -> Doc ann
prettyTypeFamilyInjectivity injectivity =
hsep
[ pretty (typeFamilyInjectivityResult injectivity),
"->",
hsep (map pretty (typeFamilyInjectivityDetermined injectivity))
]
prettyClassItem :: ClassDeclItem -> Doc ann
prettyClassItem item =
case item of
ClassItemAnn _ sub -> prettyClassItem sub
ClassItemTypeSig names ty -> hsep [hsep (punctuate comma (map prettyBinderName names)), "::", prettyType ty]
ClassItemDefaultSig name ty -> hsep ["default", prettyBinderName name, "::", prettyType ty]
ClassItemFixity assoc mNamespace prec ops ->
hsep
( [prettyFixityAssoc assoc]
<> maybe [] (pure . pretty . show) prec
<> maybe [] (pure . prettyNamespace) mNamespace
<> punctuate comma (map prettyInfixOp ops)
)
ClassItemDefault valueDecl -> prettyValueDeclSingleLine valueDecl
ClassItemTypeFamilyDecl tf -> prettyAssocTypeFamilyDecl tf
ClassItemDataFamilyDecl df -> prettyAssocDataFamilyDecl df
ClassItemDefaultTypeInst tfi -> prettyDefaultTypeInst tfi
ClassItemPragma pragma -> prettyPragma pragma
prettyClassItemLines :: ClassDeclItem -> [Doc ann]
prettyClassItemLines item =
case item of
ClassItemAnn _ inner -> prettyClassItemLines inner
ClassItemDefault valueDecl -> prettyValueDeclLines valueDecl
_ -> [prettyClassItem item]
prettyInstanceDecl :: InstanceDecl -> Doc ann
prettyInstanceDecl decl =
let headDoc =
hsep
( ["instance"]
<> map prettyPragma (instanceDeclPragmas decl)
<> maybe [] (\w -> [prettyPragma w]) (instanceDeclWarning decl)
<> forallTyVarBinderPrefix (instanceDeclForall decl)
<> [withContext (instanceDeclContext decl) (prettyType (instanceDeclHead decl))]
)
in case instanceDeclItems decl of
[] -> headDoc
items ->
headDoc
<+> "where"
<> nest 2 (hardline <> hardVsep (concatMap prettyInstanceItemLines items))
prettyStandaloneDeriving :: StandaloneDerivingDecl -> Doc ann
prettyStandaloneDeriving decl =
hsep
( ["deriving"]
<> maybe [] (\s -> [prettyDerivingStrategy s]) (standaloneDerivingStrategy decl)
<> ["instance"]
<> map prettyPragma (standaloneDerivingPragmas decl)
<> maybe [] (\w -> [prettyPragma w]) (standaloneDerivingWarning decl)
<> forallTyVarBinderPrefix (standaloneDerivingForall decl)
<> contextPrefix (standaloneDerivingContext decl)
<> [prettyType (standaloneDerivingHead decl)]
)
prettyPragma :: Pragma -> Doc ann
prettyPragma pragma
| not (T.null (pragmaRawText pragma)) = prettyHardLines (pragmaRawText pragma)
| otherwise = prettyPragmaType (pragmaType pragma)
prettyPragmaType :: PragmaType -> Doc ann
prettyPragmaType pt =
case pt of
PragmaLanguage settings -> "{-# LANGUAGE " <> hsep (punctuate comma (map (pretty . extensionSettingName) settings)) <> " #-}"
PragmaInstanceOverlap overlapPragma ->
case overlapPragma of
Overlapping -> "{-# OVERLAPPING #-}"
Overlappable -> "{-# OVERLAPPABLE #-}"
Overlaps -> "{-# OVERLAPS #-}"
Incoherent -> "{-# INCOHERENT #-}"
PragmaWarning msg -> "{-# WARNING " <> pretty (show msg) <> " #-}"
PragmaDeprecated msg -> "{-# DEPRECATED " <> pretty (show msg) <> " #-}"
PragmaInline kind body -> "{-# " <> pretty kind <> " " <> pretty body <> " #-}"
PragmaUnpack unpackKind ->
case unpackKind of
UnpackPragma -> "{-# UNPACK #-}"
NoUnpackPragma -> "{-# NOUNPACK #-}"
PragmaSource sourceText _ -> "{-# SOURCE " <> pretty sourceText <> " #-}"
PragmaSCC label -> "{-# SCC " <> pretty label <> " #-}"
PragmaUnknown text -> prettyHardLines text
prettyDerivingStrategy :: DerivingStrategy -> Doc ann
prettyDerivingStrategy strategy =
case strategy of
DerivingStock -> "stock"
DerivingNewtype -> "newtype"
DerivingAnyclass -> "anyclass"
DerivingVia ty -> "via" <+> prettyType ty
prettyInstanceItem :: InstanceDeclItem -> Doc ann
prettyInstanceItem item =
case item of
InstanceItemAnn _ inner -> prettyInstanceItem inner
InstanceItemBind valueDecl -> prettyValueDeclSingleLine valueDecl
InstanceItemTypeSig names ty -> hsep [hsep (punctuate comma (map prettyBinderName names)), "::", prettyType ty]
InstanceItemFixity assoc mNamespace prec ops ->
hsep
( [prettyFixityAssoc assoc]
<> maybe [] (pure . pretty . show) prec
<> maybe [] (pure . prettyNamespace) mNamespace
<> punctuate comma (map prettyInfixOp ops)
)
InstanceItemTypeFamilyInst tfi -> prettyInstTypeFamilyInst tfi
InstanceItemDataFamilyInst dfi -> prettyInstDataFamilyInst dfi
InstanceItemPragma pragma -> prettyPragma pragma
prettyInstanceItemLines :: InstanceDeclItem -> [Doc ann]
prettyInstanceItemLines item =
case item of
InstanceItemAnn _ inner -> prettyInstanceItemLines inner
InstanceItemBind valueDecl -> prettyValueDeclLines valueDecl
_ -> [prettyInstanceItem item]
prettyFixityAssoc :: FixityAssoc -> Doc ann
prettyFixityAssoc assoc =
case assoc of
Infix -> "infix"
InfixL -> "infixl"
InfixR -> "infixr"
prettyForeignDecl :: ForeignDecl -> Doc ann
prettyForeignDecl decl =
hsep . catMaybes $
[ Just "foreign",
Just (prettyDirection (foreignDirection decl)),
Just (prettyCallConv (foreignCallConv decl)),
prettySafety <$> foreignSafety decl,
prettyForeignEntity (foreignEntity decl),
Just (prettyBinderName (foreignName decl)),
Just "::",
Just (prettyType (foreignType decl))
]
prettyDirection :: ForeignDirection -> Doc ann
prettyDirection direction =
case direction of
ForeignImport -> "import"
ForeignExport -> "export"
prettyCallConv :: CallConv -> Doc ann
prettyCallConv cc =
case cc of
CCall -> "ccall"
StdCall -> "stdcall"
CApi -> "capi"
CPrim -> "prim"
JavaScript -> "javascript"
prettySafety :: ForeignSafety -> Doc ann
prettySafety safety =
case safety of
Safe -> "safe"
Unsafe -> "unsafe"
Interruptible -> "interruptible"
prettyForeignEntity :: ForeignEntitySpec -> Maybe (Doc ann)
prettyForeignEntity spec =
case spec of
ForeignEntityOmitted -> Nothing
ForeignEntityDynamic -> Just (quoted "dynamic")
ForeignEntityWrapper -> Just (quoted "wrapper")
ForeignEntityStatic Nothing -> Just (quoted "static")
ForeignEntityStatic (Just name) -> Just (quoted ("static " <> name))
ForeignEntityAddress Nothing -> Just (quoted "&")
ForeignEntityAddress (Just name) -> Just (quoted ("&" <> name))
ForeignEntityNamed name -> Just (quoted name)
prettyInfixOp :: UnqualifiedName -> Doc ann
prettyInfixOp name
| isSymbolicUName name = pretty (renderUnqualifiedName name)
| otherwise = "`" <> pretty (renderUnqualifiedName name) <> "`"
prettyNameInfixOp :: Name -> Doc ann
prettyNameInfixOp name
| isSymbolicName name = pretty (renderName name)
| otherwise = "`" <> pretty (renderName name) <> "`"
prettyPrefixName :: Name -> Doc ann
prettyPrefixName name
| isSymbolicName name = parens (pretty rendered)
| otherwise = pretty rendered
where
rendered = renderName name
isSymbolicUName :: UnqualifiedName -> Bool
isSymbolicUName name =
case unqualifiedNameType name of
NameVarSym -> True
NameConSym -> True
_ -> False
isSymbolicName :: Name -> Bool
isSymbolicName name =
case nameType name of
NameVarSym -> True
NameConSym -> True
_ -> False
isSymbolicTypeName :: Name -> Bool
isSymbolicTypeName = isSymbolicName
prettyFunctionBinder :: UnqualifiedName -> Doc ann
prettyFunctionBinder name
| unqualifiedNameType name == NameVarSym || unqualifiedNameType name == NameConSym =
let rendered = renderUnqualifiedName name
in if startsWithHash rendered
then parens (" " <> pretty rendered <> " ")
else parens (pretty rendered)
| otherwise = pretty (renderUnqualifiedName name)
where
startsWithHash t =
case T.uncons t of
Just ('#', _) -> True
_ -> False
prettyBinderName :: UnqualifiedName -> Doc ann
prettyBinderName = prettyFunctionBinder
prettyBinderUName :: UnqualifiedName -> Doc ann
prettyBinderUName = prettyFunctionBinder
prettyName :: Name -> Doc ann
prettyName name
| nameType name == NameVarSym || nameType name == NameConSym =
let rendered = renderName name
in if startsWithHash rendered
then parens (" " <> pretty rendered <> " ")
else parens (pretty rendered)
| otherwise = pretty (renderName name)
where
startsWithHash t =
case T.uncons t of
Just ('#', _) -> True
_ -> False
prettyBundledMemberName :: Name -> Doc ann
prettyBundledMemberName name
| isHashLeadingSymbolicName name = parens (" " <> pretty (renderName name) <> " ")
| otherwise = prettyName name
isHashLeadingSymbolicName :: Name -> Bool
isHashLeadingSymbolicName name =
isSymbolicName name
&& case nameQualifier name of
Nothing -> case T.uncons (nameText name) of
Just ('#', _) -> True
_ -> False
Just _ -> False
prettyConstructorUName :: UnqualifiedName -> Doc ann
prettyConstructorUName name
| isSymbolicUName name = parens (pretty (renderUnqualifiedName name))
| otherwise = pretty (renderUnqualifiedName name)
-- | Pretty-print an expression. The AST is assumed to already have EParen
-- nodes in the correct positions (inserted by 'addExprParens').
--
-- >>> let expr = EApp (EVar "f") (EParen (EInfix (EVar "x") "+" (EVar "y"))) in (renderDoc (prettyExpr expr), show (shorthand expr))
-- ("f (x + y)","EApp (EVar \"f\") (EParen (EInfix (EVar \"x\") \"+\" (EVar \"y\")))")
prettyExpr :: Expr -> Doc ann
prettyExpr expr =
case expr of
EApp {} -> prettyApp expr
ETypeApp fn ty ->
group (nest 2 (prettyExpr fn) <> nest 1 (spacedLine <> prettyTypeAppArg ty))
EVar name -> prettyName name
EImplicitParam name -> pretty name
ETypeSyntax TypeSyntaxExplicitNamespace ty -> "type" <+> prettyType ty
ETypeSyntax TypeSyntaxInTerm ty -> prettyType ty
EInt _ _ repr -> pretty repr
EFloat _ _ repr -> pretty repr
EChar _ repr -> pretty repr
ECharHash _ repr -> pretty repr
EString _ repr -> prettyRawText repr
EStringHash _ repr -> prettyRawText repr
EOverloadedLabel _ raw -> pretty (" " <> raw)
EQuasiQuote quoter body -> prettyQuasiQuote quoter body
ETHExpQuote body -> "[|" <+> prettyExpr body <+> "|]"
ETHTypedQuote body -> "[||" <+> prettyExpr body <+> "||]"
ETHDeclQuote decls -> prettyTHDeclQuote decls
ETHTypeQuote ty -> "[t|" <+> prettyType ty <+> "|]"
ETHPatQuote pat -> "[p|" <+> prettyPattern pat <+> "|]"
ETHNameQuote body -> "' " <> prettyExpr body
ETHTypeNameQuote ty -> "'' " <> prettyType ty
ETHSplice body -> "$" <> prettySpliceBody body
ETHTypedSplice body -> "$$" <> prettySpliceBody body
EIf cond yes no ->
group ("if" <+> prettyExpr cond <> nest 2 (line <> "then" <+> prettyExpr yes <> line <> "else" <+> prettyExpr no))
EMultiWayIf rhss ->
"if" <> prettyMultiWayIfBlock (prettyMultiWayIfRhss rhss) <> noFlat
ELambdaPats pats body ->
"\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyExpr body
ELambdaCase alts ->
"\\" <> "case" <> prettyCaseLayout (map prettyCaseAlt alts)
ELambdaCases alts ->
"\\" <> "cases" <> prettyCaseLayout (map prettyLambdaCaseAlt alts)
EInfix lhs op rhs ->
group (nest 2 (prettyExpr lhs) <> nest 1 (line <> prettyNameInfixOp op <+> prettyExpr rhs))
EViewPat viewExpr rhs ->
group (prettyExpr viewExpr <> nest 1 (line <> "->" <+> prettyExpr rhs))
ENegate inner -> "-" <+> prettyExprAtStatementStart inner
ESectionL lhs op ->
group (nest 2 (prettyExpr lhs) <> nest 1 (spacedLine <> prettyNameInfixOp op))
ESectionR op rhs -> prettyNameInfixOp op <+> prettyExpr rhs
ELetDecls decls body ->
case decls of
[] -> prettyLetDecls decls <+> "in" <+> prettyExpr body
_ -> group (align (prettyLetDecls decls <> nest 2 (line <> "in" <+> prettyExpr body)))
ECase scrutinee alts ->
prettyCaseExpr prettyCaseLayout scrutinee alts
EDo stmts flavor ->
prettyDoFlavor flavor <> nest 2 (prettyDoLayout prettyDoStmt stmts)
EListComp body quals ->
brackets
( let qualifiers = prettyCommaSeparated prettyCompStmt quals
in group (prettyExpr body <> spacedLine <> "|" <+> qualifiers)
)
EListCompParallel body qualifierGroups ->
brackets
( let qualifiers =
prettyBarSeparated
[ prettyCommaSeparated prettyCompStmt qualifierGroup
| qualifierGroup <- qualifierGroups
]
in group (prettyExpr body <> spacedLine <> "|" <+> qualifiers)
)
EArithSeq seqInfo -> prettyArithSeq seqInfo
ERecordCon name fields hasWildcard ->
prettyPrefixName name <+> braces (prettyCommaBlock (map prettyBinding fields ++ [".." | hasWildcard]))
ERecordUpd base fields ->
prettyExpr base <+> braces (prettyCommaBlock (map prettyBinding fields))
EGetField base field ->
prettyExpr base <> "." <> prettyName field
EGetFieldProjection fields ->
"." <> mconcat (punctuate "." (map prettyName fields))
ETypeSig inner ty ->
group (nest 2 (prettyExpr inner) <> nest 1 (line <> "::" <+> prettyType ty))
EParen inner -> case inner of
ECase scrutinee alts ->
parens (prettyCaseExpr prettyCaseLayout scrutinee alts)
-- ESectionR with a '#'-starting op renders as "(# ...)" which the lexer
-- reads as TkSpecialUnboxedLParen when UnboxedTuples/UnboxedSums is on.
-- A leading space produces "( # ...)" which is unambiguous.
ESectionR op _ | T.isPrefixOf "#" (renderName op) -> parens (" " <> prettyExpr inner)
-- ESectionL with a '#'-ending op renders as "(x #)" which the lexer
-- reads as TkSpecialUnboxedRParen when UnboxedTuples/UnboxedSums is on.
-- A trailing space produces "(x # )" which is unambiguous.
ESectionL _ op | T.isSuffixOf "#" (renderName op) -> parens (prettyExpr inner <> " ")
_ -> parens (prettyExpr inner)
EList values -> brackets (prettyCommaSeparated prettyExpr values)
ETuple Unboxed [] -> "(# #)"
ETuple tupleFlavor values ->
prettyTupleBody tupleFlavor (prettyCommaSeparated (maybe mempty prettyExpr) values)
EUnboxedSum altIdx arity inner ->
let slots = [if i == altIdx then prettyExpr inner else mempty | i <- [0 .. arity - 1]]
in hsep ["(#", prettyBarSeparated slots, "#)"]
EProc pat body ->
"proc" <+> prettyPattern pat <+> "->" <+> prettyCmd body
EPragma pragma inner ->
prettyPragma pragma <+> prettyExpr inner
EAnn _ sub -> prettyExpr sub
prettyApp :: Expr -> Doc ann
prettyApp = prettyAppWith prettyExpr
prettyAppWith :: (Expr -> Doc ann) -> Expr -> Doc ann
prettyAppWith prettyFn expr =
let (fn, args) = flattenApps expr
in prettyFn fn <> nest 2 (softline <> fillArguments args)
where
-- Put as many arguments on a line as fit. After an argument that ends
-- with a layout block, start a new line: text on the same line goes into
-- the block.
fillArguments [] = mempty
fillArguments [arg] = prettyExpr arg
fillArguments (arg : rest) =
prettyExpr arg <> (if endsWithLayoutBlock arg then hardline else softline) <> fillArguments rest
flattenApps = go []
go args (EAnn _ sub) = go args sub
go args (EApp fn arg) = go (arg : args) fn
go args root = (root, args)
-- | The printed expression ends with a layout block that has no closing token.
endsWithLayoutBlock :: Expr -> Bool
endsWithLayoutBlock expr =
case expr of
EAnn _ sub -> endsWithLayoutBlock sub
ECase {} -> True
EDo {} -> True
ELambdaCase {} -> True
ELambdaCases {} -> True
EMultiWayIf {} -> True
ELetDecls _ body -> endsWithLayoutBlock body
ELambdaPats _ body -> endsWithLayoutBlock body
EIf _ _ no -> endsWithLayoutBlock no
EApp _ arg -> endsWithLayoutBlock arg
EInfix _ _ rhs -> endsWithLayoutBlock rhs
ENegate inner -> endsWithLayoutBlock inner
EProc {} -> True
_ -> False
prettyCommaSeparated :: (a -> Doc ann) -> [a] -> Doc ann
prettyCommaSeparated render items =
case map render items of
[] -> mempty
rendered -> prettyCommaBlock rendered
-- | Items separated by commas. Each line gets as many items as fit.
prettyCommaFill :: [Doc ann] -> Doc ann
prettyCommaFill items = nest 2 (concatWith (\x y -> x <> comma <> softline <> y) items)
-- | Items separated by commas. When they do not fit on the line, each item
-- after the first starts a new line.
prettyCommaBlock :: [Doc ann] -> Doc ann
prettyCommaBlock items = group (nest 2 (concatWith (\x y -> x <> comma <> line <> y) items))
prettyBarSeparated :: [Doc ann] -> Doc ann
prettyBarSeparated items =
case items of
[] -> mempty
firstItem : restItems -> group (hang 1 (vsep (firstItem : map ("|" <+>) restItems)))
prettyTupleBody :: TupleFlavor -> Doc ann -> Doc ann
prettyTupleBody tupleFlavor inner =
case tupleFlavor of
Boxed -> parens inner
Unboxed -> hsep ["(#", inner, "#)"]
-- | Print the prefix tuple constructor for the given arity: @(,)@ or @(#,#)@.
prettyBinding :: RecordField Expr -> Doc ann
prettyBinding field =
if recordFieldPun field
then prettyName (recordFieldName field)
else prettyName (recordFieldName field) <+> "=" <+> prettyExpr (recordFieldValue field)
prettyCaseAltWith :: (body -> Doc ann) -> CaseAlt body -> Doc ann
prettyCaseAltWith prettyBody (CaseAlt _ pat rhs) =
case rhs of
UnguardedRhs _ body whereDecls ->
prettyPattern pat
<+> "->"
<+> nest 2 (prettyBody body)
<> prettyIndentedWhereClause whereDecls
GuardedRhss _ grhss whereDecls ->
prettyGuardedCaseAlt (prettyPattern pat) prettyBody grhss
<> prettyIndentedWhereClause whereDecls
prettyCaseAlt :: CaseAlt Expr -> Doc ann
prettyCaseAlt = prettyCaseAltWith prettyExpr
prettyGuardedRhsBodyBlock :: Text -> GuardedRhs Expr -> Doc ann
prettyGuardedRhsBodyBlock arrow grhs =
let guards = guardedRhsGuards grhs
body = guardedRhsBody grhs
in group
( "|"
<+> prettyGuardQualifiersLayout guards
<> spacedLine
<> pretty arrow
<+> prettyExpr body
)
prettyCaseGuardedRhsBlock :: (body -> Doc ann) -> GuardedRhs body -> Doc ann
prettyCaseGuardedRhsBlock prettyBody grhs =
let guards = guardedRhsGuards grhs
body = guardedRhsBody grhs
in group
( "|"
<+> prettyGuardQualifiersLayout guards
<> spacedLine
<> "->"
<+> nest 2 (prettyBody body)
)
prettyGuardedCaseAlt :: Doc ann -> (body -> Doc ann) -> [GuardedRhs body] -> Doc ann
prettyGuardedCaseAlt headDoc prettyBody grhss =
case map (prettyCaseGuardedRhsBlock prettyBody) grhss of
[] -> headDoc
[firstGrhs] -> headDoc <+> firstGrhs
firstGrhs : restGrhss ->
headDoc <+> firstGrhs <> nest 2 (hardline <> hardVsep restGrhss)
prettyMultiWayIfRhss :: [GuardedRhs Expr] -> Doc ann
prettyMultiWayIfRhss rhss = hardVsep (map (prettyGuardedRhsBodyBlock "->") rhss)
-- | Put the alternatives of a multi-way @if@ in a layout block that starts to
-- the right of the @if@ keyword and also to the right of the current
-- indentation.
--
-- The alternatives are an implicit layout block that opens at the first @|@.
-- A later line at the same column as that @|@, or further right, continues the
-- last alternative. It does not close the block. The enclosing expression
-- puts its continuation lines relative to the current indentation, which can
-- be further right than the @if@ keyword. Thus the block must also clear the
-- indentation, or the printed module does not parse to the same syntax tree.
prettyMultiWayIfBlock :: Doc ann -> Doc ann
prettyMultiWayIfBlock alternatives =
column
( \col ->
nesting
( \indent ->
let target = max (col + 1) (indent + multiWayIfBarOffset)
in pretty (T.replicate (target - col) " ") <> nest (target - indent) alternatives
)
)
-- | The least distance between the current indentation and the @|@ of a
-- multi-way @if@. Each continuation line that the pretty-printer puts after a
-- sub-expression is at most two columns to the right of the indentation of that
-- sub-expression. Three columns thus always close the block.
multiWayIfBarOffset :: Int
multiWayIfBarOffset = 3
prettyGuardQualifiersLayout :: [GuardQualifier] -> Doc ann
prettyGuardQualifiersLayout qualifiers =
case map prettyGuardQualifier qualifiers of
[] -> mempty
[firstQualifier] -> firstQualifier
firstQualifier : restQualifiers ->
group (firstQualifier <> nest 2 (line' <> concatWith (\x y -> x <> line' <> y) (map (comma <+>) restQualifiers)))
prettyCaseExpr :: ([Doc ann] -> Doc ann) -> Expr -> [CaseAlt Expr] -> Doc ann
prettyCaseExpr layout scrutinee alts =
"case"
<+> align (prettyExpr scrutinee)
<+> "of"
<> layout (map prettyCaseAlt alts)
prettyCaseLayout :: [Doc ann] -> Doc ann
prettyCaseLayout [] = " " <> spacedBraces mempty
prettyCaseLayout alts = nest 2 (hardline <> hardVsep alts)
prettyLambdaCaseAlt :: LambdaCaseAlt -> Doc ann
prettyLambdaCaseAlt (LambdaCaseAlt _ pats rhs) =
case rhs of
UnguardedRhs _ body whereDecls ->
hsep (map prettyPattern pats)
<+> "->"
<+> nest 2 (prettyExpr body)
<> prettyIndentedWhereClause whereDecls
GuardedRhss _ grhss whereDecls ->
prettyGuardedCaseAlt (hsep (map prettyPattern pats)) prettyExpr grhss
<> prettyIndentedWhereClause whereDecls
prettyGuardQualifier :: GuardQualifier -> Doc ann
prettyGuardQualifier qualifier =
case qualifier of
GuardAnn _ inner -> prettyGuardQualifier inner
GuardExpr expr -> prettyExpr expr
GuardPat pat expr -> prettyPattern pat <+> "<-" <+> prettyExpr expr
-- The let block has no closing token. On one line, the guard arrow can
-- go into the block, for example into a type signature.
GuardLet decls -> prettyLetDecls decls <> noFlat
prettyLetDecls :: [Decl] -> Doc ann
prettyLetDecls decls
| null decls = "let" <+> spacedBraces mempty
| otherwise =
"let" <+> align (hardVsep (concatMap prettyDeclLines decls))
prettyDoFlavor :: DoFlavor -> Doc ann
prettyDoFlavor DoPlain = "do"
prettyDoFlavor DoMdo = "mdo"
prettyDoFlavor (DoQualified m) = pretty m <> ".do"
prettyDoFlavor (DoQualifiedMdo m) = pretty m <> ".mdo"
prettyDoLayout :: (a -> Doc ann) -> [a] -> Doc ann
prettyDoLayout prettyStmt stmts =
case stmts of
[] -> hardline
_ -> hardline <> prettyLayoutStatements prettyStmt stmts
prettyLayoutStatements :: (a -> Doc ann) -> [a] -> Doc ann
prettyLayoutStatements prettyStmt stmts =
case map prettyStmt stmts of
[] -> mempty
rendered -> hardVsep rendered
prettyDoStmt :: DoStmt Expr -> Doc ann
prettyDoStmt stmt =
case stmt of
DoAnn _ inner -> prettyDoStmt inner
DoBind pat expr -> prettyPattern pat <+> "<-" <+> prettyExpr expr
DoLetDecls decls -> prettyLetDecls decls
--
DoExpr expr -> prettyExprAtStatementStart expr
DoRecStmt stmts -> "rec" <> nest 2 (prettyDoLayout prettyDoStmt stmts)
-- prettyExprAtStatementStart is a hack to get overloaded labels to align. We always print a space before labels which messes things up.
prettyExprAtStatementStart :: Expr -> Doc ann
prettyExprAtStatementStart expr =
case expr of
EAnn _ sub -> prettyExprAtStatementStart sub
EOverloadedLabel _ raw -> pretty raw
EApp {} -> prettyAppWith prettyExprAtStatementStart expr
ETypeApp fn ty -> group (nest 2 (prettyExprAtStatementStart fn) <> nest 1 (spacedLine <> prettyTypeAppArg ty))
EInfix lhs op rhs -> group (nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (line <> prettyNameInfixOp op <+> prettyExpr rhs))
ESectionL lhs op -> group (nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (spacedLine <> prettyNameInfixOp op))
ETypeSig inner ty -> group (nest 2 (prettyExprAtStatementStart inner) <> nest 1 (line <> "::" <+> prettyType ty))
ERecordUpd base fields ->
prettyExprAtStatementStart base <+> braces (prettyCommaBlock (map prettyBinding fields))
EGetField base field ->
prettyExprAtStatementStart base <> "." <> prettyName field
_ -> prettyExpr expr
-- | Pretty-print an arrow command.
prettyCmd :: Cmd -> Doc ann
prettyCmd (CmdAnn _ inner) = prettyCmd inner
prettyCmd cmd =
case cmd of
CmdArrApp lhs HsFirstOrderApp rhs ->
prettyExpr lhs <+> "-<" <+> prettyExpr rhs
CmdArrApp lhs HsHigherOrderApp rhs ->
prettyExpr lhs <+> "-<<" <+> prettyExpr rhs
CmdInfix l op r ->
group (nest 2 (prettyCmd l) <> nest 1 (spacedLine <> prettyNameInfixOp op <+> prettyCmd r))
CmdDo stmts ->
"do" <> nest 2 (prettyDoLayout prettyCmdStmt stmts)
CmdIf cond yes no ->
group ("if" <+> prettyExpr cond <> nest 2 (line <> "then" <+> prettyCmd yes <> line <> "else" <+> prettyCmd no))
CmdCase scrut alts ->
"case" <+> prettyExpr scrut <+> "of" <> prettyCaseLayout (map prettyCmdCaseAlt alts)
CmdLet decls body ->
case decls of
[] -> prettyLetDecls decls <+> "in" <+> prettyCmd body
_ -> group (align (prettyLetDecls decls <> nest 2 (line <> "in" <+> prettyCmd body)))
CmdLam pats body ->
"\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyCmd body
CmdApp c e ->
prettyCmd c <+> prettyExpr e
CmdPar c ->
parens (prettyCmd c)
prettyCmdStmt :: DoStmt Cmd -> Doc ann
prettyCmdStmt stmt =
case stmt of
DoAnn _ inner -> prettyCmdStmt inner
DoBind pat cmd' -> prettyPattern pat <+> "<-" <+> prettyCmd cmd'
DoLetDecls decls -> prettyLetDecls decls
DoExpr cmd'@CmdLet {} -> parens (prettyCmd cmd')
DoExpr cmd' -> prettyCmdAtStatementStart cmd'
DoRecStmt stmts -> "rec" <> nest 2 (prettyDoLayout prettyCmdStmt stmts)
prettyCmdAtStatementStart :: Cmd -> Doc ann
prettyCmdAtStatementStart cmd =
case cmd of
CmdAnn _ inner -> prettyCmdAtStatementStart inner
CmdArrApp lhs HsFirstOrderApp rhs ->
prettyExprAtStatementStart lhs <+> "-<" <+> prettyExpr rhs
CmdArrApp lhs HsHigherOrderApp rhs ->
prettyExprAtStatementStart lhs <+> "-<<" <+> prettyExpr rhs
CmdInfix l op r ->
group (nest 2 (prettyCmdAtStatementStart l) <> nest 1 (spacedLine <> prettyNameInfixOp op <+> prettyCmd r))
CmdApp c e ->
prettyCmdAtStatementStart c <+> prettyExpr e
_ -> prettyCmd cmd
prettyCmdCaseAlt :: CaseAlt Cmd -> Doc ann
prettyCmdCaseAlt = prettyCaseAltWith prettyCmd
prettyCompStmt :: CompStmt -> Doc ann
prettyCompStmt stmt =
case stmt of
CompAnn _ inner -> prettyCompStmt inner
CompGen pat expr -> prettyPattern pat <+> "<-" <+> prettyExpr expr
CompGuard expr -> prettyExpr expr
CompLetDecls decls -> prettyLetDecls decls
CompThen f -> "then" <+> prettyExpr f
CompThenBy f e -> "then" <+> prettyExpr f <+> "by" <+> prettyExpr e
CompGroupUsing f -> "then" <+> "group" <+> "using" <+> prettyExpr f
CompGroupByUsing e f -> "then" <+> "group" <+> "by" <+> prettyExpr e <+> "using" <+> prettyExpr f
prettyGuardedRhssBlock :: [GuardedRhs Expr] -> Maybe [Decl] -> Doc ann
prettyGuardedRhssBlock guards whereDecls =
hardVsep (map prettyGuardedRhsBlock guards)
<> case whereDecls of
Nothing -> mempty
Just _ -> hardline <> prettyWhereClauseBare whereDecls
prettyGuardedRhsBlock :: GuardedRhs Expr -> Doc ann
prettyGuardedRhsBlock grhs =
let guards = guardedRhsGuards grhs
body = guardedRhsBody grhs
in "|"
<+> prettyGuardQualifiersLayout guards
<+> "="
<+> prettyExpr body
prettyArithSeq :: ArithSeq -> Doc ann
prettyArithSeq seqInfo =
case seqInfo of
ArithSeqAnn _ inner -> prettyArithSeq inner
ArithSeqFrom fromExpr -> brackets (prettyExpr fromExpr <> " ..")
ArithSeqFromThen fromExpr thenExpr -> brackets (prettyExpr fromExpr <> ", " <> prettyExpr thenExpr <> " ..")
ArithSeqFromTo fromExpr toExpr -> brackets (prettyExpr fromExpr <> " .. " <> prettyExpr toExpr)
ArithSeqFromThenTo fromExpr thenExpr toExpr ->
brackets (prettyExpr fromExpr <> ", " <> prettyExpr thenExpr <> " .. " <> prettyExpr toExpr)
quoted :: Text -> Doc ann
quoted txt = pretty (show (T.unpack txt))
prettyQuasiQuote :: Text -> Text -> Doc ann
prettyQuasiQuote quoter body = "[" <> pretty quoter <> "|" <> prettyRawText body <> "|]"
-- ---------------------------------------------------------------------------
-- TypeFamilies pretty-printing helpers
prettyTypeFamilyDecl :: TypeFamilyDecl -> Doc ann
prettyTypeFamilyDecl tf =
hsep $
["type"]
<> familyKeywordPart (typeFamilyDeclExplicitFamilyKeyword tf)
<> prettyTypeFamilyHead (typeFamilyDeclHeadForm tf) (typeFamilyDeclHead tf) (typeFamilyDeclParams tf)
<> resultSigPart (typeFamilyDeclResultSig tf)
<> eqsPart (typeFamilyDeclEquations tf)
where
familyKeywordPart True = ["family"]
familyKeywordPart False = []
resultSigPart Nothing = []
resultSigPart (Just (TypeFamilyKindSig k)) = ["::", prettyType k]
resultSigPart (Just (TypeFamilyTyVarSig result)) = ["=", prettyTyVarBinder result]
resultSigPart (Just (TypeFamilyInjectiveSig result injectivity)) =
["=", prettyTyVarBinder result, "|", prettyTypeFamilyInjectivity injectivity]
eqsPart Nothing = []
eqsPart (Just []) = ["where", spacedBraces mempty]
eqsPart (Just eqs) = ["where" <> nest 2 (hardline <> hardVsep (map prettyTypeFamilyEq eqs))]
prettyTypeFamilyEq :: TypeFamilyEq -> Doc ann
prettyTypeFamilyEq eq =
hsep $
forallPart (typeFamilyEqForall eq)
<> prettyTypeFamilyLhs (typeFamilyEqHeadForm eq) (typeFamilyEqLhs eq)
<> ["=", prettyType (typeFamilyEqRhs eq)]
where
forallPart [] = []
forallPart binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]
prettyDataFamilyDecl :: DataFamilyDecl -> Doc ann
prettyDataFamilyDecl df =
hsep $
["data", "family"]
<> prettyNamedBinderHead (dataFamilyDeclHead df)
<> kindPart (dataFamilyDeclKind df)
where
kindPart Nothing = []
kindPart (Just k) = ["::", prettyType k]
prettyTopTypeFamilyInst :: TypeFamilyInst -> Doc ann
prettyTopTypeFamilyInst tfi =
hsep $
["type", "instance"]
<> forallPart (typeFamilyInstForall tfi)
<> prettyTypeFamilyLhs (typeFamilyInstHeadForm tfi) (typeFamilyInstLhs tfi)
<> ["=", prettyType (typeFamilyInstRhs tfi)]
where
forallPart [] = []
forallPart binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]
prettyTopDataFamilyInst :: DataFamilyInst -> Doc ann
prettyTopDataFamilyInst dfi =
case dataFamilyInstConstructors dfi of
ctors
| any isGadtCon ctors ->
headDoc <+> prettyGadtConBlock ctors (dataFamilyInstDeriving dfi)
_ ->
hsep $
headParts
<> ctorPart (dataFamilyInstConstructors dfi)
<> derivingParts (dataFamilyInstDeriving dfi)
where
keyword = if dataFamilyInstIsNewtype dfi then "newtype" else "data"
headParts =
[keyword, "instance"]
<> forallPart (dataFamilyInstForall dfi)
<> [prettyType (dataFamilyInstHead dfi)]
<> kindPart (dataFamilyInstKind dfi)
headDoc = hsep headParts
forallPart [] = []
forallPart binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]
kindPart Nothing = []
kindPart (Just k) = ["::", prettyType k]
ctorPart [] = []
ctorPart ctors@(c : _)
| dataFamilyInstIsNewtype dfi = ["=", prettyDataCon c]
| otherwise = ["=", hsep (punctuate " |" (map prettyDataCon ctors))]
prettyAssocTypeFamilyDecl :: TypeFamilyDecl -> Doc ann
prettyAssocTypeFamilyDecl tf =
hsep $
["type"]
<> familyKeywordPart (typeFamilyDeclExplicitFamilyKeyword tf)
<> prettyTypeFamilyHead (typeFamilyDeclHeadForm tf) (typeFamilyDeclHead tf) (typeFamilyDeclParams tf)
<> resultSigPart (typeFamilyDeclResultSig tf)
where
familyKeywordPart True = ["family"]
familyKeywordPart False = []
resultSigPart Nothing = []
resultSigPart (Just (TypeFamilyKindSig k)) = ["::", prettyType k]
resultSigPart (Just (TypeFamilyTyVarSig result)) = ["=", prettyTyVarBinder result]
resultSigPart (Just (TypeFamilyInjectiveSig result injectivity)) =
["=", prettyTyVarBinder result, "|", prettyTypeFamilyInjectivity injectivity]
prettyTypeFamilyHead :: TypeHeadForm -> Type -> [TyVarBinder] -> [Doc ann]
prettyTypeFamilyHead headForm headType params =
case headForm of
TypeHeadPrefix -> [prettyType headType] <> map prettyTyVarBinder params
TypeHeadInfix ->
case (params, typeFamilyInfixAppView headType) of
([lhs, rhs], Just (op, promoted, _, _)) ->
[ prettyTyVarBinder lhs,
(if promoted == Promoted then "'" else mempty) <> prettyNameInfixOp op,
prettyTyVarBinder rhs
]
_ -> [prettyTypeFamilyInfix headType]
prettyTypeFamilyLhs :: TypeHeadForm -> Type -> [Doc ann]
prettyTypeFamilyLhs headForm lhs =
case headForm of
TypeHeadPrefix -> [prettyType lhs]
TypeHeadInfix -> [prettyTypeFamilyInfix lhs]
prettyAssocDataFamilyDecl :: DataFamilyDecl -> Doc ann
prettyAssocDataFamilyDecl df =
hsep $
["data"]
<> prettyNamedBinderHead (dataFamilyDeclHead df)
<> kindPart (dataFamilyDeclKind df)
where
kindPart Nothing = []
kindPart (Just k) = ["::", prettyType k]
prettyDefaultTypeInst :: TypeFamilyInst -> Doc ann
prettyDefaultTypeInst tfi =
hsep $
["type", "instance"]
<> forallPart (typeFamilyInstForall tfi)
<> prettyTypeFamilyLhs (typeFamilyInstHeadForm tfi) (typeFamilyInstLhs tfi)
<> ["=", prettyType (typeFamilyInstRhs tfi)]
where
forallPart [] = []
forallPart binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]
prettyInstTypeFamilyInst :: TypeFamilyInst -> Doc ann
prettyInstTypeFamilyInst tfi =
hsep $
["type"]
<> forallPart (typeFamilyInstForall tfi)
<> prettyTypeFamilyLhs (typeFamilyInstHeadForm tfi) (typeFamilyInstLhs tfi)
<> ["=", prettyType (typeFamilyInstRhs tfi)]
where
forallPart [] = []
forallPart binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]
prettyNamedBinderHead :: BinderHead UnqualifiedName -> [Doc ann]
prettyNamedBinderHead head' =
case head' of
PrefixBinderHead name params ->
[prettyConstructorUName name] <> map prettyTyVarBinder params
InfixBinderHead lhs name rhs tailPrms ->
let infixHead = prettyTyVarBinder lhs <+> prettyTypeHeadInfixName name <+> prettyTyVarBinder rhs
in case tailPrms of
[] -> [infixHead]
_ -> parens infixHead : map prettyTyVarBinder tailPrms
prettyTypeHeadInfixName :: UnqualifiedName -> Doc ann
prettyTypeHeadInfixName = prettyInfixOp
prettyTypeFamilyInfix :: Type -> Doc ann
prettyTypeFamilyInfix ty =
case peelTypeAnn ty of
TParen inner -> parens (prettyType inner)
peeled ->
case typeFamilyInfixAppView peeled of
Just (op, promoted, lhs, rhs) ->
prettyType lhs
<+> (if promoted == Promoted then "'" else mempty)
<> prettyNameInfixOp op
<+> prettyType rhs
_ -> prettyType ty
prettyInstDataFamilyInst :: DataFamilyInst -> Doc ann
prettyInstDataFamilyInst dfi =
case dataFamilyInstConstructors dfi of
ctors
| any isGadtCon ctors ->
headDoc <+> prettyGadtConBlock ctors (dataFamilyInstDeriving dfi)
_ ->
hsep $
headParts
<> ctorPart (dataFamilyInstConstructors dfi)
<> derivingParts (dataFamilyInstDeriving dfi)
where
keyword = if dataFamilyInstIsNewtype dfi then "newtype" else "data"
headParts =
[keyword, prettyType (dataFamilyInstHead dfi)]
<> kindPart (dataFamilyInstKind dfi)
headDoc = hsep headParts
kindPart Nothing = []
kindPart (Just k) = ["::", prettyType k]
ctorPart [] = []
ctorPart ctors@(c : _)
| dataFamilyInstIsNewtype dfi = ["=", prettyDataCon c]
| otherwise = ["=", hsep (punctuate " |" (map prettyDataCon ctors))]