Outputable.lhs 21.1 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP Project, Glasgow University, 1992-1998
4 5
%

Simon Marlow's avatar
Simon Marlow committed
6 7
Outputable: defines classes for pretty-printing and forcing, both
forms of ``output.''
8 9 10

\begin{code}
module Outputable (
11 12 13
	Outputable(..), OutputableBndr(..),	-- Class

	BindingSite(..),
14

15 16
	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
        QualifyName(..),
17 18
	getPprStyle, withPprStyle, withPprStyleDoc, 
	pprDeeper, pprDeeperList, pprSetDepth,
19
	codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
Simon Marlow's avatar
Simon Marlow committed
20
	ifPprDebug, qualName, qualModule,
21
	mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
22
        mkUserStyle,
23 24

	SDoc, 		-- Abstract
25
	docToSDoc,
26
	interppSP, interpp'SP, pprQuotedList, pprWithCommas,
27
	empty, nest,
28
	text, char, ftext, ptext,
29
	int, integer, float, double, rational,
mnislaih's avatar
mnislaih committed
30
	parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
31
	semi, comma, colon, dcolon, space, equals, dot, arrow,
32
	lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
33 34 35 36 37
	(<>), (<+>), hcat, hsep, 
	($$), ($+$), vcat, 
	sep, cat, 
	fsep, fcat, 
	hang, punctuate,
38
	speakNth, speakNTimes, speakN, speakNOf, plural,
39

40
	printSDoc, printErrs, hPrintDump, printDump,
41
	printForC, printForAsm, printForUser, printForUserPartWay,
42
	pprCode, mkCodeStyle,
43
	showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
44
	showSDocUnqual, showsPrecSDoc,
45 46 47

	pprInfixVar, pprPrefixVar,
	pprHsChar, pprHsString, pprHsInfix, pprHsVar,
48

49
	-- error handling
50
	pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, 
51
	pprTrace, warnPprTrace,
52
	trace, pgmError, panic, panicFastInt, assertPanic
53 54
    ) where

55
import {-# SOURCE #-} 	Module( Module, ModuleName, moduleName )
56
import {-# SOURCE #-} 	OccName( OccName )
57

Simon Marlow's avatar
Simon Marlow committed
58
import StaticFlags
59
import FastString 
60
import FastTypes
61
import qualified Pretty
62
import Pretty		( Doc, Mode(..) )
63
import Char		( isAlpha )
64
import Panic
65

Simon Marlow's avatar
Simon Marlow committed
66 67 68
import Data.Word	( Word32 )
import System.IO	( Handle, stderr, stdout, hFlush )
import Data.Char        ( ord )
69 70
\end{code}

sof's avatar
sof committed
71

72 73
%************************************************************************
%*									*
sof's avatar
sof committed
74
\subsection{The @PprStyle@ data type}
75 76 77 78
%*									*
%************************************************************************

\begin{code}
79

sof's avatar
sof committed
80
data PprStyle
81 82 83 84 85 86
  = PprUser PrintUnqualified Depth
		-- Pretty-print in a way that will make sense to the
		-- ordinary user; must be very close to Haskell
		-- syntax, etc.
		-- Assumes printing tidied code: non-system names are
		-- printed without uniques.
sof's avatar
sof committed
87

88 89
  | PprCode CodeStyle
		-- Print code; either C or assembler
sof's avatar
sof committed
90

91 92 93 94 95
  | PprDump	-- For -ddump-foo; less verbose than PprDebug.
		-- Does not assume tidied code: non-external names
		-- are printed with uniques.

  | PprDebug	-- Full debugging output
96

97 98 99 100 101
data CodeStyle = CStyle		-- The format of labels differs for C and assembler
	       | AsmStyle

data Depth = AllTheWay
           | PartWay Int	-- 0 => stop
102 103


Simon Marlow's avatar
Simon Marlow committed
104 105
-- -----------------------------------------------------------------------------
-- Printing original names
106

Simon Marlow's avatar
Simon Marlow committed
107 108 109 110 111 112 113 114 115 116 117
-- When printing code that contains original names, we need to map the
-- original names back to something the user understands.  This is the
-- purpose of the pair of functions that gets passed around
-- when rendering 'SDoc'.

-- | given an /original/ name, this function tells you which module
-- name it should be qualified with when printing for the user, if
-- any.  For example, given @Control.Exception.catch@, which is in scope
-- as @Exception.catch@, this fuction will return @Just "Exception"@.
-- Note that the return value is a ModuleName, not a Module, because
-- in source code, names are qualified by ModuleNames.
118 119 120 121 122 123 124 125 126 127 128 129
type QueryQualifyName = Module -> OccName -> QualifyName

data QualifyName                        -- given P:M.T
        = NameUnqual                    -- refer to it as "T"
        | NameQual ModuleName           -- refer to it as "X.T" for the supplied X
        | NameNotInScope1               
                -- it is not in scope at all, but M.T is not bound in the current
                -- scope, so we can refer to it as "M.T"
        | NameNotInScope2
                -- it is not in scope at all, and M.T is already bound in the
                -- current scope, so we must refer to it as "P:M.T"

Simon Marlow's avatar
Simon Marlow committed
130 131

-- | For a given module, we need to know whether to print it with
132 133
-- a package name to disambiguate it.
type QueryQualifyModule = Module -> Bool
Simon Marlow's avatar
Simon Marlow committed
134

135
type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
Simon Marlow's avatar
Simon Marlow committed
136

137
alwaysQualifyNames :: QueryQualifyName
138
alwaysQualifyNames m _ = NameQual (moduleName m)
Simon Marlow's avatar
Simon Marlow committed
139

140
neverQualifyNames :: QueryQualifyName
141
neverQualifyNames _ _ = NameUnqual
Simon Marlow's avatar
Simon Marlow committed
142

143
alwaysQualifyModules :: QueryQualifyModule
144
alwaysQualifyModules _ = True
Simon Marlow's avatar
Simon Marlow committed
145

146
neverQualifyModules :: QueryQualifyModule
147 148 149
neverQualifyModules _ = False

type QueryQualifies = (QueryQualifyName, QueryQualifyModule)
Simon Marlow's avatar
Simon Marlow committed
150

151
alwaysQualify, neverQualify :: QueryQualifies
Simon Marlow's avatar
Simon Marlow committed
152 153
alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
neverQualify  = (neverQualifyNames,  neverQualifyModules)
154

155 156
defaultUserStyle, defaultDumpStyle :: PprStyle

157 158
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay

159 160 161
defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
		 |  otherwise          = PprDump

Simon Marlow's avatar
Simon Marlow committed
162
-- | Style for printing error messages
163
mkErrStyle :: PrintUnqualified -> PprStyle
Simon Marlow's avatar
Simon Marlow committed
164
mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
165 166 167 168 169 170

defaultErrStyle :: PprStyle
-- Default style for error messages
-- It's a bit of a hack because it doesn't take into account what's in scope
-- Only used for desugarer warnings, and typechecker errors in interface sigs
defaultErrStyle 
Simon Marlow's avatar
Simon Marlow committed
171 172
  | opt_PprStyle_Debug   = mkUserStyle alwaysQualify AllTheWay
  | otherwise            = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
173

174
mkUserStyle :: QueryQualifies -> Depth -> PprStyle
Simon Marlow's avatar
Simon Marlow committed
175 176 177
mkUserStyle unqual depth
   | opt_PprStyle_Debug = PprDebug
   | otherwise          = PprUser unqual depth
sof's avatar
sof committed
178
\end{code}
179

sof's avatar
sof committed
180 181 182 183
Orthogonal to the above printing styles are (possibly) some
command-line flags that affect printing (often carried with the
style).  The most likely ones are variations on how much type info is
shown.
sof's avatar
sof committed
184

sof's avatar
sof committed
185 186
The following test decides whether or not we are actually generating
code (either C or assembly), or generating interface files.
187 188 189 190 191 192 193 194 195 196 197

%************************************************************************
%*									*
\subsection{The @SDoc@ data type}
%*									*
%************************************************************************

\begin{code}
type SDoc = PprStyle -> Doc

withPprStyle :: PprStyle -> SDoc -> SDoc
198
withPprStyle sty d _sty' = d sty
199

200 201 202
withPprStyleDoc :: PprStyle -> SDoc -> Doc
withPprStyleDoc sty d = d sty

203
pprDeeper :: SDoc -> SDoc
204
pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
Simon Marlow's avatar
Simon Marlow committed
205 206
pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
pprDeeper d other_sty        	    = d other_sty
207

208 209 210 211 212 213
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
-- Truncate a list that list that is longer than the current depth
pprDeeperList f ds (PprUser q (PartWay n))
  | n==0      = Pretty.text "..."
  | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
  where
214
    go _ [] = []
215 216 217 218 219 220
    go i (d:ds) | i >= n    = [text "...."]
		| otherwise = d : go (i+1) ds

pprDeeperList f ds other_sty
  = f ds other_sty

221
pprSetDepth :: Int -> SDoc -> SDoc
222 223
pprSetDepth  n d (PprUser q _) = d (PprUser q (PartWay n))
pprSetDepth _n d other_sty     = d other_sty
224

225 226 227 228
getPprStyle :: (PprStyle -> SDoc) -> SDoc
getPprStyle df sty = df sty sty
\end{code}

sof's avatar
sof committed
229
\begin{code}
230
qualName :: PprStyle -> QueryQualifyName
231 232
qualName (PprUser (qual_name,_) _) m  n = qual_name m n
qualName _other		           m _n = NameQual (moduleName m)
Simon Marlow's avatar
Simon Marlow committed
233

234
qualModule :: PprStyle -> QueryQualifyModule
235 236
qualModule (PprUser (_,qual_mod) _)  m = qual_mod m
qualModule _other                   _m = True
237

sof's avatar
sof committed
238
codeStyle :: PprStyle -> Bool
239
codeStyle (PprCode _)	  = True
sof's avatar
sof committed
240 241
codeStyle _		  = False

242 243
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle)  = True
244
asmStyle _other              = False
245

246 247
dumpStyle :: PprStyle -> Bool
dumpStyle PprDump = True
248
dumpStyle _other  = False
249

250 251
debugStyle :: PprStyle -> Bool
debugStyle PprDebug	  = True
252
debugStyle _other	  = False
253

sof's avatar
sof committed
254
userStyle ::  PprStyle -> Bool
255
userStyle (PprUser _ _) = True
256
userStyle _other        = False
sof's avatar
sof committed
257

258 259
ifPprDebug :: SDoc -> SDoc	  -- Empty for non-debug style
ifPprDebug d sty@PprDebug = d sty
260
ifPprDebug _ _  	  = Pretty.empty
sof's avatar
sof committed
261
\end{code}
262

sof's avatar
sof committed
263
\begin{code}
sof's avatar
sof committed
264
-- Unused [7/02 sof]
265
printSDoc :: SDoc -> PprStyle -> IO ()
sof's avatar
sof committed
266 267 268
printSDoc d sty = do
  Pretty.printDoc PageMode stdout (d sty)
  hFlush stdout
269

270
-- I'm not sure whether the direct-IO approach of Pretty.printDoc
271
-- above is better or worse than the put-big-string approach here
272 273 274
printErrs :: Doc -> IO ()
printErrs doc = do Pretty.printDoc PageMode stderr doc
		   hFlush stderr
275 276

printDump :: SDoc -> IO ()
277 278 279 280 281 282
printDump doc = hPrintDump stdout doc

hPrintDump :: Handle -> SDoc -> IO ()
hPrintDump h doc = do
   Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
   hFlush h
sof's avatar
sof committed
283 284
 where
   better_doc = doc $$ text ""
285

286 287
printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser handle unqual doc 
288
  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
289

290 291 292 293
printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
printForUserPartWay handle d unqual doc
  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))

