Fix the bug part of Trac #1930

compiler/basicTypes/Name.lhs

@@ -32,7 +32,8 @@ module Name (
 	
 	-- Class NamedThing and overloaded friends
 	NamedThing(..),
-	getSrcLoc, getSrcSpan, getOccString
+	getSrcLoc, getSrcSpan, getOccString,
+ 	pprInfixName, pprPrefixName
     ) where
 
 import {-# SOURCE #-} TypeRep( TyThing )
@@ -422,5 +423,11 @@ getOccString	    :: NamedThing a => a -> String
 getSrcLoc	    = nameSrcLoc	   . getName
 getSrcSpan	    = nameSrcSpan	   . getName
 getOccString 	    = occNameString	   . getOccName
+
+pprInfixName, pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc
+-- See Outputable.pprPrefixVar, pprInfixVar; 
+-- add parens or back-quotes as appropriate
+pprInfixName  n = pprInfixVar  (isSymOcc (getOccName n)) (ppr n)
+pprPrefixName n = pprPrefixVar (isSymOcc (getOccName n)) (ppr n)
 \end{code}
 

compiler/hsSyn/HsDecls.lhs

@@ -43,7 +43,6 @@ import {-# SOURCE #-}	HsExpr( HsExpr, pprExpr )
 
 import HsBinds
 import HsPat
-import HsImpExp
 import HsTypes
 import HsDoc
 import NameSet
@@ -712,7 +711,7 @@ pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
 pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
   where
-    ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsVar con, ppr t2]
+    ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
     ppr_details con (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
     ppr_details con (RecCon fields)  = ppr con <+> ppr_fields fields
 

compiler/hsSyn/HsExpr.lhs

@@ -15,7 +15,6 @@ import HsDecls
 import HsPat
 import HsLit
 import HsTypes
-import HsImpExp
 import HsBinds
 
 -- others:
@@ -346,7 +345,7 @@ ppr_expr (OpApp e1 op _ e2)
       = hang (ppr op) 2 (sep [pp_e1, pp_e2])
 
     pp_infixly v
-      = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2]
+      = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2]
 
 ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
 
@@ -359,7 +358,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, pprInfix v])
+    pp_infixly v = (sep [pp_expr, pprHsInfix v])
 
 ppr_expr (SectionR op expr)
   = case unLoc op of
@@ -371,7 +370,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 [pprInfix v, pp_expr])
+      = (sep [pprHsInfix v, pp_expr])
 
 --avoid using PatternSignatures for stage1 code portability
 ppr_expr exprType@(HsLam matches)
@@ -477,7 +476,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 [pprInfix v, pprCmdArg (unLoc arg2)]]
+  = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]]
 ppr_expr (HsArrForm op _ args)
   = hang (ptext (sLit "(|") <> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
@@ -491,12 +490,6 @@ pprCmdArg (HsCmdTop cmd _ _ _)
 instance OutputableBndr id => Outputable (HsCmdTop id) where
     ppr = pprCmdArg
 
--- Put a var in backquotes if it's not an operator already
-pprInfix :: Outputable name => name -> SDoc
-pprInfix v | isOperator ppr_v = ppr_v
-           | otherwise        = char '`' <> ppr_v <> char '`'
-    where ppr_v = ppr v
-
 -- add parallel array brackets around a document
 --
 pa_brackets :: SDoc -> SDoc

compiler/hsSyn/HsImpExp.lhs

@@ -21,7 +21,6 @@ import HsDoc		( HsDoc )
 import Outputable
 import FastString
 import SrcLoc		( Located(..) )
-import Char		( isAlpha )
 \end{code}
 
 %************************************************************************
@@ -120,25 +119,4 @@ instance (Outputable name) => Outputable (IE name) where
     ppr (IEDocNamed string)     = text ("<IEDocNamed: " ++ string ++ ">")
 \end{code}
 
-\begin{code}
-pprHsVar :: Outputable name => name -> SDoc
-pprHsVar v | isOperator ppr_v = parens ppr_v
-	   | otherwise	      = ppr_v
-	   where
-	     ppr_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
-    -- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so
-    -- that we don't need NamedThing in the context of all these functions.
-    -- Gruesome, but simple.
-\end{code}
 

compiler/main/PprTyThing.hs

@@ -76,7 +76,7 @@ pprTyThingHdr pefas (AClass cls)       = pprClassHdr   pefas cls
 pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
 pprTyConHdr _ tyCon
   | Just (_fam_tc, tys) <- tyConFamInst_maybe tyCon
-  = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp tyCon (ppr_bndr tyCon) tys
+  = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp tyCon tys
   | otherwise
   = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
   where
@@ -212,7 +212,7 @@ pprDataConDecl _ gadt_style show_label dataCon
 
     ppr_fields [ty1, ty2]
 	| GHC.dataConIsInfix dataCon && null labels
-	= sep [pprParendBangTy ty1, ppr dataCon, pprParendBangTy ty2]
+	= sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2]
     ppr_fields fields
 	| null labels
 	= ppr_bndr dataCon <+> sep (map pprParendBangTy fields)

compiler/typecheck/TcDeriv.lhs

@@ -537,7 +537,7 @@ tcLookupFamInstExact tycon tys
 famInstNotFound :: TyCon -> [Type] -> TcM a
 famInstNotFound tycon tys 
   = failWithTc (ptext (sLit "No family instance for")
-			<+> quotes (pprTypeApp tycon (ppr tycon) tys))
+			<+> quotes (pprTypeApp tycon tys))
 \end{code}
 
 

