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