294
-- printForC, printForAsm do what they sound like
295
printForC :: Handle -> SDoc -> IO ()
296
printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
297 298

printForAsm :: Handle -> SDoc -> IO ()
299
printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
300

sof's avatar
sof committed
301 302
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
303

304 305 306
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

307 308
-- Can't make SDoc an instance of Show because SDoc is just a function type
-- However, Doc *is* an instance of Show
309 310
-- showSDoc just blasts it out as a string
showSDoc :: SDoc -> String
311 312
showSDoc d = show (d defaultUserStyle)

313 314 315
showSDocForUser :: PrintUnqualified -> SDoc -> String
showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))

316
showSDocUnqual :: SDoc -> String
317
-- Only used in the gruesome isOperator
318 319 320 321
showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))

showsPrecSDoc :: Int -> SDoc -> ShowS
showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
322

323 324 325
showSDocDump :: SDoc -> String
showSDocDump d = show (d PprDump)

326 327
showSDocDebug :: SDoc -> String
showSDocDebug d = show (d PprDebug)
328 329
\end{code}

330
\begin{code}
331 332 333
docToSDoc :: Doc -> SDoc
docToSDoc d = \_ -> d

334 335 336 337
empty    :: SDoc
text     :: String     -> SDoc
char     :: Char       -> SDoc
ftext    :: FastString -> SDoc
338
ptext    :: LitString  -> SDoc
339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
int      :: Int        -> SDoc
integer  :: Integer    -> SDoc
float    :: Float      -> SDoc
double   :: Double     -> SDoc
rational :: Rational   -> SDoc

