Outputable.lhs 24.9 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
6
%

\begin{code}
batterseapower's avatar
batterseapower committed
7
8
9
10
11
12
-- | This module defines classes and functions for pretty-printing. It also
-- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
--
-- The interface to this module is very similar to the standard Hughes-PJ pretty printing
-- module, except that it exports a number of additional functions that are rarely used,
-- and works over the 'SDoc' type.
13
module Outputable (
batterseapower's avatar
batterseapower committed
14
15
	-- * Type classes
	Outputable(..), OutputableBndr(..),
16

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

batterseapower's avatar
batterseapower committed
35
        -- * Converting 'SDoc' into strings and outputing it
36
	printSDoc, printErrs, hPrintDump, printDump,
37
	printForC, printForAsm, printForUser, printForUserPartWay,
38
	pprCode, mkCodeStyle,
39
	showSDoc, showSDocForUser, showSDocDebug, showSDocDump, showPpr,
40
	showSDocUnqual, showsPrecSDoc,
41
42
43

	pprInfixVar, pprPrefixVar,
	pprHsChar, pprHsString, pprHsInfix, pprHsVar,
44
    pprFastFilePath,
45

batterseapower's avatar
batterseapower committed
46
47
48
49
50
51
52
53
54
55
        -- * Controlling the style in which output is printed
	BindingSite(..),

	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
        QualifyName(..),
	getPprStyle, withPprStyle, withPprStyleDoc, 
	pprDeeper, pprDeeperList, pprSetDepth,
	codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
	ifPprDebug, qualName, qualModule,
	mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
56
        mkUserStyle, Depth(..),
batterseapower's avatar
batterseapower committed
57
58

	-- * Error handling and debugging utilities
59
	pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, 
60
	pprTrace, warnPprTrace,
61
	trace, pgmError, panic, panicFastInt, assertPanic
62
63
    ) where

