Commit f098cfb2 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fix the bug part of Trac #1930

parent 54ef1c3c
......@@ -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}
......@@ -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
......
......@@ -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
......
......@@ -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 ("<IEDocNamed: " ++ string ++ ">")
\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}
......@@ -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)
......
......@@ -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}
......
......@@ -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")
......
......@@ -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
......
......@@ -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}
......
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