Tidy up pretty-printing for variables

We already have a class OutputableBndr; this patch adds
methods pprInfixOcc and pprPrefixOcc, so that we can get
rid of the hideous hack (the old) Outputable.pprHsVar.

The hack was exposed by Trac #5657, which is thereby fixed.

compiler/basicTypes/Name.lhs

@@ -430,6 +430,9 @@ instance Outputable Name where
 
 instance OutputableBndr Name where
     pprBndr _ name = pprName name
+    pprInfixOcc  = pprInfixName
+    pprPrefixOcc = pprPrefixName
+
 
 pprName :: Name -> SDoc
 pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ})

compiler/basicTypes/RdrName.lhs

@@ -273,6 +273,9 @@ instance OutputableBndr RdrName where
 	| isTvOcc (rdrNameOcc n) = char '@' <+> ppr n
 	| otherwise		 = ppr n
 
+    pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
+    pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
+
 showRdrName :: RdrName -> String
 showRdrName r = showSDoc (ppr r)
 

compiler/coreSyn/CoreSyn.lhs

@@ -992,6 +992,8 @@ instance Outputable b => Outputable (TaggedBndr b) where
 
 instance Outputable b => OutputableBndr (TaggedBndr b) where
   pprBndr _ b = ppr b	-- Simple
+  pprInfixOcc  b = ppr b
+  pprPrefixOcc b = ppr b
 \end{code}
 
 

compiler/coreSyn/PprCore.lhs

@@ -21,6 +21,7 @@ module PprCore (
 
 import CoreSyn
 import Literal( pprLiteral )
+import Name( pprInfixName, pprPrefixName )
 import Var
 import Id
 import IdInfo
@@ -268,6 +269,8 @@ and @pprCoreExpr@ functions.
 \begin{code}
 instance OutputableBndr Var where
   pprBndr = pprCoreBinder
+  pprInfixOcc  = pprInfixName  . varName
+  pprPrefixOcc = pprPrefixName . varName
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder

compiler/hsSyn/HsDecls.lhs

@@ -802,8 +802,8 @@ pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
                     , con_res = ResTyH98, con_doc = doc })
   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
   where
-    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
-    ppr_details (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
+    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2]
+    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc (unLoc con) : map ppr tys)
     ppr_details (RecCon fields)  = ppr con <+> pprConDeclFields fields
 
 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs

compiler/hsSyn/HsExpr.lhs

@@ -379,7 +379,7 @@ ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
 ppr_lexpr e = ppr_expr (unLoc e)
 
 ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc
-ppr_expr (HsVar v)       = pprHsVar v
+ppr_expr (HsVar v)       = pprPrefixOcc v
 ppr_expr (HsIPVar v)     = ppr v
 ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
@@ -407,7 +407,7 @@ ppr_expr (OpApp e1 op _ e2)
       = hang (ppr op) 2 (sep [pp_e1, pp_e2])
 
     pp_infixly v
-      = sep [pp_e1, sep [pprHsInfix v, nest 2 pp_e2]]
+      = sep [pp_e1, sep [pprInfixOcc v, nest 2 pp_e2]]
 
 ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
 
@@ -420,7 +420,7 @@ ppr_expr (SectionL expr op)
 
     pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
                        4 (hsep [pp_expr, ptext (sLit "x_ )")])
-    pp_infixly v = (sep [pp_expr, pprHsInfix v])
+    pp_infixly v = (sep [pp_expr, pprInfixOcc v])
 
 ppr_expr (SectionR op expr)
   = case unLoc op of
@@ -431,7 +431,7 @@ ppr_expr (SectionR op expr)
 
     pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
                        4 ((<>) pp_expr rparen)
-    pp_infixly v = sep [pprHsInfix v, pp_expr]
+    pp_infixly v = sep [pprInfixOcc v, pp_expr]
 
 ppr_expr (ExplicitTuple exprs boxity)
   = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs))
@@ -541,7 +541,7 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
   = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
 
 ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
-  = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]]
+  = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
 ppr_expr (HsArrForm op _ args)
   = hang (ptext (sLit "(|") <> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))

compiler/hsSyn/HsImpExp.lhs

