Outputable.lhs 14.2 KB
Newer Older
1
%
2
% (c) The GRASP Project, Glasgow University, 1992-1998
3
4
5
6
7
8
9
%
\section[Outputable]{Classes for pretty-printing}

Defines classes for pretty-printing and forcing, both forms of
``output.''

\begin{code}
10

11
module Outputable (
12
13
14
	Outputable(..), OutputableBndr(..),	-- Class

	BindingSite(..),
15

16
	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
17
	getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
18
	codeStyle, userStyle, debugStyle, asmStyle,
19
20
	ifPprDebug, unqualStyle, 
	mkErrStyle, defaultErrStyle,
21
22

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

38
	printSDoc, printErrs, printDump,
39
	printForC, printForAsm, printForUser,
40
	pprCode, mkCodeStyle,
41
	showSDoc, showSDocForUser, showSDocDebug,
42
	showSDocUnqual, showsPrecSDoc,
43
	pprHsChar, pprHsString,
44

45
46

	-- error handling
47
48
	pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
	trace, panic, panic#, assertPanic
49
50
    ) where

51
#include "HsVersions.h"
sof's avatar
sof committed
52

53

54
55
import {-# SOURCE #-} 	Name( Name )

56
import CmdLineOpts	( opt_PprStyle_Debug, opt_PprUserLength )
sof's avatar
sof committed
57
import FastString
58
import qualified Pretty
59
import Pretty		( Doc, Mode(..) )
60
import Panic
61

62
63
import DATA_WORD	( Word32 )

sof's avatar
sof committed
64
import IO		( Handle, stderr, stdout, hFlush )
65
import Char             ( ord )
66
67
\end{code}

sof's avatar
sof committed
68

69
70
%************************************************************************
%*									*
sof's avatar
sof committed
71
\subsection{The @PprStyle@ data type}
72
73
74
75
%*									*
%************************************************************************

\begin{code}
sof's avatar
sof committed
76
data PprStyle
77
78
79
80
  = PprUser PrintUnqualified Depth	-- Pretty-print in a way that will
					-- make sense to the ordinary user;
					-- must be very close to Haskell
					-- syntax, etc.
sof's avatar
sof committed
81

82
  | PprCode CodeStyle		-- Print code; either C or assembler
sof's avatar
sof committed
83

84
  | PprDebug			-- Standard debugging output
85

86
87
88
89
90
data CodeStyle = CStyle		-- The format of labels differs for C and assembler
	       | AsmStyle

data Depth = AllTheWay
           | PartWay Int	-- 0 => stop
91
92
93
94
95
96
97
98
99
100
101
102


type PrintUnqualified = Name -> Bool
	-- This function tells when it's ok to print 
	-- a (Global) name unqualified

alwaysQualify,neverQualify :: PrintUnqualified
alwaysQualify n = False
neverQualify  n = True

defaultUserStyle = mkUserStyle alwaysQualify AllTheWay

103
104
105
106
107
108
109
110
111
112
mkErrStyle :: PrintUnqualified -> PprStyle
-- Style for printing error messages
mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)

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 
  | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
113
  | otherwise	       = mkUserStyle alwaysQualify  (PartWay opt_PprUserLength)
114

115
116
mkUserStyle unqual depth |  opt_PprStyle_Debug = PprDebug
	          	 |  otherwise          = PprUser unqual depth
sof's avatar
sof committed
117
\end{code}
118

sof's avatar
sof committed
119
120
121
122
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
123

sof's avatar
sof committed
124
125
The following test decides whether or not we are actually generating
code (either C or assembly), or generating interface files.
126
127
128
129
130
131
132
133
134
135
136
137
138

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

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

withPprStyle :: PprStyle -> SDoc -> SDoc
withPprStyle sty d sty' = d sty

139
140
141
withPprStyleDoc :: PprStyle -> SDoc -> Doc
withPprStyleDoc sty d = d sty

142
pprDeeper :: SDoc -> SDoc
143
144
145
pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
pprDeeper d other_sty        		 = d other_sty
146
147
148
149
150

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

sof's avatar
sof committed
151
\begin{code}
152
153
154
155
unqualStyle :: PprStyle -> Name -> Bool
unqualStyle (PprUser    unqual _) n = unqual n
unqualStyle other		  n = False

sof's avatar
sof committed
156
codeStyle :: PprStyle -> Bool
157
codeStyle (PprCode _)	  = True
sof's avatar
sof committed
158
159
codeStyle _		  = False

160
161
162
163
164
165
166
167
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle)  = True
asmStyle other               = False

debugStyle :: PprStyle -> Bool
debugStyle PprDebug	  = True
debugStyle other	  = False

sof's avatar
sof committed
168
userStyle ::  PprStyle -> Bool
169
170
userStyle (PprUser _ _) = True
userStyle other         = False
sof's avatar
sof committed
171

172
173
174
ifPprDebug :: SDoc -> SDoc	  -- Empty for non-debug style
ifPprDebug d sty@PprDebug = d sty
ifPprDebug d sty	  = Pretty.empty
sof's avatar
sof committed
175
\end{code}
176

sof's avatar
sof committed
177
\begin{code}
sof's avatar
sof committed
178
-- Unused [7/02 sof]
179
printSDoc :: SDoc -> PprStyle -> IO ()
sof's avatar
sof committed
180
181
182
printSDoc d sty = do
  Pretty.printDoc PageMode stdout (d sty)
  hFlush stdout
183

184
-- I'm not sure whether the direct-IO approach of Pretty.printDoc
185
-- above is better or worse than the put-big-string approach here
186
187
188
printErrs :: Doc -> IO ()
printErrs doc = do Pretty.printDoc PageMode stderr doc
		   hFlush stderr
189
190

printDump :: SDoc -> IO ()
sof's avatar
sof committed
191
192
193
194
195
196
197
printDump doc = do
   Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
   hFlush stdout
 where
   better_doc = doc $$ text ""
    -- We used to always print in debug style, but I want
    -- to try the effect of a more user-ish style (unless you
198
    -- say -dppr-debug)
199

200
201
printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser handle unqual doc 
202
  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
203

204
-- printForC, printForAsm do what they sound like
205
printForC :: Handle -> SDoc -> IO ()
206
printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
207
208

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

sof's avatar
sof committed
211
212
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
213

214
215
216
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

217
218
-- Can't make SDoc an instance of Show because SDoc is just a function type
-- However, Doc *is* an instance of Show
219
220
-- showSDoc just blasts it out as a string
showSDoc :: SDoc -> String
221
222
showSDoc d = show (d defaultUserStyle)

223
224
225
showSDocForUser :: PrintUnqualified -> SDoc -> String
showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))

226
227
228
229
230
231
showSDocUnqual :: SDoc -> String
-- Only used in the gruesome HsExpr.isOperator
showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))

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

233
234
showSDocDebug :: SDoc -> String
showSDocDebug d = show (d PprDebug)
235
236
\end{code}

237
\begin{code}
238
239
240
docToSDoc :: Doc -> SDoc
docToSDoc d = \_ -> d

241
242
243
empty sty      = Pretty.empty
text s sty     = Pretty.text s
char c sty     = Pretty.char c
244
ftext s sty    = Pretty.ftext s
245
246
247
248
249
250
251
252
253
254
255
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 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)
256
angleBrackets d    = char '<' <> d <> char '>'
257

258
259
260
261
262
263
264
265
266
-- 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
		 other	    -> Pretty.quotes pp_d
	     where
	       pp_d = d sty

267
268
269
270
271
272
273
274
275
276
277
semi sty   = Pretty.semi
comma sty  = Pretty.comma
colon sty  = Pretty.colon
equals sty = Pretty.equals
space sty  = Pretty.space
lparen sty = Pretty.lparen
rparen sty = Pretty.rparen
lbrack sty = Pretty.lbrack
rbrack sty = Pretty.rbrack
lbrace sty = Pretty.lbrace
rbrace sty = Pretty.rbrace
278
dcolon sty = Pretty.ptext SLIT("::")
279
arrow  sty = Pretty.ptext SLIT("->")
280
281
underscore = char '_'
dot	   = char '.'
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305

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)

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]

hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)

punctuate :: SDoc -> [SDoc] -> [SDoc]
punctuate p []     = []
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
306

sof's avatar
sof committed
307
308
309
310
311
312
313
314
315

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

\begin{code}
class Outputable a where
316
	ppr :: a -> SDoc
sof's avatar
sof committed
317
318
\end{code}

319
320
\begin{code}
instance Outputable Bool where
321
    ppr True  = ptext SLIT("True")
