Mainly tidying up pretty printing of types

including (a) centralising Outputable.paBrackets
          (b) printing the quote on promoted TyCon/DataCon

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 1dd3c83..08d1281 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -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
 

diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 3180d24..2241d7b 100644 (file)
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -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}
 
 

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index accb3dd..acd4df9 100644 (file)
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -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}
 
 

diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index b421e42..4329ad2 100644 (file)
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -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}
 
 %************************************************************************

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 26526ab..3bc1b23 100644 (file)
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -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 $

diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 248f549..b713896 100644 (file)
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -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