compiler/types/FamInstEnv.lhs

@@ -94,7 +94,7 @@ pprFamInstHdr :: FamInst -> SDoc
 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
   = pprTyConSort <+> pprHead
   where
-    pprHead = pprTypeApp fam (ppr fam) tys
+    pprHead = pprTypeApp fam tys
     pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance")
 		 | isNewTyCon  tycon = ptext (sLit "newtype instance")
 		 | isSynTyCon  tycon = ptext (sLit "type instance")

compiler/types/TypeRep.lhs

@@ -448,11 +448,10 @@ pprType, pprParendType :: Type -> SDoc
 pprType       ty = ppr_type TopPrec   ty
 pprParendType ty = ppr_type TyConPrec ty
 
-pprTypeApp :: NamedThing a => a -> SDoc -> [Type] -> SDoc
--- The first arg is the tycon; it's used to arrange printing infix 
--- if it looks like an operator
--- Second arg is the pretty-printed tycon
-pprTypeApp tc pp_tc tys = ppr_type_app TopPrec (getName tc) pp_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 = ppr_type_app TopPrec (getName tc) tys
 
 ------------------
 pprPred :: PredType -> SDoc
@@ -460,7 +459,7 @@ pprPred (ClassP cls tys) = pprClassPred cls tys
 pprPred (IParam ip ty)   = ppr ip <> dcolon <> pprType ty
 pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext (sLit "~")), ppr ty2]
 pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred clas tys = ppr_type_app TopPrec (getName clas) (ppr clas) tys
+pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys
 
 pprTheta :: ThetaType -> SDoc
 pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
@@ -543,26 +542,23 @@ ppr_tc_app p tc tys
   | isTupleTyCon tc && tyConArity tc == length tys
   = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
   | otherwise
-  = ppr_type_app p (getName tc) (ppr_naked_tc tc) tys
+  = ppr_type_app p (getName tc) tys
 
-ppr_type_app :: Prec -> Name -> SDoc -> [Type] -> SDoc
-ppr_type_app p tc pp_tc tys
+ppr_type_app :: Prec -> Name -> [Type] -> SDoc
+-- Used for classes as well as types; that's why it's separate from ppr_tc_app
+ppr_type_app p tc tys
   | is_sym_occ		-- Print infix if possible
   , [ty1,ty2] <- tys	-- We know nothing of precedence though
   = maybeParen p FunPrec (sep [ppr_type FunPrec ty1, 
-			       pp_tc <+> ppr_type FunPrec ty2])
+			       pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2])
   | otherwise
-  = maybeParen p TyConPrec (hang paren_tc 2 (sep (map pprParendType tys)))
+  = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc))
+    	       	 	       2 (sep (map pprParendType tys)))
   where
     is_sym_occ = isSymOcc (getOccName tc)
-    paren_tc | is_sym_occ = parens pp_tc
-	     | otherwise  = pp_tc
 
-ppr_tc :: TyCon -> SDoc
-ppr_tc tc = parenSymOcc (getOccName tc) (ppr_naked_tc tc)
-
-ppr_naked_tc :: TyCon -> SDoc	-- No brackets for SymOcc
-ppr_naked_tc tc 
+ppr_tc :: TyCon -> SDoc	-- No brackets for SymOcc
+ppr_tc tc 
   = pp_nt_debug <> ppr tc
   where
    pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc 

compiler/utils/Outputable.lhs

@@ -42,7 +42,9 @@ module Outputable (
 	pprCode, mkCodeStyle,
 	showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
 	showSDocUnqual, showsPrecSDoc,
-	pprHsChar, pprHsString,
+
+	pprInfixVar, pprPrefixVar,
+	pprHsChar, pprHsString, pprHsInfix, pprHsVar,
 
 	-- error handling
 	pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, 
@@ -54,10 +56,11 @@ import {-# SOURCE #-} 	Module( Module, ModuleName, moduleName )
 import {-# SOURCE #-} 	OccName( OccName )
 
 import StaticFlags
-import FastString
+import FastString 
 import FastTypes
 import qualified Pretty
 import Pretty		( Doc, Mode(..) )
+import Char		( isAlpha )
 import Panic
 
 import Data.Word	( Word32 )
@@ -311,7 +314,7 @@ showSDocForUser :: PrintUnqualified -> SDoc -> String
 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
 
 showSDocUnqual :: SDoc -> String
--- Only used in the gruesome HsExpr.isOperator
+-- Only used in the gruesome isOperator
 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 
 showsPrecSDoc :: Int -> SDoc -> ShowS
@@ -522,15 +525,48 @@ class Outputable a => OutputableBndr a where
 %************************************************************************
 
 \begin{code}
--- We have 31-bit Chars and will simply use Show instances
--- of Char and String.
-
+-- We have 31-bit Chars and will simply use Show instances of Char and String.
 pprHsChar :: Char -> SDoc
 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
             | otherwise      = text (show c)
 
 pprHsString :: FastString -> SDoc
 pprHsString fs = text (show (unpackFS fs))
+
+---------------------
+-- Put a name in parens if it's an operator
+pprPrefixVar :: Bool -> SDoc -> SDoc
+pprPrefixVar is_operator pp_v
+  | is_operator = parens pp_v
+  | otherwise	= pp_v
+
+-- Put a name in backquotes if it's not an operator
+pprInfixVar :: Bool -> SDoc -> SDoc
+pprInfixVar is_operator pp_v 
+  | 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
 \end{code}