From 144db21e9519fac0af5a845b57b605567c1aaa25 Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski Date: Fri, 19 Apr 2013 13:23:11 +0200 Subject: [PATCH] Display operators using parentheses/backticks in error messages (#7848) --- compiler/basicTypes/DataCon.lhs | 4 ++++ compiler/hsSyn/HsBinds.lhs | 14 +++++++------- compiler/hsSyn/HsPat.lhs | 14 +++++++------- compiler/main/PprTyThing.hs | 2 +- compiler/typecheck/TcErrors.lhs | 2 +- compiler/typecheck/TcHsType.lhs | 2 +- compiler/typecheck/TcRnTypes.lhs | 2 +- compiler/typecheck/TcTyClsDecls.lhs | 2 +- 8 files changed, 23 insertions(+), 19 deletions(-) diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 2b96d3f8d1f7..a15b7341d6d6 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 44e7e399eb6a..8d5fa9a4dfff 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 3a8e433596a6..181b765ebaf4 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 c14b853145e3..878ba647edf1 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 8bb6de1cc246..69df5bfca72b 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 cde55a65fd4a..9ec0d36b023c 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 8331b62621f3..b1de4b5cc32a 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 c6467249e881..9b7425c9a37d 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