Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
f098cfb2
Commit
f098cfb2
authored
Aug 04, 2008
by
simonpj@microsoft.com
Browse files
Fix the bug part of Trac
#1930
parent
54ef1c3c
Changes
9
Hide whitespace changes
Inline
Side-by-side
compiler/basicTypes/Name.lhs
View file @
f098cfb2
...
...
@@ -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}
compiler/hsSyn/HsDecls.lhs
View file @
f098cfb2
...
...
@@ -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, pprHs
Var
con, ppr t2]
ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHs
Infix
con, ppr t2]
ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields
...
...
compiler/hsSyn/HsExpr.lhs
View file @
f098cfb2
...
...
@@ -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, ppr
Hs
Infix 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, ppr
Hs
Infix 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 [ppr
Hs
Infix 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 [ppr
Hs
Infix 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
...
...
compiler/hsSyn/HsImpExp.lhs
View file @
f098cfb2
...
...
@@ -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}
compiler/main/PprTyThing.hs
View file @
f098cfb2
...
...
@@ -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
,
ppr
InfixName
dataCon
,
pprParendBangTy
ty2
]
ppr_fields
fields
|
null
labels
=
ppr_bndr
dataCon
<+>
sep
(
map
pprParendBangTy
fields
)
...
...
compiler/typecheck/TcDeriv.lhs
View file @
f098cfb2
...
...
@@ -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}
...
...
compiler/types/FamInstEnv.lhs
View file @
f098cfb2
...
...
@@ -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")
...
...
compiler/types/TypeRep.lhs
View file @
f098cfb2
...
...
@@ -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])
pp
rInfixVar 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
...
...
compiler/utils/Outputable.lhs
View file @
f098cfb2
...
...
@@ -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}
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment