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

Fix the bug part of Trac #1930

parent 54ef1c3c
...@@ -32,7 +32,8 @@ module Name ( ...@@ -32,7 +32,8 @@ module Name (
-- Class NamedThing and overloaded friends -- Class NamedThing and overloaded friends
NamedThing(..), NamedThing(..),
getSrcLoc, getSrcSpan, getOccString getSrcLoc, getSrcSpan, getOccString,
pprInfixName, pprPrefixName
) where ) where
import {-# SOURCE #-} TypeRep( TyThing ) import {-# SOURCE #-} TypeRep( TyThing )
...@@ -422,5 +423,11 @@ getOccString :: NamedThing a => a -> String ...@@ -422,5 +423,11 @@ getOccString :: NamedThing a => a -> String
getSrcLoc = nameSrcLoc . getName getSrcLoc = nameSrcLoc . getName
getSrcSpan = nameSrcSpan . getName getSrcSpan = nameSrcSpan . getName
getOccString = occNameString . getOccName 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} \end{code}
...@@ -43,7 +43,6 @@ import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) ...@@ -43,7 +43,6 @@ import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
import HsBinds import HsBinds
import HsPat import HsPat
import HsImpExp
import HsTypes import HsTypes
import HsDoc import HsDoc
import NameSet import NameSet
...@@ -712,7 +711,7 @@ pprConDecl :: OutputableBndr name => ConDecl name -> SDoc ...@@ -712,7 +711,7 @@ pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc) pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details] = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
where 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 (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields
......
...@@ -15,7 +15,6 @@ import HsDecls ...@@ -15,7 +15,6 @@ import HsDecls
import HsPat import HsPat
import HsLit import HsLit
import HsTypes import HsTypes
import HsImpExp
import HsBinds import HsBinds
-- others: -- others:
...@@ -346,7 +345,7 @@ ppr_expr (OpApp e1 op _ e2) ...@@ -346,7 +345,7 @@ ppr_expr (OpApp e1 op _ e2)
= hang (ppr op) 2 (sep [pp_e1, pp_e2]) = hang (ppr op) 2 (sep [pp_e1, pp_e2])
pp_infixly v 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 ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
...@@ -359,7 +358,7 @@ ppr_expr (SectionL expr op) ...@@ -359,7 +358,7 @@ ppr_expr (SectionL expr op)
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, ptext (sLit "x_ )")]) 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) ppr_expr (SectionR op expr)
= case unLoc op of = case unLoc op of
...@@ -371,7 +370,7 @@ ppr_expr (SectionR op expr) ...@@ -371,7 +370,7 @@ ppr_expr (SectionR op expr)
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")]) pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
4 ((<>) pp_expr rparen) 4 ((<>) pp_expr rparen)
pp_infixly v pp_infixly v
= (sep [pprInfix v, pp_expr]) = (sep [pprHsInfix v, pp_expr])
--avoid using PatternSignatures for stage1 code portability --avoid using PatternSignatures for stage1 code portability
ppr_expr exprType@(HsLam matches) ppr_expr exprType@(HsLam matches)
...@@ -477,7 +476,7 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) ...@@ -477,7 +476,7 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
= hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow] = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) 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) ppr_expr (HsArrForm op _ args)
= hang (ptext (sLit "(|") <> ppr_lexpr op) = hang (ptext (sLit "(|") <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
...@@ -491,12 +490,6 @@ pprCmdArg (HsCmdTop cmd _ _ _) ...@@ -491,12 +490,6 @@ pprCmdArg (HsCmdTop cmd _ _ _)
instance OutputableBndr id => Outputable (HsCmdTop id) where instance OutputableBndr id => Outputable (HsCmdTop id) where
ppr = pprCmdArg 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 -- add parallel array brackets around a document
-- --
pa_brackets :: SDoc -> SDoc pa_brackets :: SDoc -> SDoc
......
...@@ -21,7 +21,6 @@ import HsDoc ( HsDoc ) ...@@ -21,7 +21,6 @@ import HsDoc ( HsDoc )
import Outputable import Outputable
import FastString import FastString
import SrcLoc ( Located(..) ) import SrcLoc ( Located(..) )
import Char ( isAlpha )
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -120,25 +119,4 @@ instance (Outputable name) => Outputable (IE name) where ...@@ -120,25 +119,4 @@ instance (Outputable name) => Outputable (IE name) where
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">") ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
\end{code} \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 ...@@ -76,7 +76,7 @@ pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls
pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
pprTyConHdr _ tyCon pprTyConHdr _ tyCon
| Just (_fam_tc, tys) <- tyConFamInst_maybe 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 | otherwise
= ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars) = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
where where
...@@ -212,7 +212,7 @@ pprDataConDecl _ gadt_style show_label dataCon ...@@ -212,7 +212,7 @@ pprDataConDecl _ gadt_style show_label dataCon
ppr_fields [ty1, ty2] ppr_fields [ty1, ty2]
| GHC.dataConIsInfix dataCon && null labels | GHC.dataConIsInfix dataCon && null labels
= sep [pprParendBangTy ty1, ppr dataCon, pprParendBangTy ty2] = sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2]
ppr_fields fields ppr_fields fields
| null labels | null labels
= ppr_bndr dataCon <+> sep (map pprParendBangTy fields) = ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
......
...@@ -537,7 +537,7 @@ tcLookupFamInstExact tycon tys ...@@ -537,7 +537,7 @@ tcLookupFamInstExact tycon tys
famInstNotFound :: TyCon -> [Type] -> TcM a famInstNotFound :: TyCon -> [Type] -> TcM a
famInstNotFound tycon tys famInstNotFound tycon tys
= failWithTc (ptext (sLit "No family instance for") = failWithTc (ptext (sLit "No family instance for")
<+> quotes (pprTypeApp tycon (ppr tycon) tys)) <+> quotes (pprTypeApp tycon tys))
\end{code} \end{code}
......
...@@ -94,7 +94,7 @@ pprFamInstHdr :: FamInst -> SDoc ...@@ -94,7 +94,7 @@ pprFamInstHdr :: FamInst -> SDoc
pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
= pprTyConSort <+> pprHead = pprTyConSort <+> pprHead
where where
pprHead = pprTypeApp fam (ppr fam) tys pprHead = pprTypeApp fam tys
pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance") pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance")
| isNewTyCon tycon = ptext (sLit "newtype instance") | isNewTyCon tycon = ptext (sLit "newtype instance")
| isSynTyCon tycon = ptext (sLit "type instance") | isSynTyCon tycon = ptext (sLit "type instance")
......
...@@ -448,11 +448,10 @@ pprType, pprParendType :: Type -> SDoc ...@@ -448,11 +448,10 @@ pprType, pprParendType :: Type -> SDoc
pprType ty = ppr_type TopPrec ty pprType ty = ppr_type TopPrec ty
pprParendType ty = ppr_type TyConPrec ty pprParendType ty = ppr_type TyConPrec ty
pprTypeApp :: NamedThing a => a -> SDoc -> [Type] -> SDoc pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
-- The first arg is the tycon; it's used to arrange printing infix -- The first arg is the tycon, or sometimes class
-- if it looks like an operator -- Print infix if the tycon/class looks like an operator
-- Second arg is the pretty-printed tycon pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys
pprTypeApp tc pp_tc tys = ppr_type_app TopPrec (getName tc) pp_tc tys
------------------ ------------------
pprPred :: PredType -> SDoc pprPred :: PredType -> SDoc
...@@ -460,7 +459,7 @@ pprPred (ClassP cls tys) = pprClassPred cls tys ...@@ -460,7 +459,7 @@ pprPred (ClassP cls tys) = pprClassPred cls tys
pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty
pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext (sLit "~")), ppr ty2] pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext (sLit "~")), ppr ty2]
pprClassPred :: Class -> [Type] -> SDoc 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 :: ThetaType -> SDoc
pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
...@@ -543,26 +542,23 @@ ppr_tc_app p tc tys ...@@ -543,26 +542,23 @@ ppr_tc_app p tc tys
| isTupleTyCon tc && tyConArity tc == length tys | isTupleTyCon tc && tyConArity tc == length tys
= tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys))) = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
| otherwise | 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 :: Prec -> Name -> [Type] -> SDoc
ppr_type_app p tc pp_tc tys -- 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 | is_sym_occ -- Print infix if possible
, [ty1,ty2] <- tys -- We know nothing of precedence though , [ty1,ty2] <- tys -- We know nothing of precedence though
= maybeParen p FunPrec (sep [ppr_type FunPrec ty1, = maybeParen p FunPrec (sep [ppr_type FunPrec ty1,
pp_tc <+> ppr_type FunPrec ty2]) pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2])
| otherwise | 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 where
is_sym_occ = isSymOcc (getOccName tc) is_sym_occ = isSymOcc (getOccName tc)
paren_tc | is_sym_occ = parens pp_tc
| otherwise = pp_tc
ppr_tc :: TyCon -> SDoc ppr_tc :: TyCon -> SDoc -- No brackets for SymOcc
ppr_tc tc = parenSymOcc (getOccName tc) (ppr_naked_tc tc) ppr_tc tc
ppr_naked_tc :: TyCon -> SDoc -- No brackets for SymOcc
ppr_naked_tc tc
= pp_nt_debug <> ppr tc = pp_nt_debug <> ppr tc
where where
pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
......
...@@ -42,7 +42,9 @@ module Outputable ( ...@@ -42,7 +42,9 @@ module Outputable (
pprCode, mkCodeStyle, pprCode, mkCodeStyle,
showSDoc, showSDocForUser, showSDocDebug, showSDocDump, showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
showSDocUnqual, showsPrecSDoc, showSDocUnqual, showsPrecSDoc,
pprHsChar, pprHsString,
pprInfixVar, pprPrefixVar,
pprHsChar, pprHsString, pprHsInfix, pprHsVar,
-- error handling -- error handling
pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
...@@ -54,10 +56,11 @@ import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) ...@@ -54,10 +56,11 @@ import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
import {-# SOURCE #-} OccName( OccName ) import {-# SOURCE #-} OccName( OccName )
import StaticFlags import StaticFlags
import FastString import FastString
import FastTypes import FastTypes
import qualified Pretty import qualified Pretty
import Pretty ( Doc, Mode(..) ) import Pretty ( Doc, Mode(..) )
import Char ( isAlpha )
import Panic import Panic
import Data.Word ( Word32 ) import Data.Word ( Word32 )
...@@ -311,7 +314,7 @@ showSDocForUser :: PrintUnqualified -> SDoc -> String ...@@ -311,7 +314,7 @@ showSDocForUser :: PrintUnqualified -> SDoc -> String
showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
showSDocUnqual :: SDoc -> String showSDocUnqual :: SDoc -> String
-- Only used in the gruesome HsExpr.isOperator -- Only used in the gruesome isOperator
showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
showsPrecSDoc :: Int -> SDoc -> ShowS showsPrecSDoc :: Int -> SDoc -> ShowS
...@@ -522,15 +525,48 @@ class Outputable a => OutputableBndr a where ...@@ -522,15 +525,48 @@ class Outputable a => OutputableBndr a where
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
-- We have 31-bit Chars and will simply use Show instances -- We have 31-bit Chars and will simply use Show instances of Char and String.
-- of Char and String.
pprHsChar :: Char -> SDoc pprHsChar :: Char -> SDoc
pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
| otherwise = text (show c) | otherwise = text (show c)
pprHsString :: FastString -> SDoc pprHsString :: FastString -> SDoc
pprHsString fs = text (show (unpackFS fs)) 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} \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