Commit 2126f7a8 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Mainly tidying up pretty printing of types

including (a) centralising Outputable.paBrackets
          (b) printing the quote on promoted TyCon/DataCon
parent 7f79d0c7
......@@ -473,7 +473,7 @@ ppr_expr (ExplicitList _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (ExplicitPArr _ exprs)
= pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
= paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (RecordCon con_id _ rbinds)
= hang (ppr con_id) 2 (ppr rbinds)
......@@ -489,7 +489,7 @@ ppr_expr (ExprWithTySigOut expr sig)
4 (ppr sig)
ppr_expr (ArithSeq _ info) = brackets (ppr info)
ppr_expr (PArrSeq _ info) = pa_brackets (ppr info)
ppr_expr (PArrSeq _ info) = paBrackets (ppr info)
ppr_expr EWildPat = char '_'
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
......@@ -554,11 +554,6 @@ pprCmdArg (HsCmdTop cmd _ _ _)
instance OutputableBndr id => Outputable (HsCmdTop id) where
ppr = pprCmdArg
-- add parallel array brackets around a document
--
pa_brackets :: SDoc -> SDoc
pa_brackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\end{code}
HsSyn records exactly where the user put parens, with HsPar.
......@@ -1132,7 +1127,7 @@ pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts
pprDo ListComp stmts = brackets $ pprComp stmts
pprDo PArrComp stmts = pa_brackets $ pprComp stmts
pprDo PArrComp stmts = paBrackets $ pprComp stmts
pprDo MonadComp stmts = brackets $ pprComp stmts
pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
......
......@@ -246,7 +246,7 @@ pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat]
pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
pprPat (ParPat pat) = parens (ppr pat)
pprPat (ListPat pats _) = brackets (interpp'SP pats)
pprPat (PArrPat pats _) = pabrackets (interpp'SP pats)
pprPat (PArrPat pats _) = paBrackets (interpp'SP pats)
pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
pprPat (ConPatIn con details) = pprUserCon con details
......@@ -292,11 +292,6 @@ instance (OutputableBndr id, Outputable arg)
ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
hsRecPun = pun })
= ppr f <+> (ppUnless pun $ equals <+> ppr arg)
-- add parallel array brackets around a document
--
pabrackets :: SDoc -> SDoc
pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\end{code}
......
......@@ -560,7 +560,7 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
_ -> BoxedTuple
ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind)
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
......@@ -613,10 +613,6 @@ ppr_fun_ty ctxt_prec ty1 ty2
in
maybeParen ctxt_prec pREC_FUN $
sep [p1, ptext (sLit "->") <+> p2]
--------------------------
pabrackets :: SDoc -> SDoc
pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\end{code}
......@@ -283,7 +283,7 @@ ppr_tc_app _ tc [] = ppr_tc tc
ppr_tc_app _ IfaceListTc [ty] = brackets (pprIfaceType ty)
ppr_tc_app _ IfaceListTc _ = panic "ppr_tc_app IfaceListTc"
ppr_tc_app _ IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
ppr_tc_app _ IfacePArrTc [ty] = paBrackets (pprIfaceType ty)
ppr_tc_app _ IfacePArrTc _ = panic "ppr_tc_app IfacePArrTc"
ppr_tc_app _ (IfaceTupTc sort _) tys =
......@@ -326,10 +326,6 @@ pprIfaceContext theta = ppr_preds theta <+> darrow
ppr_preds :: [IfacePredType] -> SDoc
ppr_preds [pred] = ppr pred -- No parens
ppr_preds preds = parens (sep (punctuate comma (map ppr preds)))
-------------------
pabrackets :: SDoc -> SDoc
pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\end{code}
%************************************************************************
......
......@@ -597,47 +597,47 @@ pprTcApp _ _ tc [] -- No brackets for SymOcc
| otherwise = empty
pprTcApp _ pp tc [ty]
| tc `hasKey` listTyConKey = brackets (pp TopPrec ty)
| tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pp TopPrec ty <> ptext (sLit ":]")
| tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*")
| tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
| tc `hasKey` openTypeKindTyConKey = ptext (sLit "OpenKind")
| tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)")
| tc `hasKey` argTypeKindTyConKey = ptext (sLit "ArgKind")
| Just n <- tyConIP_maybe tc = ppr n <> ptext (sLit "::") <> pp TopPrec ty
| tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty)
| tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
| Just n <- tyConIP_maybe tc = ppr n <> ptext (sLit "::") <> pp TopPrec ty
pprTcApp p pp tc tys
| isTupleTyCon tc && tyConArity tc == length tys
= tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys)))
= pprPromotionQuote tc <>
tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys)))
| tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because
-- its not a SymOcc so won't get printed infix
, [_, ty1,ty2] <- tys
= pprInfixApp p pp (getName tc) ty1 ty2
, [_, ty1,ty2] <- tys -- with kind polymorphism it has 3 args, so won't get printed infix
= pprInfixApp p pp (ppr tc) ty1 ty2
| otherwise
= pprTypeNameApp p pp (getName tc) tys
= ppr_type_name_app p pp (ppr tc) (isSymOcc (getOccName tc)) tys
----------------
pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
-- The first arg is the tycon, or sometimes class
-- Print infix if the tycon/class looks like an operator
pprTypeApp tc tys = pprTypeNameApp TopPrec ppr_type (getName tc) tys
pprTypeApp tc tys
= pprTypeNameApp TopPrec ppr_type (getName tc) tys
pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc
-- Used for classes and coercions as well as types; that's why it's separate from pprTcApp
pprTypeNameApp p pp tc tys
pprTypeNameApp p pp name tys
= ppr_type_name_app p pp (ppr name) (isSymOcc (getOccName name)) tys
ppr_type_name_app :: Prec -> (Prec -> a -> SDoc) -> SDoc -> Bool -> [a] -> SDoc
ppr_type_name_app p pp pp_tc is_sym_occ tys
| is_sym_occ -- Print infix if possible
, [ty1,ty2] <- tys -- We know nothing of precedence though
= pprInfixApp p pp tc ty1 ty2
= pprInfixApp p pp pp_tc ty1 ty2
| otherwise
= pprPrefixApp p (pprPrefixVar is_sym_occ (ppr tc)) (map (pp TyConPrec) tys)
where
is_sym_occ = isSymOcc (getOccName tc)
= pprPrefixApp p (pprPrefixVar is_sym_occ pp_tc) (map (pp TyConPrec) tys)
----------------
pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> Name -> a -> a -> SDoc
pprInfixApp p pp tc ty1 ty2
pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> SDoc -> a -> a -> SDoc
pprInfixApp p pp pp_tc ty1 ty2
= maybeParen p FunPrec $
sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2]
sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2]
pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc
pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $
......
......@@ -23,7 +23,8 @@ module Outputable (
char,
text, ftext, ptext,
int, intWithCommas, integer, float, double, rational,
parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets,
parens, cparen, brackets, braces, quotes, quote,
doubleQuotes, angleBrackets, paBrackets,
semi, comma, colon, dcolon, space, equals, dot, arrow, darrow,
lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
blankLine,
......@@ -444,27 +445,31 @@ float n = docToSDoc $ Pretty.float n
double n = docToSDoc $ Pretty.double n
rational n = docToSDoc $ Pretty.rational n
parens, braces, brackets, quotes, quote, doubleQuotes, angleBrackets :: SDoc -> SDoc
parens, braces, brackets, quotes, quote,
paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
parens d = SDoc $ Pretty.parens . runSDoc d
braces d = SDoc $ Pretty.braces . runSDoc d
brackets d = SDoc $ Pretty.brackets . runSDoc d
quote d = SDoc $ Pretty.quote . runSDoc d
doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
parens d = SDoc $ Pretty.parens . runSDoc d
braces d = SDoc $ Pretty.braces . runSDoc d
brackets d = SDoc $ Pretty.brackets . runSDoc d
quote d = SDoc $ Pretty.quote . runSDoc d
doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
angleBrackets d = char '<' <> d <> char '>'
paBrackets d = ptext (sLit "[:") <> d <> ptext (sLit ":]")
cparen :: Bool -> SDoc -> SDoc
cparen b d = SDoc $ Pretty.cparen b . runSDoc d
-- 'quotes' encloses something in single quotes...
-- but it omits them if the thing ends in a single quote
-- but it omits them if the thing begins or ends in a single quote
-- so that we don't get `foo''. Instead we just have foo'.
quotes d = SDoc $ \sty ->
let pp_d = runSDoc d sty in
case snocView (show pp_d) of
Just (_, '\'') -> pp_d
_other -> Pretty.quotes pp_d
let pp_d = runSDoc d sty
str = show pp_d
in case (str, snocView str) of
(_, Just (_, '\'')) -> pp_d
('\'' : _, _) -> pp_d
_other -> Pretty.quotes pp_d
semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment