Display operators using parentheses/backticks in error messages (#7848)

8 files changed, 23 insertions, 19 deletions

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 2b96d3f8d1..a15b7341d6 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -529,6 +529,10 @@ instance NamedThing DataCon where
 instance Outputable DataCon where
     ppr con = ppr (dataConName con)
 
+instance OutputableBndr DataCon where
+    pprInfixOcc con = pprInfixName (dataConName con)
+    pprPrefixOcc con = pprPrefixName (dataConName con)
+
 instance Data.Data DataCon where
     -- don't traverse?
     toConstr _   = abstractConstr "DataCon"
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 44e7e399eb..8d5fa9a4df 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -575,22 +575,22 @@ ppr_sig (TypeSig vars ty)         = pprVarSig (map unLoc vars) (ppr ty)
 ppr_sig (GenericSig vars ty)      = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
 ppr_sig (IdSig id)                = pprVarSig [id] (ppr (varType id))
 ppr_sig (FixSig fix_sig)          = ppr fix_sig
-ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var (ppr ty) inl)
-ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
+ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec (unLoc var) (ppr ty) inl)
+ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 
-instance Outputable name => Outputable (FixitySig name) where
-  ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
+instance OutputableBndr name => Outputable (FixitySig name) where
+  ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)]
 
 pragBrackets :: SDoc -> SDoc
 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
 
-pprVarSig :: (Outputable id) => [id] -> SDoc -> SDoc
+pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
 pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
   where
-    pprvars = hsep $ punctuate comma (map ppr vars)
+    pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
 
-pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
+pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty
   where
     pp_inl | isDefaultInlinePragma inl = empty
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 3a8e433596..181b765eba 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -232,7 +232,7 @@ pprPatBndr var                  -- Print with type info if -dppr-debug is on
         parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
                                                 -- but is it worth it?
     else
-        ppr var
+        pprPrefixOcc var
 
 pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
 pprParendLPat (L _ p) = pprParendPat p
@@ -246,14 +246,14 @@ pprPat (VarPat var)       = pprPatBndr var
 pprPat (WildPat _)        = char '_'
 pprPat (LazyPat pat)      = char '~' <> pprParendLPat pat
 pprPat (BangPat pat)      = char '!' <> pprParendLPat pat
-pprPat (AsPat name pat)   = hcat [ppr name, char '@', pprParendLPat pat]
+pprPat (AsPat name pat)   = hcat [pprPrefixOcc (unLoc 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 (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
 
-pprPat (ConPatIn con details) = pprUserCon con details
+pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
 pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
                     pat_binds = binds, pat_args = details })
   = getPprStyle $ \ sty ->      -- Tiresome; in TcBinds.tcRhs we print out a
@@ -262,7 +262,7 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
         ppr con <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                                , ppr binds])
                 <+> pprConArgs details
-    else pprUserCon con details
+    else pprUserCon (unLoc con) details
 
 pprPat (LitPat s)           = ppr s
 pprPat (NPat l Nothing  _)  = ppr l
@@ -273,9 +273,9 @@ pprPat (CoPat co pat _)     = pprHsWrapper (ppr pat) co
 pprPat (SigPatIn pat ty)    = ppr pat <+> dcolon <+> ppr ty
 pprPat (SigPatOut pat ty)   = ppr pat <+> dcolon <+> ppr ty
 
-pprUserCon :: (Outputable con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
-pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2
-pprUserCon c details          = ppr c <+> pprConArgs details
+pprUserCon :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
+pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
+pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
 
 pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc
 pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index c14b853145..878ba647ed 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -228,7 +228,7 @@ pprDataConDecl pefas ss gadt_style dataCon
     user_ify bang                      = bang
 
     maybe_show_label (lbl,bty)
-	| showSub ss lbl = Just (ppr lbl <+> dcolon <+> pprBangTy bty)
+	| showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty)
 	| otherwise      = Nothing
 
     ppr_fields [ty1, ty2]
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 8bb6de1cc2..69df5bfca7 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -1164,7 +1164,7 @@ relevantBindings ctxt ct
        | otherwise
        = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
             ; let id_tvs = tyVarsOfType tidy_ty
-                  doc = sep [ ppr id <+> dcolon <+> ppr tidy_ty
+                  doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty
 		            , nest 2 (parens (ptext (sLit "bound at")
 			    	 <+> ppr (getSrcLoc id)))]
             ; if id_tvs `intersectsVarSet` ct_tvs 
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index cde55a65fd..9ec0d36b02 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -1555,7 +1555,7 @@ pprHsSigCtxt ctxt hs_ty = sep [ ptext (sLit "In") <+> pprUserTypeCtxt ctxt <> co
     pp_sig (ForSigCtxt n)  = pp_n_colon n
     pp_sig _               = ppr (unLoc hs_ty)
 
-    pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty)
+    pp_n_colon n = pprPrefixOcc n <+> dcolon <+> ppr (unLoc hs_ty)
 
 badPatSigTvs :: TcType -> [TyVar] -> SDoc
 badPatSigTvs sig_ty bad_tvs
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 8331b62621..b1de4b5cc3 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -1480,7 +1480,7 @@ pprSkolInfo :: SkolemInfo -> SDoc
 -- Complete the sentence "is a rigid type variable bound by..."
 pprSkolInfo (SigSkol (FunSigCtxt f) ty)
                             = hang (ptext (sLit "the type signature for"))
-                                 2 (ppr f <+> dcolon <+> ppr ty)
+                                 2 (pprPrefixOcc f <+> dcolon <+> ppr ty)
 pprSkolInfo (SigSkol cx ty) = hang (pprUserTypeCtxt cx <> colon)
                                  2 (ppr ty)
 pprSkolInfo (IPSkol ips)    = ptext (sLit "the implicit-parameter bindings for")
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index c6467249e8..9b7425c9a3 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1733,7 +1733,7 @@ dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quote
 
 classOpCtxt :: Var -> Type -> SDoc
 classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"),
-                              nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
+                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]
 
 nullaryClassErr :: Class -> SDoc
 nullaryClassErr cls