322
    ppr False = ptext SLIT("False")
323

sof's avatar
sof committed
324
instance Outputable Int where
325
   ppr n = int n
sof's avatar
sof committed
326

327
328
329
instance Outputable () where
   ppr _ = text "()"

330
instance (Outputable a) => Outputable [a] where
331
    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
332
333

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

336
instance Outputable a => Outputable (Maybe a) where
337
338
  ppr Nothing = ptext SLIT("Nothing")
  ppr (Just x) = ptext SLIT("Just") <+> ppr x
339

340
341
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
342
    ppr (x,y,z) =
343
344
345
346
      parens (sep [ppr x <> comma,
		   ppr y <> comma,
		   ppr z ])

347
348
349
350
351
352
353
354
instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
	 Outputable (a, b, c, d) where
    ppr (x,y,z,w) =
      parens (sep [ppr x <> comma,
		   ppr y <> comma,
		   ppr z <> comma,
		   ppr w])

355
356
357
instance Outputable FastString where
    ppr fs = text (unpackFS fs)		-- Prints an unadorned string,
					-- no double quotes or anything
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
\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.
373

374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
\begin{code}
data BindingSite = LambdaBind | CaseBind | LetBind

class Outputable a => OutputableBndr a where
   pprBndr :: BindingSite -> a -> SDoc
   pprBndr b x = ppr x
\end{code}



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

\begin{code}
391
392
393
-- We have 31-bit Chars and will simply use Show instances
-- of Char and String.

394
395
396
pprHsChar :: Char -> SDoc
pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
            | otherwise      = text (show c)
397
398
399
400

pprHsString :: FastString -> SDoc
pprHsString fs = text (show (unpackFS fs))

401
402
instance Show FastString  where
    showsPrec p fs = showsPrecSDoc p (ppr fs)
sof's avatar
sof committed
403
404
405
\end{code}


sof's avatar
sof committed
406
407
408
409
410
411
412
%************************************************************************
%*									*
\subsection{Other helper functions}
%*									*
%************************************************************************

\begin{code}
413
pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
414
pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
415

416
interppSP  :: Outputable a => [a] -> SDoc
417
interppSP  xs = sep (map ppr xs)
sof's avatar
sof committed
418

419
interpp'SP :: Outputable a => [a] -> SDoc
420
interpp'SP xs = sep (punctuate comma (map ppr xs))
421
422
423
424

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
425
426
427
428
429
430
431
432
\end{code}


%************************************************************************
%*									*
\subsection{Printing numbers verbally}
%*									*
%************************************************************************
sof's avatar
sof committed
433
434
435
436
437

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

\begin{code}
438
speakNth :: Int -> SDoc
sof's avatar
sof committed
439
440
441
442
443
444
445

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")
446
speakNth n = hcat [ int n, text suffix ]
sof's avatar
sof committed
447
  where
448
449
450
451
452
    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
453

454
    last_dig = n `rem` 10
455
\end{code}
456
457
458
459
460
461
462
463

\begin{code}
speakNTimes :: Int {- >=1 -} -> SDoc
speakNTimes t | t == 1 	   = ptext SLIT("once")
              | t == 2 	   = ptext SLIT("twice")
              | otherwise  = int t <+> ptext SLIT("times")
\end{code}

464

465
466
%************************************************************************
%*									*
467
\subsection{Error handling}
468
469
470
471
%*									*
%************************************************************************

\begin{code}
472
473
474
pprPanic :: String -> SDoc -> a
pprError :: String -> SDoc -> a
pprTrace :: String -> SDoc -> a -> a
sof's avatar
sof committed
475
476
477
pprPanic  = pprAndThen panic
pprError  = pprAndThen error
pprTrace  = pprAndThen trace
478
479
480
481
482

pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
			     where
			       doc = text heading <+> pretty_msg

sof's avatar
sof committed
483
484
485
pprAndThen :: (String -> a) -> String -> SDoc -> a
pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
    where
486
     doc = sep [text heading, nest 4 pretty_msg]
sof's avatar
sof committed
487

488
489
490
491
492
493
494
495
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]
496
497
498
499
500
501
502
503

warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
warnPprTrace False file line msg x = x
warnPprTrace True  file line msg x
  = trace (show (doc PprDebug)) x
  where
    doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
	       msg]
504
\end{code}