@@ -57,7 +57,7 @@ simpleImportDecl mn = ImportDecl {
 \end{code}
 
 \begin{code}
-instance (Outputable name) => Outputable (ImportDecl name) where
+instance (OutputableBndr name) => Outputable (ImportDecl name) where
     ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg
                     , ideclSource = from, ideclSafe = safe
                     , ideclQualified = qual, ideclImplicit = implicit
@@ -134,12 +134,12 @@ ieNames (IEDocNamed       _   ) = []
 \end{code}
 
 \begin{code}
-instance (Outputable name) => Outputable (IE name) where
-    ppr (IEVar          var)    = pprHsVar var
+instance (OutputableBndr name, Outputable name) => Outputable (IE name) where
+    ppr (IEVar          var)    = pprPrefixOcc var
     ppr (IEThingAbs     thing)  = ppr thing
     ppr (IEThingAll     thing)  = hcat [ppr thing, text "(..)"]
     ppr (IEThingWith thing withs)
-        = pprHsVar thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
+        = pprPrefixOcc thing <> parens (fsep (punctuate comma (map pprPrefixOcc withs)))
     ppr (IEModuleContents mod')
         = ptext (sLit "module") <+> ppr mod'
     ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")

compiler/typecheck/TcHsSyn.lhs

@@ -424,7 +424,7 @@ warnMissingSig msg id
         ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
         ; addWarnTcM (env1, mk_msg tidy_ty) }
   where
-    mk_msg ty = sep [ msg, nest 2 $ pprHsVar (idName id) <+> dcolon <+> ppr ty ]
+    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
 
 ---------------------------------------------
 zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id)

compiler/types/TypeRep.lhs

@@ -511,7 +511,9 @@ instance Outputable Type where
     ppr ty = pprType ty
 
 instance Outputable name => OutputableBndr (IPName name) where
-    pprBndr _ n = ppr n	-- Simple for now
+    pprBndr _ n   = ppr n	-- Simple for now
+    pprInfixOcc  n = ppr n 
+    pprPrefixOcc n = ppr n 
 
 ------------------
 	-- OK, here's the main printer

compiler/utils/Outputable.lhs

@@ -48,7 +48,7 @@ module Outputable (
         renderWithStyle,
 
         pprInfixVar, pprPrefixVar,
-        pprHsChar, pprHsString, pprHsInfix, pprHsVar,
+        pprHsChar, pprHsString, 
         pprFastFilePath,
 
         -- * Controlling the style in which output is printed
@@ -743,6 +743,11 @@ data BindingSite = LambdaBind | CaseBind | LetBind
 class Outputable a => OutputableBndr a where
    pprBndr :: BindingSite -> a -> SDoc
    pprBndr _b x = ppr x
+
+   pprPrefixOcc, pprInfixOcc :: a -> SDoc
+      -- Print an occurrence of the name, suitable either in the 
+      -- prefix position of an application, thus   (f a b) or  ((+) x)
+      -- or infix position,                 thus   (a `f` b) or  (x + y)
 \end{code}
 
 %************************************************************************
@@ -777,27 +782,6 @@ pprInfixVar is_operator pp_v
   | otherwise   = char '`' <> pp_v <> char '`'
 
 ---------------------
--- pprHsVar and pprHsInfix use the gruesome isOperator, which
--- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
--- Reason: it means that pprHsVar doesn't need a NamedThing context,
---         which none of the HsSyn printing functions do
-pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
-pprHsVar   v = pprPrefixVar (isOperator pp_v) pp_v
-             where pp_v = ppr v
-pprHsInfix v = pprInfixVar  (isOperator pp_v) pp_v
-             where pp_v = ppr v
-
-isOperator :: SDoc -> Bool
-isOperator ppr_v
-  = case showSDocUnqual ppr_v of
-        ('(':_)   -> False              -- (), (,) etc
-        ('[':_)   -> False              -- []
-        ('$':c:_) -> not (isAlpha c)    -- Don't treat $d as an operator
-        (':':c:_) -> not (isAlpha c)    -- Don't treat :T as an operator
-        ('_':_)   -> False              -- Not an operator
-        (c:_)     -> not (isAlpha c)    -- Starts with non-alpha
-        _         -> False
-
 pprFastFilePath :: FastString -> SDoc
 pprFastFilePath path = text $ normalise $ unpackFS path
 \end{code}