64
import {-# SOURCE #-} 	Module( Module, ModuleName, moduleName )
65
import {-# SOURCE #-} 	OccName( OccName )
66

Simon Marlow's avatar
Simon Marlow committed
67
import StaticFlags
68
import FastString 
69
import FastTypes
70
import qualified Pretty
71
import Pretty		( Doc, Mode(..) )
72
import Char		( isAlpha )
73
import Panic
74

Simon Marlow's avatar
Simon Marlow committed
75
76
77
import Data.Word	( Word32 )
import System.IO	( Handle, stderr, stdout, hFlush )
import Data.Char        ( ord )
78
import System.FilePath
79
80
\end{code}

sof's avatar
sof committed
81

82
83
%************************************************************************
%*									*
sof's avatar
sof committed
84
\subsection{The @PprStyle@ data type}
85
86
87
88
%*									*
%************************************************************************

\begin{code}
89

sof's avatar
sof committed
90
data PprStyle
91
92
93
94
95
96
  = 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
97

98
99
  | PprCode CodeStyle
		-- Print code; either C or assembler
sof's avatar
sof committed
100

101
102
103
104
105
  | PprDump	-- For -ddump-foo; less verbose than PprDebug.
		-- Does not assume tidied code: non-external names
		-- are printed with uniques.

  | PprDebug	-- Full debugging output
106

107
108
109
110
111
data CodeStyle = CStyle		-- The format of labels differs for C and assembler
	       | AsmStyle

data Depth = AllTheWay
           | PartWay Int	-- 0 => stop
112
113


Simon Marlow's avatar
Simon Marlow committed
114
115
-- -----------------------------------------------------------------------------
-- Printing original names
116

Simon Marlow's avatar
Simon Marlow committed
117
118
119
120
121
122
123
124
125
126
127
-- 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.
128
129
130
131
132
133
134
135
136
137
138
139
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
140
141

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

145
type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
Simon Marlow's avatar
Simon Marlow committed
146

147
alwaysQualifyNames :: QueryQualifyName
148
alwaysQualifyNames m _ = NameQual (moduleName m)
Simon Marlow's avatar
Simon Marlow committed
149

150
neverQualifyNames :: QueryQualifyName
151
neverQualifyNames _ _ = NameUnqual
Simon Marlow's avatar
Simon Marlow committed
152

153
alwaysQualifyModules :: QueryQualifyModule
154
alwaysQualifyModules _ = True
Simon Marlow's avatar
Simon Marlow committed
155

156
neverQualifyModules :: QueryQualifyModule
157
158
neverQualifyModules _ = False

159
alwaysQualify, neverQualify :: PrintUnqualified
Simon Marlow's avatar
Simon Marlow committed
160
161
alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
neverQualify  = (neverQualifyNames,  neverQualifyModules)
162

163
164
defaultUserStyle, defaultDumpStyle :: PprStyle

165
166
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay

167
168
169
defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
		 |  otherwise          = PprDump

Simon Marlow's avatar
Simon Marlow committed
170
-- | Style for printing error messages
171
mkErrStyle :: PrintUnqualified -> PprStyle
Simon Marlow's avatar
Simon Marlow committed
172
mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
173
174
175
176
177
178

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
179
180
  | opt_PprStyle_Debug   = mkUserStyle alwaysQualify AllTheWay
  | otherwise            = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
181

182
mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
Simon Marlow's avatar
Simon Marlow committed
183
184
185
mkUserStyle unqual depth
   | opt_PprStyle_Debug = PprDebug
   | otherwise          = PprUser unqual depth
sof's avatar
sof committed
186
\end{code}
187

sof's avatar
sof committed
188
189
190
191
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
192

sof's avatar
sof committed
193
194
The following test decides whether or not we are actually generating
code (either C or assembly), or generating interface files.
195
196
197
198
199
200
201
202
203
204
205

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

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

withPprStyle :: PprStyle -> SDoc -> SDoc
206
withPprStyle sty d _sty' = d sty
207

208
209
210
withPprStyleDoc :: PprStyle -> SDoc -> Doc
withPprStyleDoc sty d = d sty

211
pprDeeper :: SDoc -> SDoc
212
pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
Simon Marlow's avatar
Simon Marlow committed
213
214
pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
pprDeeper d other_sty        	    = d other_sty
215

216
217
218
219
220
221
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
222
    go _ [] = []
223
224
225
226
227
228
    go i (d:ds) | i >= n    = [text "...."]
		| otherwise = d : go (i+1) ds

pprDeeperList f ds other_sty
  = f ds other_sty

229
pprSetDepth :: Int -> SDoc -> SDoc
230
231
pprSetDepth  n d (PprUser q _) = d (PprUser q (PartWay n))
pprSetDepth _n d other_sty     = d other_sty
232

233
234
235
236
getPprStyle :: (PprStyle -> SDoc) -> SDoc
getPprStyle df sty = df sty sty
\end{code}

sof's avatar
sof committed
237
\begin{code}
238
qualName :: PprStyle -> QueryQualifyName
239
240
qualName (PprUser (qual_name,_) _) m  n = qual_name m n
qualName _other		           m _n = NameQual (moduleName m)
Simon Marlow's avatar
Simon Marlow committed
241

242
qualModule :: PprStyle -> QueryQualifyModule
243
244
qualModule (PprUser (_,qual_mod) _)  m = qual_mod m
qualModule _other                   _m = True
245

sof's avatar
sof committed
246
codeStyle :: PprStyle -> Bool
247
codeStyle (PprCode _)	  = True
sof's avatar
sof committed
248
249
codeStyle _		  = False

250
251
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle)  = True
252
asmStyle _other              = False
253

254
255
dumpStyle :: PprStyle -> Bool
dumpStyle PprDump = True
256
dumpStyle _other  = False
257

258
259
debugStyle :: PprStyle -> Bool
debugStyle PprDebug	  = True
260
debugStyle _other	  = False
261

sof's avatar
sof committed
262
userStyle ::  PprStyle -> Bool
263
userStyle (PprUser _ _) = True
264
userStyle _other        = False
sof's avatar
sof committed
265

266
267
ifPprDebug :: SDoc -> SDoc	  -- Empty for non-debug style
ifPprDebug d sty@PprDebug = d sty
268
ifPprDebug _ _  	  = Pretty.empty
sof's avatar
sof committed
269
\end{code}
270

sof's avatar
sof committed
271
\begin{code}
sof's avatar
sof committed
272
-- Unused [7/02 sof]
273
printSDoc :: SDoc -> PprStyle -> IO ()
sof's avatar
sof committed
274
275
276
printSDoc d sty = do
  Pretty.printDoc PageMode stdout (d sty)
  hFlush stdout
277

278
-- I'm not sure whether the direct-IO approach of Pretty.printDoc
279
-- above is better or worse than the put-big-string approach here
280
281
282
printErrs :: Doc -> IO ()
printErrs doc = do Pretty.printDoc PageMode stderr doc
		   hFlush stderr
283
284

printDump :: SDoc -> IO ()
285
286
287
288
289
290
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
291
292
 where
   better_doc = doc $$ text ""
293

294
295
printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser handle unqual doc 
296
  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
297

298
299
300
301
printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
printForUserPartWay handle d unqual doc
  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))

302
-- printForC, printForAsm do what they sound like
303
printForC :: Handle -> SDoc -> IO ()
304
printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
305
306

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

sof's avatar
sof committed
309
310
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
311

312
313
314
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

315
316
-- Can't make SDoc an instance of Show because SDoc is just a function type
-- However, Doc *is* an instance of Show
317
318
-- showSDoc just blasts it out as a string
showSDoc :: SDoc -> String
319
showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
320

321
322
323
showSDocForUser :: PrintUnqualified -> SDoc -> String
showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))

324
showSDocUnqual :: SDoc -> String
325
-- Only used in the gruesome isOperator
326
327
328
329
showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))

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

331
332
333
showSDocDump :: SDoc -> String
showSDocDump d = show (d PprDump)

334
335
showSDocDebug :: SDoc -> String
showSDocDebug d = show (d PprDebug)
336
337
338

showPpr :: Outputable a => a -> String
showPpr = showSDoc . ppr
339
340
\end{code}

341
\begin{code}
342
343
344
docToSDoc :: Doc -> SDoc
docToSDoc d = \_ -> d

345
346
empty    :: SDoc
char     :: Char       -> SDoc
batterseapower's avatar
batterseapower committed
347
text     :: String     -> SDoc
348
ftext    :: FastString -> SDoc
349
ptext    :: LitString  -> SDoc
350
351
352
353
354
355
356
357
int      :: Int        -> SDoc
integer  :: Integer    -> SDoc
float    :: Float      -> SDoc
double   :: Double     -> SDoc
rational :: Rational   -> SDoc

empty _sty      = Pretty.empty
char c _sty     = Pretty.char c
batterseapower's avatar
batterseapower committed
358
text s _sty     = Pretty.text s
359
360
361
362
363
364
365
366
367
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
368
369
370
371
372

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)
373
angleBrackets d    = char '<' <> d <> char '>'
374

375
376
cparen :: Bool -> SDoc -> SDoc

mnislaih's avatar
mnislaih committed
377
378
cparen b d sty       = Pretty.cparen b (d sty)

379
380
381
382
383
-- 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
384
		 _other	    -> Pretty.quotes pp_d
385
386
387
	     where
	       pp_d = d sty

388
389
390
391
392
393
394
395
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
396
397
dcolon _sty = Pretty.ptext (sLit "::")
arrow  _sty = Pretty.ptext (sLit "->")
398
399
400
401
402
403
404
405
406
407
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
batterseapower's avatar
batterseapower committed
408
409
410
411
412
413
414
415
416
417
-- ^ Indent 'SDoc' some specified amount
(<>) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together horizontally without a gap
(<+>) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together horizontally with a gap between them
($$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically; if there is 
-- no vertical overlap it "dovetails" the two onto one line
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
418
419
420
421
422
423
424

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)

batterseapower's avatar
batterseapower committed
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
hcat :: [SDoc] -> SDoc
-- ^ Concatenate 'SDoc' horizontally
hsep :: [SDoc] -> SDoc
-- ^ Concatenate 'SDoc' horizontally with a space between each one
vcat :: [SDoc] -> SDoc
-- ^ Concatenate 'SDoc' vertically with dovetailing
sep :: [SDoc] -> SDoc
-- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
cat :: [SDoc] -> SDoc
-- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
fsep :: [SDoc] -> SDoc
-- ^ A paragraph-fill combinator. It's much like sep, only it
-- keeps fitting things on one line until it can't fit any more.
fcat :: [SDoc] -> SDoc
-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
440
441


442
443
444
445
446
447
448
449
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]

batterseapower's avatar
batterseapower committed
450
451
452
453
hang :: SDoc  -- ^ The header
      -> Int  -- ^ Amount to indent the hung body
      -> SDoc -- ^ The hung body, indented and placed below the header
      -> SDoc
454
455
hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)

batterseapower's avatar
batterseapower committed
456
457
458
punctuate :: SDoc   -- ^ The punctuation
          -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
          -> [SDoc] -- ^ Punctuated list
459
punctuate _ []     = []
460
461
462
463
464
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
465

sof's avatar
sof committed
466
467
468
469
470
471
472
473

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

\begin{code}
batterseapower's avatar
batterseapower committed
474
-- | Class designating that some type has an 'SDoc' representation
sof's avatar
sof committed
475
class Outputable a where
476
	ppr :: a -> SDoc
