From f098cfb236c17bcb3c46e39f9b1d7d8d8ca86003 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 4 Aug 2008 16:10:39 +0000 Subject: [PATCH] Fix the bug part of Trac #1930 --- compiler/basicTypes/Name.lhs | 9 +++++++- compiler/hsSyn/HsDecls.lhs | 3 +-- compiler/hsSyn/HsExpr.lhs | 15 ++++--------- compiler/hsSyn/HsImpExp.lhs | 22 ------------------ compiler/main/PprTyThing.hs | 4 ++-- compiler/typecheck/TcDeriv.lhs | 2 +- compiler/types/FamInstEnv.lhs | 2 +- compiler/types/TypeRep.lhs | 32 ++++++++++++--------------- compiler/utils/Outputable.lhs | 48 +++++++++++++++++++++++++++++++++++----- 9 files changed, 73 insertions(+), 64 deletions(-) diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 7dfed64..bbc249f 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -32,7 +32,8 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, getSrcSpan, getOccString + getSrcLoc, getSrcSpan, getOccString, + pprInfixName, pprPrefixName ) where import {-# SOURCE #-} TypeRep( TyThing ) @@ -422,5 +423,11 @@ getOccString :: NamedThing a => a -> String getSrcLoc = nameSrcLoc . getName getSrcSpan = nameSrcSpan . getName getOccString = occNameString . getOccName + +pprInfixName, pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc +-- See Outputable.pprPrefixVar, pprInfixVar; +-- add parens or back-quotes as appropriate +pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) +pprPrefixName n = pprPrefixVar (isSymOcc (getOccName n)) (ppr n) \end{code} diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 3a615f0..1faaa26 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -43,7 +43,6 @@ import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) import HsBinds import HsPat -import HsImpExp import HsTypes import HsDoc import NameSet @@ -712,7 +711,7 @@ pprConDecl :: OutputableBndr name => ConDecl name -> SDoc pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc) = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details] where - ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsVar con, ppr t2] + ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2] ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys) ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index a28b26a..e5d85ca 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -15,7 +15,6 @@ import HsDecls import HsPat import HsLit import HsTypes -import HsImpExp import HsBinds -- others: @@ -346,7 +345,7 @@ ppr_expr (OpApp e1 op _ e2) = hang (ppr op) 2 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2] + = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2] ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e @@ -359,7 +358,7 @@ ppr_expr (SectionL expr op) pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, ptext (sLit "x_ )")]) - pp_infixly v = (sep [pp_expr, pprInfix v]) + pp_infixly v = (sep [pp_expr, pprHsInfix v]) ppr_expr (SectionR op expr) = case unLoc op of @@ -371,7 +370,7 @@ ppr_expr (SectionR op expr) pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")]) 4 ((<>) pp_expr rparen) pp_infixly v - = (sep [pprInfix v, pp_expr]) + = (sep [pprHsInfix v, pp_expr]) --avoid using PatternSignatures for stage1 code portability ppr_expr exprType@(HsLam matches) @@ -477,7 +476,7 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow] ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) - = sep [pprCmdArg (unLoc arg1), hsep [pprInfix v, pprCmdArg (unLoc arg2)]] + = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]] ppr_expr (HsArrForm op _ args) = hang (ptext (sLit "(|") <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) @@ -491,12 +490,6 @@ pprCmdArg (HsCmdTop cmd _ _ _) instance OutputableBndr id => Outputable (HsCmdTop id) where ppr = pprCmdArg --- Put a var in backquotes if it's not an operator already -pprInfix :: Outputable name => name -> SDoc -pprInfix v | isOperator ppr_v = ppr_v - | otherwise = char '`' <> ppr_v <> char '`' - where ppr_v = ppr v - -- add parallel array brackets around a document -- pa_brackets :: SDoc -> SDoc diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 78e417c..4e58dd7 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -21,7 +21,6 @@ import HsDoc ( HsDoc ) import Outputable import FastString import SrcLoc ( Located(..) ) -import Char ( isAlpha ) \end{code} %************************************************************************ @@ -120,25 +119,4 @@ instance (Outputable name) => Outputable (IE name) where ppr (IEDocNamed string) = text ("") \end{code} -\begin{code} -pprHsVar :: Outputable name => name -> SDoc -pprHsVar v | isOperator ppr_v = parens ppr_v - | otherwise = ppr_v - where - ppr_v = ppr v - -isOperator :: SDoc -> Bool -isOperator ppr_v - = case showSDocUnqual ppr_v of - ('(':_) -> False -- (), (,) etc - ('[':_) -> False -- [] - ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator - (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator - ('_':_) -> False -- Not an operator - (c:_) -> not (isAlpha c) -- Starts with non-alpha - _ -> False - -- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so - -- that we don't need NamedThing in the context of all these functions. - -- Gruesome, but simple. -\end{code} diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index c9e0b2a..2479028 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -76,7 +76,7 @@ pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc pprTyConHdr _ tyCon | Just (_fam_tc, tys) <- tyConFamInst_maybe tyCon - = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp tyCon (ppr_bndr tyCon) tys + = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp tyCon tys | otherwise = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars) where @@ -212,7 +212,7 @@ pprDataConDecl _ gadt_style show_label dataCon ppr_fields [ty1, ty2] | GHC.dataConIsInfix dataCon && null labels - = sep [pprParendBangTy ty1, ppr dataCon, pprParendBangTy ty2] + = sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2] ppr_fields fields | null labels = ppr_bndr dataCon <+> sep (map pprParendBangTy fields) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index e4d66a6..dc9bf3e 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -537,7 +537,7 @@ tcLookupFamInstExact tycon tys famInstNotFound :: TyCon -> [Type] -> TcM a famInstNotFound tycon tys = failWithTc (ptext (sLit "No family instance for") - <+> quotes (pprTypeApp tycon (ppr tycon) tys)) + <+> quotes (pprTypeApp tycon tys)) \end{code} diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 28a8770..783ee13 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -94,7 +94,7 @@ pprFamInstHdr :: FamInst -> SDoc pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) = pprTyConSort <+> pprHead where - pprHead = pprTypeApp fam (ppr fam) tys + pprHead = pprTypeApp fam tys pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance") | isNewTyCon tycon = ptext (sLit "newtype instance") | isSynTyCon tycon = ptext (sLit "type instance") diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 7b5324b..48481e2 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -448,11 +448,10 @@ pprType, pprParendType :: Type -> SDoc pprType ty = ppr_type TopPrec ty pprParendType ty = ppr_type TyConPrec ty -pprTypeApp :: NamedThing a => a -> SDoc -> [Type] -> SDoc --- The first arg is the tycon; it's used to arrange printing infix --- if it looks like an operator --- Second arg is the pretty-printed tycon -pprTypeApp tc pp_tc tys = ppr_type_app TopPrec (getName tc) pp_tc tys +pprTypeApp :: NamedThing a => a -> [Type] -> SDoc +-- The first arg is the tycon, or sometimes class +-- Print infix if the tycon/class looks like an operator +pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys ------------------ pprPred :: PredType -> SDoc @@ -460,7 +459,7 @@ pprPred (ClassP cls tys) = pprClassPred cls tys pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext (sLit "~")), ppr ty2] pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = ppr_type_app TopPrec (getName clas) (ppr clas) tys +pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys pprTheta :: ThetaType -> SDoc pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) @@ -543,26 +542,23 @@ ppr_tc_app p tc tys | isTupleTyCon tc && tyConArity tc == length tys = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys))) | otherwise - = ppr_type_app p (getName tc) (ppr_naked_tc tc) tys + = ppr_type_app p (getName tc) tys -ppr_type_app :: Prec -> Name -> SDoc -> [Type] -> SDoc -ppr_type_app p tc pp_tc tys +ppr_type_app :: Prec -> Name -> [Type] -> SDoc +-- Used for classes as well as types; that's why it's separate from ppr_tc_app +ppr_type_app p tc tys | is_sym_occ -- Print infix if possible , [ty1,ty2] <- tys -- We know nothing of precedence though = maybeParen p FunPrec (sep [ppr_type FunPrec ty1, - pp_tc <+> ppr_type FunPrec ty2]) + pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2]) | otherwise - = maybeParen p TyConPrec (hang paren_tc 2 (sep (map pprParendType tys))) + = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc)) + 2 (sep (map pprParendType tys))) where is_sym_occ = isSymOcc (getOccName tc) - paren_tc | is_sym_occ = parens pp_tc - | otherwise = pp_tc -ppr_tc :: TyCon -> SDoc -ppr_tc tc = parenSymOcc (getOccName tc) (ppr_naked_tc tc) - -ppr_naked_tc :: TyCon -> SDoc -- No brackets for SymOcc -ppr_naked_tc tc +ppr_tc :: TyCon -> SDoc -- No brackets for SymOcc +ppr_tc tc = pp_nt_debug <> ppr tc where pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 61ad4dd..ebf8416 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -42,7 +42,9 @@ module Outputable ( pprCode, mkCodeStyle, showSDoc, showSDocForUser, showSDocDebug, showSDocDump, showSDocUnqual, showsPrecSDoc, - pprHsChar, pprHsString, + + pprInfixVar, pprPrefixVar, + pprHsChar, pprHsString, pprHsInfix, pprHsVar, -- error handling pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, @@ -54,10 +56,11 @@ import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) import StaticFlags -import FastString +import FastString import FastTypes import qualified Pretty import Pretty ( Doc, Mode(..) ) +import Char ( isAlpha ) import Panic import Data.Word ( Word32 ) @@ -311,7 +314,7 @@ showSDocForUser :: PrintUnqualified -> SDoc -> String showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) showSDocUnqual :: SDoc -> String --- Only used in the gruesome HsExpr.isOperator +-- Only used in the gruesome isOperator showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) showsPrecSDoc :: Int -> SDoc -> ShowS @@ -522,15 +525,48 @@ class Outputable a => OutputableBndr a where %************************************************************************ \begin{code} --- We have 31-bit Chars and will simply use Show instances --- of Char and String. - +-- We have 31-bit Chars and will simply use Show instances of Char and String. pprHsChar :: Char -> SDoc pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) | otherwise = text (show c) pprHsString :: FastString -> SDoc pprHsString fs = text (show (unpackFS fs)) + +--------------------- +-- Put a name in parens if it's an operator +pprPrefixVar :: Bool -> SDoc -> SDoc +pprPrefixVar is_operator pp_v + | is_operator = parens pp_v + | otherwise = pp_v + +-- Put a name in backquotes if it's not an operator +pprInfixVar :: Bool -> SDoc -> SDoc +pprInfixVar is_operator pp_v + | is_operator = pp_v + | otherwise = char '`' <> pp_v <> char '`' + +--------------------- +-- pprHsVar and pprHsInfix use the gruesome isOperator, which +-- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v). +-- Reason: it means that pprHsVar doesn't need a NamedThing context, +-- which none of the HsSyn printing functions do +pprHsVar, pprHsInfix :: Outputable name => name -> SDoc +pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v + where pp_v = ppr v +pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v + where pp_v = ppr v + +isOperator :: SDoc -> Bool +isOperator ppr_v + = case showSDocUnqual ppr_v of + ('(':_) -> False -- (), (,) etc + ('[':_) -> False -- [] + ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator + (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator + ('_':_) -> False -- Not an operator + (c:_) -> not (isAlpha c) -- Starts with non-alpha + _ -> False \end{code} -- 1.7.10.4