summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/Name.lhs3
-rw-r--r--compiler/basicTypes/RdrName.lhs3
-rw-r--r--compiler/coreSyn/CoreSyn.lhs2
-rw-r--r--compiler/coreSyn/PprCore.lhs3
-rw-r--r--compiler/hsSyn/HsDecls.lhs4
-rw-r--r--compiler/hsSyn/HsExpr.lhs10
-rw-r--r--compiler/hsSyn/HsImpExp.lhs8
-rw-r--r--compiler/typecheck/TcHsSyn.lhs2
-rw-r--r--compiler/types/TypeRep.lhs4
-rw-r--r--compiler/utils/Outputable.lhs28
10 files changed, 32 insertions, 35 deletions
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index 64ca362d54..e4a9c7d82a 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -430,6 +430,9 @@ instance Outputable Name where
instance OutputableBndr Name where
pprBndr _ name = pprName name
+ pprInfixOcc = pprInfixName
+ pprPrefixOcc = pprPrefixName
+
pprName :: Name -> SDoc
pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ})
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index 0353e65d04..d7f4ced721 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -273,6 +273,9 @@ instance OutputableBndr RdrName where
| isTvOcc (rdrNameOcc n) = char '@' <+> ppr n
| otherwise = ppr n
+ pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
+ pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
+
showRdrName :: RdrName -> String
showRdrName r = showSDoc (ppr r)
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 04bb9d4a68..310a05e1a9 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -992,6 +992,8 @@ instance Outputable b => Outputable (TaggedBndr b) where
instance Outputable b => OutputableBndr (TaggedBndr b) where
pprBndr _ b = ppr b -- Simple
+ pprInfixOcc b = ppr b
+ pprPrefixOcc b = ppr b
\end{code}
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 9def8e8ca7..7487c66025 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -21,6 +21,7 @@ module PprCore (
import CoreSyn
import Literal( pprLiteral )
+import Name( pprInfixName, pprPrefixName )
import Var
import Id
import IdInfo
@@ -268,6 +269,8 @@ and @pprCoreExpr@ functions.
\begin{code}
instance OutputableBndr Var where
pprBndr = pprCoreBinder
+ pprInfixOcc = pprInfixName . varName
+ pprPrefixOcc = pprPrefixName . varName
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index d4463632af..772a3ebee7 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -802,8 +802,8 @@ pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_res = ResTyH98, con_doc = doc })
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
where
- ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
- ppr_details (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
+ ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2]
+ ppr_details (PrefixCon tys) = hsep (pprPrefixOcc (unLoc con) : map ppr tys)
ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 5a18fc6574..cd761c6607 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -379,7 +379,7 @@ ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc
-ppr_expr (HsVar v) = pprHsVar v
+ppr_expr (HsVar v) = pprPrefixOcc v
ppr_expr (HsIPVar v) = ppr v
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
@@ -407,7 +407,7 @@ ppr_expr (OpApp e1 op _ e2)
= hang (ppr op) 2 (sep [pp_e1, pp_e2])
pp_infixly v
- = sep [pp_e1, sep [pprHsInfix v, nest 2 pp_e2]]
+ = sep [pp_e1, sep [pprInfixOcc v, nest 2 pp_e2]]
ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
@@ -420,7 +420,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, pprHsInfix v])
+ pp_infixly v = (sep [pp_expr, pprInfixOcc v])
ppr_expr (SectionR op expr)
= case unLoc op of
@@ -431,7 +431,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 [pprHsInfix v, pp_expr]
+ pp_infixly v = sep [pprInfixOcc v, pp_expr]
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs))
@@ -541,7 +541,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 [pprHsInfix v, pprCmdArg (unLoc arg2)]]
+ = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
ppr_expr (HsArrForm op _ args)
= hang (ptext (sLit "(|") <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs
index 01890b6c95..ee75414d4c 100644
--- a/compiler/hsSyn/HsImpExp.lhs
+++ b/compiler/hsSyn/HsImpExp.lhs
@@ -57,7 +57,7 @@ simpleImportDecl mn = ImportDecl {
\end{code}
\begin{code}
-instance (Outputable name) => Outputable (ImportDecl name) where
+instance (OutputableBndr name) => Outputable (ImportDecl name) where
ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg
, ideclSource = from, ideclSafe = safe
, ideclQualified = qual, ideclImplicit = implicit
@@ -134,12 +134,12 @@ ieNames (IEDocNamed _ ) = []
\end{code}
\begin{code}
-instance (Outputable name) => Outputable (IE name) where
- ppr (IEVar var) = pprHsVar var
+instance (OutputableBndr name, Outputable name) => Outputable (IE name) where
+ ppr (IEVar var) = pprPrefixOcc var
ppr (IEThingAbs thing) = ppr thing
ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"]
ppr (IEThingWith thing withs)
- = pprHsVar thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
+ = pprPrefixOcc thing <> parens (fsep (punctuate comma (map pprPrefixOcc withs)))
ppr (IEModuleContents mod')
= ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index c1f425b2e6..7fe677c648 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -424,7 +424,7 @@ warnMissingSig msg id
; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
; addWarnTcM (env1, mk_msg tidy_ty) }
where
- mk_msg ty = sep [ msg, nest 2 $ pprHsVar (idName id) <+> dcolon <+> ppr ty ]
+ mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
---------------------------------------------
zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id)
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 6d1050fde2..3458b632c5 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -511,7 +511,9 @@ instance Outputable Type where
ppr ty = pprType ty
instance Outputable name => OutputableBndr (IPName name) where
- pprBndr _ n = ppr n -- Simple for now
+ pprBndr _ n = ppr n -- Simple for now
+ pprInfixOcc n = ppr n
+ pprPrefixOcc n = ppr n
------------------
-- OK, here's the main printer
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 5263081c9a..e0be21b983 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -48,7 +48,7 @@ module Outputable (
renderWithStyle,
pprInfixVar, pprPrefixVar,
- pprHsChar, pprHsString, pprHsInfix, pprHsVar,
+ pprHsChar, pprHsString,
pprFastFilePath,
-- * Controlling the style in which output is printed
@@ -743,6 +743,11 @@ data BindingSite = LambdaBind | CaseBind | LetBind
class Outputable a => OutputableBndr a where
pprBndr :: BindingSite -> a -> SDoc
pprBndr _b x = ppr x
+
+ pprPrefixOcc, pprInfixOcc :: a -> SDoc
+ -- Print an occurrence of the name, suitable either in the
+ -- prefix position of an application, thus (f a b) or ((+) x)
+ -- or infix position, thus (a `f` b) or (x + y)
\end{code}
%************************************************************************
@@ -777,27 +782,6 @@ pprInfixVar 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
-
pprFastFilePath :: FastString -> SDoc
pprFastFilePath path = text $ normalise $ unpackFS path
\end{code}
View Lorry Controller Status