Ticket #7848: 0001-Display-operators-using-parentheses-backticks-in-err.patch

File 0001-Display-operators-using-parentheses-backticks-in-err.patch, 8.9 KB (added by monoidal, 12 months ago)

Compiler

  • compiler/basicTypes/DataCon.lhs

    From f707496132b7134844607a79b4fb1d5d5a97990b Mon Sep 17 00:00:00 2001
    From: Krzysztof Gogolewski <krz.gogolewski@gmail.com>
    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 2b96d3f..a15b734 100644
    a b instance NamedThing DataCon where 
    529529instance Outputable DataCon where 
    530530    ppr con = ppr (dataConName con) 
    531531 
     532instance OutputableBndr DataCon where 
     533    pprInfixOcc con = pprInfixName (dataConName con) 
     534    pprPrefixOcc con = pprPrefixName (dataConName con) 
     535 
    532536instance Data.Data DataCon where 
    533537    -- don't traverse? 
    534538    toConstr _   = abstractConstr "DataCon" 
  • compiler/hsSyn/HsBinds.lhs

    diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
    index 44e7e39..8d5fa9a 100644
    a b ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) 
    575575ppr_sig (GenericSig vars ty)      = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) 
    576576ppr_sig (IdSig id)                = pprVarSig [id] (ppr (varType id)) 
    577577ppr_sig (FixSig fix_sig)          = ppr fix_sig 
    578 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var (ppr ty) inl) 
    579 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var) 
     578ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec (unLoc var) (ppr ty) inl) 
     579ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var)) 
    580580ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) 
    581581 
    582 instance Outputable name => Outputable (FixitySig name) where 
    583   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name] 
     582instance OutputableBndr name => Outputable (FixitySig name) where 
     583  ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)] 
    584584 
    585585pragBrackets :: SDoc -> SDoc 
    586586pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") 
    587587 
    588 pprVarSig :: (Outputable id) => [id] -> SDoc -> SDoc 
     588pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc 
    589589pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] 
    590590  where 
    591     pprvars = hsep $ punctuate comma (map ppr vars) 
     591    pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) 
    592592 
    593 pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc 
     593pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc 
    594594pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty 
    595595  where 
    596596    pp_inl | isDefaultInlinePragma inl = empty 
  • compiler/hsSyn/HsPat.lhs

    diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
    index 3a8e433..181b765 100644
    a b pprPatBndr var -- Print with type info if -dppr-debug is on 
    232232        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat 
    233233                                                -- but is it worth it? 
    234234    else 
    235         ppr var 
     235        pprPrefixOcc var 
    236236 
    237237pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc 
    238238pprParendLPat (L _ p) = pprParendPat p 
    pprPat (VarPat var) = pprPatBndr var 
    246246pprPat (WildPat _)        = char '_' 
    247247pprPat (LazyPat pat)      = char '~' <> pprParendLPat pat 
    248248pprPat (BangPat pat)      = char '!' <> pprParendLPat pat 
    249 pprPat (AsPat name pat)   = hcat [ppr name, char '@', pprParendLPat pat] 
     249pprPat (AsPat name pat)   = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat] 
    250250pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] 
    251251pprPat (ParPat pat)         = parens (ppr pat) 
    252252pprPat (ListPat pats _ _)     = brackets (interpp'SP pats) 
    253253pprPat (PArrPat pats _)     = paBrackets (interpp'SP pats) 
    254254pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) 
    255255 
    256 pprPat (ConPatIn con details) = pprUserCon con details 
     256pprPat (ConPatIn con details) = pprUserCon (unLoc con) details 
    257257pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, 
    258258                    pat_binds = binds, pat_args = details }) 
    259259  = getPprStyle $ \ sty ->      -- Tiresome; in TcBinds.tcRhs we print out a 
    pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, 
    262262        ppr con <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) 
    263263                               , ppr binds]) 
    264264                <+> pprConArgs details 
    265     else pprUserCon con details 
     265    else pprUserCon (unLoc con) details 
    266266 
    267267pprPat (LitPat s)           = ppr s 
    268268pprPat (NPat l Nothing  _)  = ppr l 
    pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co 
    273273pprPat (SigPatIn pat ty)    = ppr pat <+> dcolon <+> ppr ty 
    274274pprPat (SigPatOut pat ty)   = ppr pat <+> dcolon <+> ppr ty 
    275275 
    276 pprUserCon :: (Outputable con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc 
    277 pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2 
    278 pprUserCon c details          = ppr c <+> pprConArgs details 
     276pprUserCon :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc 
     277pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 
     278pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details 
    279279 
    280280pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc 
    281281pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) 
  • compiler/main/PprTyThing.hs

    diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
    index c14b853..878ba64 100644
    a b pprDataConDecl pefas ss gadt_style dataCon 
    228228    user_ify bang                      = bang 
    229229 
    230230    maybe_show_label (lbl,bty) 
    231         | showSub ss lbl = Just (ppr lbl <+> dcolon <+> pprBangTy bty) 
     231        | showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty) 
    232232        | otherwise      = Nothing 
    233233 
    234234    ppr_fields [ty1, ty2] 
  • compiler/typecheck/TcErrors.lhs

    diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
    index 8bb6de1..69df5bf 100644
    a b relevantBindings ctxt ct 
    11641164       | otherwise 
    11651165       = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) 
    11661166            ; let id_tvs = tyVarsOfType tidy_ty 
    1167                   doc = sep [ ppr id <+> dcolon <+> ppr tidy_ty 
     1167                  doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty 
    11681168                            , nest 2 (parens (ptext (sLit "bound at") 
    11691169                                 <+> ppr (getSrcLoc id)))] 
    11701170            ; if id_tvs `intersectsVarSet` ct_tvs  
  • compiler/typecheck/TcHsType.lhs

    diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
    index cde55a6..9ec0d36 100644
    a b pprHsSigCtxt ctxt hs_ty = sep [ ptext (sLit "In") <+> pprUserTypeCtxt ctxt <> co 
    15551555    pp_sig (ForSigCtxt n)  = pp_n_colon n 
    15561556    pp_sig _               = ppr (unLoc hs_ty) 
    15571557 
    1558     pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty) 
     1558    pp_n_colon n = pprPrefixOcc n <+> dcolon <+> ppr (unLoc hs_ty) 
    15591559 
    15601560badPatSigTvs :: TcType -> [TyVar] -> SDoc 
    15611561badPatSigTvs sig_ty bad_tvs 
  • compiler/typecheck/TcRnTypes.lhs

    diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
    index 8331b62..b1de4b5 100644
    a b pprSkolInfo :: SkolemInfo -> SDoc 
    14801480-- Complete the sentence "is a rigid type variable bound by..." 
    14811481pprSkolInfo (SigSkol (FunSigCtxt f) ty) 
    14821482                            = hang (ptext (sLit "the type signature for")) 
    1483                                  2 (ppr f <+> dcolon <+> ppr ty) 
     1483                                 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) 
    14841484pprSkolInfo (SigSkol cx ty) = hang (pprUserTypeCtxt cx <> colon) 
    14851485                                 2 (ppr ty) 
    14861486pprSkolInfo (IPSkol ips)    = ptext (sLit "the implicit-parameter bindings for") 
  • compiler/typecheck/TcTyClsDecls.lhs

    diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
    index c646724..9b7425c 100644
    a b dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quote 
    17331733 
    17341734classOpCtxt :: Var -> Type -> SDoc 
    17351735classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"), 
    1736                               nest 2 (ppr sel_id <+> dcolon <+> ppr tau)] 
     1736                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] 
    17371737 
    17381738nullaryClassErr :: Class -> SDoc 
    17391739nullaryClassErr cls