empty _sty      = Pretty.empty
text s _sty     = Pretty.text s
char c _sty     = Pretty.char c
ftext s _sty    = Pretty.ftext s
ptext s _sty    = Pretty.ptext s
int n _sty      = Pretty.int n
integer n _sty  = Pretty.integer n
float n _sty    = Pretty.float n
double n _sty   = Pretty.double n
rational n _sty = Pretty.rational n

parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
357 358 359 360 361

parens d sty       = Pretty.parens (d sty)
braces d sty       = Pretty.braces (d sty)
brackets d sty     = Pretty.brackets (d sty)
doubleQuotes d sty = Pretty.doubleQuotes (d sty)
362
angleBrackets d    = char '<' <> d <> char '>'
363

364 365
cparen :: Bool -> SDoc -> SDoc

mnislaih's avatar
mnislaih committed
366 367
cparen b d sty       = Pretty.cparen b (d sty)

368 369 370 371 372
-- quotes encloses something in single quotes...
-- but it omits them if the thing ends in a single quote
-- so that we don't get `foo''.  Instead we just have foo'.
quotes d sty = case show pp_d of
		 ('\'' : _) -> pp_d
373
		 _other	    -> Pretty.quotes pp_d
374 375 376
	     where
	       pp_d = d sty

377 378 379 380 381 382 383 384
semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc

semi _sty   = Pretty.semi
comma _sty  = Pretty.comma
colon _sty  = Pretty.colon
equals _sty = Pretty.equals
space _sty  = Pretty.space
Ian Lynagh's avatar
Ian Lynagh committed
385 386
dcolon _sty = Pretty.ptext (sLit "::")
arrow  _sty = Pretty.ptext (sLit "->")
387 388 389 390 391 392 393 394 395 396 397
underscore  = char '_'
dot	    = char '.'
lparen _sty = Pretty.lparen
rparen _sty = Pretty.rparen
lbrack _sty = Pretty.lbrack
rbrack _sty = Pretty.rbrack
lbrace _sty = Pretty.lbrace
rbrace _sty = Pretty.rbrace

nest :: Int -> SDoc -> SDoc
(<>), (<+>), ($$), ($+$) :: SDoc -> SDoc -> SDoc
398 399 400 401 402 403 404

nest n d sty    = Pretty.nest n (d sty)
(<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)

405 406 407
hcat, hsep, vcat, sep, cat, fsep, fcat :: [SDoc] -> SDoc


408 409 410 411 412 413 414 415
hcat ds sty = Pretty.hcat [d sty | d <- ds]
hsep ds sty = Pretty.hsep [d sty | d <- ds]
vcat ds sty = Pretty.vcat [d sty | d <- ds]
sep ds sty  = Pretty.sep  [d sty | d <- ds]
cat ds sty  = Pretty.cat  [d sty | d <- ds]
fsep ds sty = Pretty.fsep [d sty | d <- ds]
fcat ds sty = Pretty.fcat [d sty | d <- ds]

416 417
hang :: SDoc -> Int -> SDoc -> SDoc

418 419 420
hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)

punctuate :: SDoc -> [SDoc] -> [SDoc]
421
punctuate _ []     = []
422 423 424 425 426
punctuate p (d:ds) = go d ds
		   where
		     go d [] = [d]
		     go d (e:es) = (d <> p) : go e es
\end{code}
sof's avatar
sof committed
427

sof's avatar
sof committed
428 429 430 431 432 433 434 435 436

%************************************************************************
%*									*
\subsection[Outputable-class]{The @Outputable@ class}
%*									*
%************************************************************************

\begin{code}
class Outputable a where
437
	ppr :: a -> SDoc
sof's avatar
sof committed
438 439
\end{code}

440 441
\begin{code}
instance Outputable Bool where
Ian Lynagh's avatar
Ian Lynagh committed
442 443
    ppr True  = ptext (sLit "True")
    ppr False = ptext (sLit "False")
444

sof's avatar
sof committed
445
instance Outputable Int where
446
   ppr n = int n
sof's avatar
sof committed
447

448 449 450
instance Outputable Word32 where
   ppr n = integer $ fromIntegral n

451 452 453
instance Outputable () where
   ppr _ = text "()"

454
instance (Outputable a) => Outputable [a] where
455
    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
456 457

instance (Outputable a, Outputable b) => Outputable (a, b) where
458
    ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
459

460
instance Outputable a => Outputable (Maybe a) where
Ian Lynagh's avatar
Ian Lynagh committed
461 462
  ppr Nothing = ptext (sLit "Nothing")
  ppr (Just x) = ptext (sLit "Just") <+> ppr x
463

464
instance (Outputable a, Outputable b) => Outputable (Either a b) where
Ian Lynagh's avatar
Ian Lynagh committed
465 466
  ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
  ppr (Right y) = ptext (sLit "Right") <+> ppr y
467

468 469
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
470
    ppr (x,y,z) =
471 472 473 474
      parens (sep [ppr x <> comma,
		   ppr y <> comma,
		   ppr z ])

475 476
instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
	 Outputable (a, b, c, d) where
477 478 479 480 481 482 483 484 485 486 487 488 489 490
    ppr (a,b,c,d) =
      parens (sep [ppr a <> comma,
		   ppr b <> comma,
		   ppr c <> comma,
		   ppr d])

instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
	 Outputable (a, b, c, d, e) where
    ppr (a,b,c,d,e) =
      parens (sep [ppr a <> comma,
		   ppr b <> comma,
		   ppr c <> comma,
		   ppr d <> comma,
		   ppr e])
491

492
instance Outputable FastString where
493 494
    ppr fs = ftext fs		-- Prints an unadorned string,
				-- no double quotes or anything
495 496 497 498 499 500 501 502 503 504 505 506 507 508 509
\end{code}


%************************************************************************
%*									*
\subsection{The @OutputableBndr@ class}
%*									*
%************************************************************************

When we print a binder, we often want to print its type too.
The @OutputableBndr@ class encapsulates this idea.

@BindingSite@ is used to tell the thing that prints binder what
language construct is binding the identifier.  This can be used
to decide how much info to print.
510

511 512 513 514 515
\begin{code}
data BindingSite = LambdaBind | CaseBind | LetBind

class Outputable a => OutputableBndr a where
   pprBndr :: BindingSite -> a -> SDoc
516
   pprBndr _b x = ppr x
517 518 519 520 521 522 523 524 525 526 527
\end{code}



%************************************************************************
%*									*
\subsection{Random printing helpers}
%*									*
%************************************************************************

\begin{code}
528
-- We have 31-bit Chars and will simply use Show instances of Char and String.
529 530 531
pprHsChar :: Char -> SDoc
pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
            | otherwise      = text (show c)
532 533 534

pprHsString :: FastString -> SDoc
pprHsString fs = text (show (unpackFS fs))
535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569

---------------------
-- 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
sof's avatar
sof committed
570 571 572
\end{code}


sof's avatar
sof committed
573 574 575 576 577 578 579
%************************************************************************
%*									*
\subsection{Other helper functions}
%*									*
%************************************************************************

\begin{code}
580
pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
581
pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
582

583
interppSP  :: Outputable a => [a] -> SDoc
584
interppSP  xs = sep (map ppr xs)
sof's avatar
sof committed
585

586
interpp'SP :: Outputable a => [a] -> SDoc
587
interpp'SP xs = sep (punctuate comma (map ppr xs))
588 589 590 591

pprQuotedList :: Outputable a => [a] -> SDoc
-- [x,y,z]  ==>  `x', `y', `z'
pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
sof's avatar
sof committed
592 593 594 595 596 597 598 599
\end{code}


%************************************************************************
%*									*
\subsection{Printing numbers verbally}
%*									*
%************************************************************************
sof's avatar
sof committed
600 601 602 603 604

@speakNth@ converts an integer to a verbal index; eg 1 maps to
``first'' etc.

\begin{code}
605
speakNth :: Int -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
606 607 608 609 610 611
speakNth 1 = ptext (sLit "first")
speakNth 2 = ptext (sLit "second")
speakNth 3 = ptext (sLit "third")
speakNth 4 = ptext (sLit "fourth")
speakNth 5 = ptext (sLit "fifth")
speakNth 6 = ptext (sLit "sixth")
612
speakNth n = hcat [ int n, text suffix ]
sof's avatar
sof committed
613
  where
614 615 616 617 618
    suffix | n <= 20       = "th"	-- 11,12,13 are non-std
	   | last_dig == 1 = "st"
	   | last_dig == 2 = "nd"
	   | last_dig == 3 = "rd"
	   | otherwise     = "th"
sof's avatar
sof committed
619

620
    last_dig = n `rem` 10
621

622
speakN :: Int -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
623 624 625 626 627 628 629
speakN 0 = ptext (sLit "none")	-- E.g.  "he has none"
speakN 1 = ptext (sLit "one")	-- E.g.  "he has one"
speakN 2 = ptext (sLit "two")
speakN 3 = ptext (sLit "three")
speakN 4 = ptext (sLit "four")
speakN 5 = ptext (sLit "five")
speakN 6 = ptext (sLit "six")
630 631
speakN n = int n

632
speakNOf :: Int -> SDoc -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
633 634
speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'	-- E.g. "no arguments"
speakNOf 1 d = ptext (sLit "one") <+> d			-- E.g. "one argument"
635 636
speakNOf n d = speakN n <+> d <> char 's'		-- E.g. "three arguments"

637
speakNTimes :: Int {- >=1 -} -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
638 639 640
speakNTimes t | t == 1 	   = ptext (sLit "once")
              | t == 2 	   = ptext (sLit "twice")
              | otherwise  = speakN t <+> ptext (sLit "times")
641

642 643 644
plural :: [a] -> SDoc
plural [_] = empty  -- a bit frightening, but there you are
plural _   = char 's'
645 646
\end{code}

647

648 649
%************************************************************************
%*									*
650
\subsection{Error handling}
651 652 653 654
%*									*
%************************************************************************

\begin{code}
655
pprPanic, pprPgmError :: String -> SDoc -> a
656
pprTrace :: String -> SDoc -> a -> a
657 658 659 660
pprPanic    = pprAndThen panic		-- Throw an exn saying "bug in GHC"

pprPgmError = pprAndThen pgmError	-- Throw an exn saying "bug in pgm being compiled"
					--	(used for unusual pgm errors)
Simon Marlow's avatar
Simon Marlow committed
661 662 663
pprTrace str doc x
   | opt_NoDebugOutput = x
   | otherwise         = pprAndThen trace str doc x
664

665 666
pprPanicFastInt :: String -> SDoc -> FastInt
pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
667 668 669
			     where
			       doc = text heading <+> pretty_msg

sof's avatar
sof committed
670 671 672
pprAndThen :: (String -> a) -> String -> SDoc -> a
pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
    where
673
     doc = sep [text heading, nest 4 pretty_msg]
sof's avatar
sof committed
674

675 676 677 678 679 680 681 682
assertPprPanic :: String -> Int -> SDoc -> a
assertPprPanic file line msg
  = panic (show (doc PprDebug))
  where
    doc = sep [hsep[text "ASSERT failed! file", 
		 	   text file, 
			   text "line", int line], 
		    msg]
683 684

warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
Simon Marlow's avatar
Simon Marlow committed
685
warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
686 687
warnPprTrace False _file _line _msg x = x
warnPprTrace True   file  line  msg x
688 689 690 691
  = trace (show (doc PprDebug)) x
  where
    doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
	       msg]
692
\end{code}