sof's avatar
sof committed
477
478
\end{code}

479
480
\begin{code}
instance Outputable Bool where
Ian Lynagh's avatar
Ian Lynagh committed
481
482
    ppr True  = ptext (sLit "True")
    ppr False = ptext (sLit "False")
483

sof's avatar
sof committed
484
instance Outputable Int where
485
   ppr n = int n
sof's avatar
sof committed
486

487
488
489
instance Outputable Word32 where
   ppr n = integer $ fromIntegral n

490
491
492
instance Outputable () where
   ppr _ = text "()"

493
instance (Outputable a) => Outputable [a] where
494
    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
495
496

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

499
instance Outputable a => Outputable (Maybe a) where
Ian Lynagh's avatar
Ian Lynagh committed
500
501
  ppr Nothing = ptext (sLit "Nothing")
  ppr (Just x) = ptext (sLit "Just") <+> ppr x
502

503
instance (Outputable a, Outputable b) => Outputable (Either a b) where
Ian Lynagh's avatar
Ian Lynagh committed
504
505
  ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
  ppr (Right y) = ptext (sLit "Right") <+> ppr y
506

507
508
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
509
    ppr (x,y,z) =
510
511
512
513
      parens (sep [ppr x <> comma,
		   ppr y <> comma,
		   ppr z ])

514
515
instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
	 Outputable (a, b, c, d) where
516
517
518
519
520
521
522
523
524
525
526
527
528
529
    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])
530

531
instance Outputable FastString where
532
533
    ppr fs = ftext fs		-- Prints an unadorned string,
				-- no double quotes or anything
534
535
536
537
538
539
540
541
542
\end{code}

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

\begin{code}
batterseapower's avatar
batterseapower committed
543
544
545
-- | '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.
546
547
data BindingSite = LambdaBind | CaseBind | LetBind

batterseapower's avatar
batterseapower committed
548
549
-- | When we print a binder, we often want to print its type too.
-- The @OutputableBndr@ class encapsulates this idea.
550
551
class Outputable a => OutputableBndr a where
   pprBndr :: BindingSite -> a -> SDoc
552
   pprBndr _b x = ppr x
553
554
555
556
557
558
559
560
561
\end{code}

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

\begin{code}
562
-- We have 31-bit Chars and will simply use Show instances of Char and String.
batterseapower's avatar
batterseapower committed
563
564

-- | Special combinator for showing character literals.
565
566
567
pprHsChar :: Char -> SDoc
pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
            | otherwise      = text (show c)
568

batterseapower's avatar
batterseapower committed
569
-- | Special combinator for showing string literals.
570
571
pprHsString :: FastString -> SDoc
pprHsString fs = text (show (unpackFS fs))
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606

---------------------
-- 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
607
608
609

pprFastFilePath :: FastString -> SDoc
pprFastFilePath path = text $ normalise $ unpackFS path
sof's avatar
sof committed
610
611
\end{code}

sof's avatar
sof committed
612
613
614
615
616
617
618
%************************************************************************
%*									*
\subsection{Other helper functions}
%*									*
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
619
620
621
622
pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
              -> [a]         -- ^ The things to be pretty printed
              -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,
                             -- comma-separated and finally packed into a paragraph.
623
pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
624

batterseapower's avatar
batterseapower committed
625
-- | Returns the seperated concatenation of the pretty printed things.
626
interppSP  :: Outputable a => [a] -> SDoc
627
interppSP  xs = sep (map ppr xs)
sof's avatar
sof committed
628

batterseapower's avatar
batterseapower committed
629
-- | Returns the comma-seperated concatenation of the pretty printed things.
630
interpp'SP :: Outputable a => [a] -> SDoc
631
interpp'SP xs = sep (punctuate comma (map ppr xs))
632

batterseapower's avatar
batterseapower committed
633
634
635
-- | Returns the comma-seperated concatenation of the quoted pretty printed things.
--
-- > [x,y,z]  ==>  `x', `y', `z'
636
637
pprQuotedList :: Outputable a => [a] -> SDoc
pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
sof's avatar
sof committed
638
639
640
641
642
643
644
645
\end{code}


%************************************************************************
%*									*
\subsection{Printing numbers verbally}
%*									*
%************************************************************************
sof's avatar
sof committed
646
647

\begin{code}
batterseapower's avatar
batterseapower committed
648
649
650
651
652
-- | Converts an integer to a verbal index:
--
-- > speakNth 1 = text "first"
-- > speakNth 5 = text "fifth"
-- > speakNth 21 = text "21st"
653
speakNth :: Int -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
654
655
656
657
658
659
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")
660
speakNth n = hcat [ int n, text suffix ]
sof's avatar
sof committed
661
  where
