Commit 144db21e authored by Krzysztof Gogolewski's avatar Krzysztof Gogolewski Committed by ian@well-typed.com

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

parent 78d56448
......@@ -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"
......
......@@ -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
......
......@@ -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)
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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")
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment