Commit c492e50b authored by Simon Peyton Jones's avatar Simon Peyton Jones

Tidy up pretty-printing for variables

We already have a class OutputableBndr; this patch adds
methods pprInfixOcc and pprPrefixOcc, so that we can get
rid of the hideous hack (the old) Outputable.pprHsVar.

The hack was exposed by Trac #5657, which is thereby fixed.
parent e8c93ad1
......@@ -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})
......
......@@ -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)
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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 "|)"))
......
......@@ -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) ++ ">")
......
......@@ -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)
......
......@@ -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
......
......@@ -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}
......
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