662
663
664
665
666
    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
667

668
    last_dig = n `rem` 10
669

batterseapower's avatar
batterseapower committed
670
671
672
673
674
-- | Converts an integer to a verbal multiplicity:
-- 
-- > speakN 0 = text "none"
-- > speakN 5 = text "five"
-- > speakN 10 = text "10"
675
speakN :: Int -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
676
677
678
679
680
681
682
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")
683
684
speakN n = int n

batterseapower's avatar
batterseapower committed
685
686
687
688
689
690
-- | Converts an integer and object description to a statement about the
-- multiplicity of those objects:
--
-- > speakNOf 0 (text "melon") = text "no melons"
-- > speakNOf 1 (text "melon") = text "one melon"
-- > speakNOf 3 (text "melon") = text "three melons"
691
speakNOf :: Int -> SDoc -> SDoc
batterseapower's avatar
batterseapower committed
692
speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
Ian Lynagh's avatar
Ian Lynagh committed
693
speakNOf 1 d = ptext (sLit "one") <+> d			-- E.g. "one argument"
694
695
speakNOf n d = speakN n <+> d <> char 's'		-- E.g. "three arguments"

batterseapower's avatar
batterseapower committed
696
697
698
699
700
-- | Converts a strictly positive integer into a number of times:
--
-- > speakNTimes 1 = text "once"
-- > speakNTimes 2 = text "twice"
-- > speakNTimes 4 = text "4 times"
701
speakNTimes :: Int {- >=1 -} -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
702
703
704
speakNTimes t | t == 1 	   = ptext (sLit "once")
              | t == 2 	   = ptext (sLit "twice")
              | otherwise  = speakN t <+> ptext (sLit "times")
705

batterseapower's avatar
batterseapower committed
706
707
708
709
710
-- | Determines the pluralisation suffix appropriate for the length of a list:
--
-- > plural [] = char 's'
-- > plural ["Hello"] = empty
-- > plural ["Hello", "World"] = char 's'
711
712
713
plural :: [a] -> SDoc
plural [_] = empty  -- a bit frightening, but there you are
plural _   = char 's'
714
715
\end{code}

716

717
718
%************************************************************************
%*									*
719
\subsection{Error handling}
720
721
722
723
%*									*
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
724
725
726
727
pprPanic :: String -> SDoc -> a
-- ^ Throw an exception saying "bug in GHC"
pprPgmError :: String -> SDoc -> a
-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
728
pprTrace :: String -> SDoc -> a -> a
batterseapower's avatar
batterseapower committed
729
730
731
732
733
-- ^ If debug output is on, show some 'SDoc' on the screen

pprPanic    = pprAndThen panic

pprPgmError = pprAndThen pgmError
734

Simon Marlow's avatar
Simon Marlow committed
735
736
737
pprTrace str doc x
   | opt_NoDebugOutput = x
   | otherwise         = pprAndThen trace str doc x
738

739
pprPanicFastInt :: String -> SDoc -> FastInt
batterseapower's avatar
batterseapower committed
740
-- ^ Specialization of pprPanic that can be safely used with 'FastInt'
741
pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
742
743
744
			     where
			       doc = text heading <+> pretty_msg

sof's avatar
sof committed
745
746
747
pprAndThen :: (String -> a) -> String -> SDoc -> a
pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
    where
748
     doc = sep [text heading, nest 4 pretty_msg]
sof's avatar
sof committed
749

750
assertPprPanic :: String -> Int -> SDoc -> a
batterseapower's avatar
batterseapower committed
751
752
-- ^ Panic with an assertation failure, recording the given file and line number.
-- Should typically be accessed with the ASSERT family of macros
753
754
755
756
757
758
759
assertPprPanic file line msg
  = panic (show (doc PprDebug))
  where
    doc = sep [hsep[text "ASSERT failed! file", 
		 	   text file, 
			   text "line", int line], 
		    msg]
760
761

warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
batterseapower's avatar
batterseapower committed
762
763
-- ^ Just warn about an assertion failure, recording the given file and line number.
-- Should typically be accessed with the WARN macros
Simon Marlow's avatar
Simon Marlow committed
764
warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
765
766
warnPprTrace False _file _line _msg x = x
warnPprTrace True   file  line  msg x
767
768
769
770
  = trace (show (doc PprDebug)) x
  where
    doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
	       msg]
771
\end{code}