aihc-parser-1.0.0.2: 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,
comma,
hang,
hardline,
hsep,
indent,
nest,
nesting,
parens,
punctuate,
semi,
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
-- | 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) (pretty raw)
| otherwise = pretty raw
prettySpliceBody :: Expr -> Doc ann
prettySpliceBody = nest 2 . 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 = vsep (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 =
vsep (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 (hsep (punctuate comma (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 (hsep (punctuate comma (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
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]
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 = map (nest 2) $
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 =
hang 2 $
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" <> hardline <> indent 2 (vsep (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)
: map
(indent 2)
( 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 ->
"="
<+> nest 4 (prettyExpr body)
<> prettyIndentedWhereClause whereDecls
GuardedRhss _ guards whereDecls ->
hardline <> indent 2 (prettyGuardedRhssBlock guards whereDecls)
prettyWhereClauseBare :: Maybe [Decl] -> Doc ann
prettyWhereClauseBare Nothing = mempty
prettyWhereClauseBare (Just []) = "where" <+> spacedBraces mempty
prettyWhereClauseBare (Just decls) =
"where" <> hardline <> indent 2 (vsep (concatMap prettyDeclLines decls))
prettyIndentedWhereClause :: Maybe [Decl] -> Doc ann
prettyIndentedWhereClause Nothing = mempty
prettyIndentedWhereClause whereDecls = hardline <> indent 2 (prettyWhereClauseBare whereDecls)
prettyTHDeclQuote :: [Decl] -> Doc ann
prettyTHDeclQuote [] =
hang 2 $
"[d|"
<> hardline
<> "|]"
prettyTHDeclQuote decls =
hang 2 $
"[d|"
<> hardline
<> vsep (concatMap prettyDeclLines decls)
<> hardline
<> "|]"
-- | 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 -> prettyTypeBuiltinCon con
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 ->
prettyType a <+> prettyArrowKind arrowKind <+> prettyType 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 -> prettyContext cs <+> "=>" <+> prettyType inner
TSplice body -> "$" <> prettySpliceBody body
TWildcard -> "_"
prettyArrowKind :: ArrowKind -> Doc ann
prettyArrowKind ArrowUnrestricted = "->"
prettyArrowKind ArrowLinear = "%1" <+> "->"
prettyArrowKind (ArrowExplicit ty) = "%" <> prettyType ty <+> "->"
prettyTypeBuiltinCon :: TypeBuiltinCon -> Doc ann
prettyTypeBuiltinCon con =
case con of
TBuiltinTuple arity -> parens (pretty (T.replicate (max 0 (arity - 1)) ","))
TBuiltinArrow -> "(->)"
TBuiltinList -> "[]"
TBuiltinCons -> "(:)"
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)
PInfix lhs op rhs -> prettyPattern lhs <+> prettyNameInfixOp op <+> prettyPattern rhs
PView viewExpr inner ->
prettyExpr viewExpr <> hardline <> indent 1 ("->" <+> prettyPattern inner)
PAs name inner -> prettyBinderUName name <> "@" <> prettyPattern inner
PStrict inner -> "!" <> prettyPattern inner
PIrrefutable inner -> "~" <> prettyPattern inner
PNegLit lit -> "-" <> 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)
_ ->
hsep (headParts <> ctorPart <> derivingParts (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)
ctorPart =
case dataDeclConstructors decl of
[] -> []
ctors -> ["=", hsep (punctuate " |" (map prettyDataCon ctors))]
prettyTypeDataDecl :: DataDecl -> Doc ann
prettyTypeDataDecl decl =
case dataDeclConstructors decl of
ctors
| any isGadtCon ctors -> headDoc <+> prettyGadtConBlock ctors []
_ -> hsep (headParts <> ctorPart)
where
headParts =
["type data"]
<> prettyDeclBinderHead (dataDeclContext decl) (dataDeclHead decl)
<> kindPart
headDoc = hsep headParts
kindPart = maybe [] (\k -> ["::", prettyType k]) (dataDeclKind decl)
ctorPart =
case dataDeclConstructors decl of
[] -> []
ctors -> ["=", hsep (punctuate " |" (map prettyDataCon ctors))]
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)
_ ->
hsep (headParts <> ctorPart <> derivingParts (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)
ctorPart =
case newtypeDeclConstructor decl of
Nothing -> []
Just ctor -> ["=", prettyDataCon ctor]
derivingParts :: [DerivingClause] -> [Doc ann]
derivingParts = concatMap derivingPart
prettyGadtConBlock :: [DataConDecl] -> [DerivingClause] -> Doc ann
prettyGadtConBlock ctors derivingClauses =
"where"
<> hardline
<> indent 2 (vsep (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
_ ->
hsep $
concatMap (\(bt, ak) -> [prettyBangType bt, prettyArrowKind ak]) args
++ [prettyType resultTy]
GadtRecordBody fields resultTy ->
braces (prettyRecordFields fields) <+> "->" <+> prettyType resultTy
prettyRecordFields :: [FieldDecl] -> Doc ann
prettyRecordFields fields =
hsep
( punctuate
comma
[ 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 =
hsep
( ["class"]
<> maybeContextPrefix (classDeclContext decl)
<> prettyNamedBinderHead (classDeclHead decl)
<> prettyClassFundeps (classDeclFundeps decl)
)
in case classDeclItems decl of
[] -> headDoc
items ->
headDoc
<+> "where"
<> hardline
<> indent 2 (vsep (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))
]
maybeContextPrefix :: Maybe [Type] -> [Doc ann]
maybeContextPrefix maybeConstraints =
case maybeConstraints of
Nothing -> []
Just constraints -> [prettyContext constraints, "=>"]
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)
<> contextPrefix (instanceDeclContext decl)
<> [prettyType (instanceDeclHead decl)]
)
in case instanceDeclItems decl of
[] -> headDoc
items ->
headDoc
<+> "where"
<> hardline
<> indent 2 (vsep (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)) = pretty (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 -> pretty 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\n (x\n + 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 ->
prettyExpr fn <> hardline <> " " <> prettyTypeAppArg ty
EVar name -> prettyName 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 ->
"if" <+> nest 2 (prettyExpr cond <+> "then" <+> prettyExpr yes <+> "else" <+> prettyExpr no)
EMultiWayIf rhss ->
"if" <+> hang 3 (prettyMultiWayIfRhss rhss)
ELambdaPats pats body ->
"\\" <+> hsep (map prettyPattern pats) <+> "->" <+> nest 2 (prettyExpr body)
ELambdaCase alts ->
"\\" <> "case" <> prettyCaseLayout (map prettyCaseAlt alts)
ELambdaCases alts ->
"\\" <> "cases" <> prettyCaseLayout (map prettyLambdaCaseAlt alts)
EInfix lhs op rhs ->
prettyExpr lhs <> hardline <> prettyNameInfixOp op <+> prettyExpr rhs
ENegate inner -> "-" <+> prettyExprAtStatementStart inner
ESectionL lhs op ->
prettyExpr lhs <> hardline <> " " <> prettyNameInfixOp op
ESectionR op rhs -> prettyNameInfixOp op <+> prettyExpr rhs
ELetDecls decls body ->
case decls of
[] -> prettyLetDecls decls <+> "in" <+> prettyExpr body
_ -> align (prettyLetDecls decls <> hardline <> indent 2 ("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 prettyExpr body <> hardline <> " |" <+> qualifiers
)
EListCompParallel body qualifierGroups ->
brackets
( let qualifiers =
prettyBarSeparated
[ prettyCommaSeparated prettyCompStmt group
| group <- qualifierGroups
]
in prettyExpr body <> hardline <> " |" <+> qualifiers
)
EArithSeq seqInfo -> prettyArithSeq seqInfo
ERecordCon name fields hasWildcard ->
prettyPrefixName name <+> braces (hsep (punctuate comma (map prettyBinding fields ++ [".." | hasWildcard])))
ERecordUpd base fields ->
prettyExpr base <+> braces (hsep (punctuate comma (map prettyBinding fields)))
EGetField base field ->
prettyExpr base <> "." <> prettyName field
EGetFieldProjection fields ->
"." <> mconcat (punctuate "." (map prettyName fields))
ETypeSig inner ty ->
align (prettyExpr inner <> hardline <> "::" <+> prettyType ty)
EParen inner -> case inner of
ECase scrutinee alts ->
parens (prettyCaseExpr prettyCaseLayoutAligned 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 <+> "->" <+> nest 2 (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 vsep (prettyFn fn : map (indent 2 . prettyExpr) args)
where
flattenApps = go []
go args (EAnn _ sub) = go args sub
go args (EApp fn arg) = go (arg : args) fn
go args root = (root, args)
prettyCommaSeparated :: (a -> Doc ann) -> [a] -> Doc ann
prettyCommaSeparated render items =
case map render items of
[] -> mempty
rendered -> hang 2 (vsep (punctuate comma rendered))
prettyBarSeparated :: [Doc ann] -> Doc ann
prettyBarSeparated items =
case items of
[] -> mempty
firstItem : restItems -> hang 2 (vsep (firstItem : map ("|" <+>) restItems))
prettyTupleBody :: TupleFlavor -> Doc ann -> Doc ann
prettyTupleBody tupleFlavor inner =
case tupleFlavor of
Boxed -> parens inner
Unboxed -> hsep ["(#", inner, "#)"]
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) = nest 2 $
case rhs of
UnguardedRhs _ body whereDecls ->
prettyPattern pat
<+> "->"
<> hardline
<> indent 2 (prettyBody body)
<> prettyIndentedWhereClause whereDecls
GuardedRhss _ grhss whereDecls ->
prettyPattern pat
<> hardline
<> indent 2 (vsep (map (prettyCaseGuardedRhsBlock 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 "|"
<+> prettyGuardQualifiersLayout guards
<> hardline
<> " "
<> pretty arrow
<> hardline
<> indent 2 (prettyExpr body)
prettyCaseGuardedRhsBlock :: (body -> Doc ann) -> GuardedRhs body -> Doc ann
prettyCaseGuardedRhsBlock prettyBody grhs =
let guards = guardedRhsGuards grhs
body = guardedRhsBody grhs
in "|"
<+> prettyGuardQualifiersLayout guards
<> hardline
<> " "
<> "->"
<> hardline
<> indent 2 (prettyBody body)
prettyMultiWayIfRhss :: [GuardedRhs Expr] -> Doc ann
prettyMultiWayIfRhss rhss = vsep (map (prettyGuardedRhsBodyBlock "->") rhss)
prettyGuardQualifiersLayout :: [GuardQualifier] -> Doc ann
prettyGuardQualifiersLayout qualifiers =
case map prettyGuardQualifier qualifiers of
[] -> mempty
firstQualifier : restQualifiers ->
vsep (firstQualifier : map (indent 2 . (comma <+>)) restQualifiers)
prettyCaseExpr :: ([Doc ann] -> Doc ann) -> Expr -> [CaseAlt Expr] -> Doc ann
prettyCaseExpr layout scrutinee alts =
"case"
<+> nest 2 (prettyExpr scrutinee)
<+> "of"
<> layout (map prettyCaseAlt alts)
prettyCaseLayout :: [Doc ann] -> Doc ann
prettyCaseLayout [] = " " <> spacedBraces mempty
prettyCaseLayout alts = nest 2 (hardline <> vsep alts)
prettyCaseLayoutAligned :: [Doc ann] -> Doc ann
prettyCaseLayoutAligned [] = " " <> spacedBraces mempty
prettyCaseLayoutAligned alts = hang 2 (hardline <> vsep alts)
prettyLambdaCaseAlt :: LambdaCaseAlt -> Doc ann
prettyLambdaCaseAlt (LambdaCaseAlt _ pats rhs) = nest 2 $
case rhs of
UnguardedRhs _ body whereDecls ->
hsep (map prettyPattern pats)
<+> "->"
<> hardline
<> indent 2 (prettyExpr body)
<> prettyIndentedWhereClause whereDecls
GuardedRhss _ grhss whereDecls ->
hsep (map prettyPattern pats)
<> hardline
<> indent 2 (vsep (map (prettyCaseGuardedRhsBlock 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
GuardLet decls -> prettyLetDecls decls
prettyLetDecls :: [Decl] -> Doc ann
prettyLetDecls decls
| null decls = "let" <+> spacedBraces mempty
| otherwise =
"let" <+> hang 0 (vsep (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 -> vsep rendered
prettyDoStmt :: DoStmt Expr -> Doc ann
prettyDoStmt stmt =
case stmt of
DoAnn _ inner -> prettyDoStmt inner
DoBind pat expr -> prettyPattern pat <+> "<-" <+> nest 2 (prettyExpr expr)
DoLetDecls decls -> prettyLetDecls decls
--
DoExpr expr -> hang 2 (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 -> prettyExprAtStatementStart fn <> hardline <> " " <> prettyTypeAppArg ty
EInfix lhs op rhs -> prettyExprAtStatementStart lhs <> hardline <> prettyNameInfixOp op <+> prettyExpr rhs
ESectionL lhs op -> prettyExprAtStatementStart lhs <> hardline <> " " <> prettyNameInfixOp op
ETypeSig inner ty -> prettyExprAtStatementStart inner <> hardline <> indent 2 ("::" <+> prettyType ty)
ERecordUpd base fields ->
prettyExprAtStatementStart base <+> braces (hsep (punctuate comma (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 = nest 2 $
case cmd of
CmdArrApp lhs HsFirstOrderApp rhs ->
prettyExpr lhs <+> "-<" <+> prettyExpr rhs
CmdArrApp lhs HsHigherOrderApp rhs ->
prettyExpr lhs <+> "-<<" <+> prettyExpr rhs
CmdInfix l op r ->
prettyCmd l <> hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r
CmdDo stmts ->
"do" <> prettyDoLayout prettyCmdStmt stmts
CmdIf cond yes no ->
"if" <+> prettyExpr cond <+> "then" <+> prettyCmd yes <+> "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
_ -> align (prettyLetDecls decls <> hardline <> "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 = nest 2 $
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 ->
prettyCmdAtStatementStart l <> hardline <> " " <> 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 =
vsep (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 "|"
<+> nest
2
( prettyGuardQualifiersLayout guards
<> hardline
<> "="
<+> nest 2 (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" <> hardline <> indent 2 (vsep (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))]