Outputable.lhs 33.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
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 (
dterei's avatar
dterei committed
14
15
        -- * Type classes
        Outputable(..), OutputableBndr(..),
16

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

37
        coloured, PprColour, colType, colCoerc, colDataCon,
Thomas Schilling's avatar
Thomas Schilling committed
38
        colBinder, bold, keyword,
39

batterseapower's avatar
batterseapower committed
40
        -- * Converting 'SDoc' into strings and outputing it
41
        hPrintDump,
dterei's avatar
dterei committed
42
43
44
        printForC, printForAsm, printForUser, printForUserPartWay,
        pprCode, mkCodeStyle,
        showSDoc, showSDocOneLine,
45
46
        showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
        showPpr,
Ian Lynagh's avatar
Ian Lynagh committed
47
        showSDocUnqual,
48
        renderWithStyle,
49

dterei's avatar
dterei committed
50
        pprInfixVar, pprPrefixVar,
51
        pprHsChar, pprHsString, 
52
        pprFastFilePath,
53

batterseapower's avatar
batterseapower committed
54
        -- * Controlling the style in which output is printed
dterei's avatar
dterei committed
55
        BindingSite(..),
batterseapower's avatar
batterseapower committed
56

dterei's avatar
dterei committed
57
        PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
batterseapower's avatar
batterseapower committed
58
        QualifyName(..),
Ian Lynagh's avatar
Ian Lynagh committed
59
        sdocWithDynFlags, sdocWithPlatform,
dterei's avatar
dterei committed
60
61
62
63
64
        getPprStyle, withPprStyle, withPprStyleDoc,
        pprDeeper, pprDeeperList, pprSetDepth,
        codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
        ifPprDebug, qualName, qualModule,
        mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
65
        mkUserStyle, cmdlineParserStyle, Depth(..),
dterei's avatar
dterei committed
66
67
68
69

        -- * Error handling and debugging utilities
        pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
        pprTrace, pprDefiniteTrace, warnPprTrace,
Ian Lynagh's avatar
Ian Lynagh committed
70
71
        trace, pgmError, panic, sorry, panicFastInt, assertPanic,
        pprDebugAndThen,
72
73
    ) where

74
75
import {-# SOURCE #-}   DynFlags( DynFlags, tracingDynFlags,
                                  targetPlatform, pprUserLength )
dterei's avatar
dterei committed
76
import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
77
import {-# SOURCE #-}   Name( Name, nameModule )
78

Simon Marlow's avatar
Simon Marlow committed
79
import StaticFlags
dterei's avatar
dterei committed
80
import FastString
81
import FastTypes
82
import qualified Pretty
83
import Util
Ian Lynagh's avatar
Ian Lynagh committed
84
import Platform
dterei's avatar
dterei committed
85
import Pretty           ( Doc, Mode(..) )
86
import Panic
87

Ian Lynagh's avatar
Ian Lynagh committed
88
import Data.Char
89
import qualified Data.Map as M
90
import qualified Data.IntMap as IM
91
92
import Data.Set (Set)
import qualified Data.Set as Set
93
import Data.Word
94
import System.IO        ( Handle, hFlush )
95
import System.FilePath
96
97


Ian Lynagh's avatar
Ian Lynagh committed
98
#if __GLASGOW_HASKELL__ >= 701
99
import GHC.Show         ( showMultiLineString )
100
101
102
#else
showMultiLineString :: String -> [String]
-- Crude version
103
showMultiLineString s = [ showList s "" ]
104
#endif
105
106
\end{code}

sof's avatar
sof committed
107

108

109
%************************************************************************
dterei's avatar
dterei committed
110
%*                                                                      *
sof's avatar
sof committed
111
\subsection{The @PprStyle@ data type}
dterei's avatar
dterei committed
112
%*                                                                      *
113
114
115
%************************************************************************

\begin{code}
116

sof's avatar
sof committed
117
data PprStyle
118
  = PprUser PrintUnqualified Depth
dterei's avatar
dterei committed
119
120
121
122
123
                -- 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
124

125
  | PprCode CodeStyle
dterei's avatar
dterei committed
126
                -- Print code; either C or assembler
sof's avatar
sof committed
127

dterei's avatar
dterei committed
128
129
130
  | PprDump     -- For -ddump-foo; less verbose than PprDebug.
                -- Does not assume tidied code: non-external names
                -- are printed with uniques.
131

dterei's avatar
dterei committed
132
  | PprDebug    -- Full debugging output
133

dterei's avatar
dterei committed
134
135
data CodeStyle = CStyle         -- The format of labels differs for C and assembler
               | AsmStyle
136
137

data Depth = AllTheWay
dterei's avatar
dterei committed
138
           | PartWay Int        -- 0 => stop
139
140


Simon Marlow's avatar
Simon Marlow committed
141
142
-- -----------------------------------------------------------------------------
-- Printing original names
143

Simon Marlow's avatar
Simon Marlow committed
144
145
146
147
148
149
150
151
152
153
154
-- 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.
155
type QueryQualifyName = Name -> QualifyName
156

157
-- See Note [Printing original names] in HscTypes
158
159
160
data QualifyName                        -- given P:M.T
        = NameUnqual                    -- refer to it as "T"
        | NameQual ModuleName           -- refer to it as "X.T" for the supplied X
dterei's avatar
dterei committed
161
        | NameNotInScope1
162
163
164
165
166
167
                -- 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
168
169

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

173
type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
Simon Marlow's avatar
Simon Marlow committed
174

175
alwaysQualifyNames :: QueryQualifyName
176
alwaysQualifyNames n = NameQual (moduleName (nameModule n))
Simon Marlow's avatar
Simon Marlow committed
177

178
neverQualifyNames :: QueryQualifyName
179
neverQualifyNames _ = NameUnqual
Simon Marlow's avatar
Simon Marlow committed
180

181
alwaysQualifyModules :: QueryQualifyModule
182
alwaysQualifyModules _ = True
Simon Marlow's avatar
Simon Marlow committed
183

184
neverQualifyModules :: QueryQualifyModule
185
186
neverQualifyModules _ = False

187
alwaysQualify, neverQualify :: PrintUnqualified
Simon Marlow's avatar
Simon Marlow committed
188
189
alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
neverQualify  = (neverQualifyNames,  neverQualifyModules)
190

191
192
defaultUserStyle, defaultDumpStyle :: PprStyle

193
194
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay

195
defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
dterei's avatar
dterei committed
196
                 |  otherwise          = PprDump
197

Simon Marlow's avatar
Simon Marlow committed
198
-- | Style for printing error messages
199
200
mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags))
201

202
defaultErrStyle :: DynFlags -> PprStyle
203
204
205
-- 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
206
207
208
209
defaultErrStyle dflags = mkUserStyle alwaysQualify depth
    where depth = if opt_PprStyle_Debug
                  then AllTheWay
                  else PartWay (pprUserLength dflags)
210

211
mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
Simon Marlow's avatar
Simon Marlow committed
212
213
214
mkUserStyle unqual depth
   | opt_PprStyle_Debug = PprDebug
   | otherwise          = PprUser unqual depth
215
216
217

cmdlineParserStyle :: PprStyle
cmdlineParserStyle = PprUser alwaysQualify AllTheWay
sof's avatar
sof committed
218
\end{code}
219

sof's avatar
sof committed
220
221
222
223
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
224

sof's avatar
sof committed
225
226
The following test decides whether or not we are actually generating
code (either C or assembly), or generating interface files.
227
228

%************************************************************************
dterei's avatar
dterei committed
229
%*                                                                      *
230
\subsection{The @SDoc@ data type}
dterei's avatar
dterei committed
231
%*                                                                      *
232
233
234
%************************************************************************

\begin{code}
Thomas Schilling's avatar
Thomas Schilling committed
235
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
236
237
238
239
240

data SDocContext = SDC
  { sdocStyle      :: !PprStyle
  , sdocLastColour :: !PprColour
    -- ^ The most recently used colour.  This allows nesting colours.
Ian Lynagh's avatar
Ian Lynagh committed
241
  , sdocDynFlags   :: DynFlags
242
243
  }

Ian Lynagh's avatar
Ian Lynagh committed
244
245
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags sty = SDC
246
247
  { sdocStyle = sty
  , sdocLastColour = colReset
Ian Lynagh's avatar
Ian Lynagh committed
248
  , sdocDynFlags = dflags
249
  }
250
251

withPprStyle :: PprStyle -> SDoc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
252
withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
253

Ian Lynagh's avatar
Ian Lynagh committed
254
255
withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
256

257
pprDeeper :: SDoc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
258
259
260
261
262
pprDeeper d = SDoc $ \ctx -> case ctx of
  SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
  SDC{sdocStyle=PprUser q (PartWay n)} ->
    runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
  _ -> runSDoc d ctx
263

264
265
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
-- Truncate a list that list that is longer than the current depth
Thomas Schilling's avatar
Thomas Schilling committed
266
267
268
269
270
271
272
273
274
275
276
pprDeeperList f ds = SDoc work
 where
  work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
   | n==0      = Pretty.text "..."
   | otherwise =
      runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
   where
     go _ [] = []
     go i (d:ds) | i >= n    = [text "...."]
                 | otherwise = d : go (i+1) ds
  work other_ctx = runSDoc (f ds) other_ctx
277

278
pprSetDepth :: Depth -> SDoc -> SDoc
dterei's avatar
dterei committed
279
280
281
282
283
284
pprSetDepth depth doc = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprUser q _} ->
            runSDoc doc ctx{sdocStyle = PprUser q depth}
        _ ->
            runSDoc doc ctx
285

286
getPprStyle :: (PprStyle -> SDoc) -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
287
getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
Ian Lynagh's avatar
Ian Lynagh committed
288
289
290
291
292
293

sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx

sdocWithPlatform :: (Platform -> SDoc) -> SDoc
sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
294
295
\end{code}

sof's avatar
sof committed
296
\begin{code}
297
qualName :: PprStyle -> QueryQualifyName
298
299
qualName (PprUser (qual_name,_) _)  n = qual_name n
qualName _other                     n = NameQual (moduleName (nameModule n))
Simon Marlow's avatar
Simon Marlow committed
300

301
qualModule :: PprStyle -> QueryQualifyModule
302
303
qualModule (PprUser (_,qual_mod) _)  m = qual_mod m
qualModule _other                   _m = True
304

sof's avatar
sof committed
305
codeStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
306
307
codeStyle (PprCode _)     = True
codeStyle _               = False
sof's avatar
sof committed
308

309
310
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle)  = True
311
asmStyle _other              = False
312

313
314
dumpStyle :: PprStyle -> Bool
dumpStyle PprDump = True
315
dumpStyle _other  = False
316

317
debugStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
318
319
debugStyle PprDebug = True
debugStyle _other   = False
320

sof's avatar
sof committed
321
userStyle ::  PprStyle -> Bool
322
userStyle (PprUser _ _) = True
323
userStyle _other        = False
sof's avatar
sof committed
324

dterei's avatar
dterei committed
325
326
327
328
329
ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
ifPprDebug d = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprDebug} -> runSDoc d ctx
        _                       -> Pretty.empty
sof's avatar
sof committed
330
\end{code}
331

sof's avatar
sof committed
332
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
333
hPrintDump :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
334
hPrintDump dflags h doc = do
Thomas Schilling's avatar
Thomas Schilling committed
335
   Pretty.printDoc PageMode h
Ian Lynagh's avatar
Ian Lynagh committed
336
     (runSDoc better_doc (initSDocContext dflags defaultDumpStyle))
337
   hFlush h
sof's avatar
sof committed
338
 where
339
   better_doc = doc $$ blankLine
340

341
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
342
printForUser dflags handle unqual doc
Thomas Schilling's avatar
Thomas Schilling committed
343
  = Pretty.printDoc PageMode handle
Ian Lynagh's avatar
Ian Lynagh committed
344
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
345

346
347
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
                    -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
348
printForUserPartWay dflags handle d unqual doc
Thomas Schilling's avatar
Thomas Schilling committed
349
  = Pretty.printDoc PageMode handle
Ian Lynagh's avatar
Ian Lynagh committed
350
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d))))
351

352
-- printForC, printForAsm do what they sound like
353
printForC :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
354
printForC dflags handle doc =
Thomas Schilling's avatar
Thomas Schilling committed
355
  Pretty.printDoc LeftMode handle
Ian Lynagh's avatar
Ian Lynagh committed
356
    (runSDoc doc (initSDocContext dflags (PprCode CStyle)))
357

358
printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
359
printForAsm dflags handle doc =
Thomas Schilling's avatar
Thomas Schilling committed
360
  Pretty.printDoc LeftMode handle
Ian Lynagh's avatar
Ian Lynagh committed
361
    (runSDoc doc (initSDocContext dflags (PprCode AsmStyle)))
362

sof's avatar
sof committed
363
364
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
365

366
367
368
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

369
370
-- Can't make SDoc an instance of Show because SDoc is just a function type
-- However, Doc *is* an instance of Show
371
-- showSDoc just blasts it out as a string
Ian Lynagh's avatar
Ian Lynagh committed
372
showSDoc :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
373
showSDoc dflags d =
Thomas Schilling's avatar
Thomas Schilling committed
374
  Pretty.showDocWith PageMode
Ian Lynagh's avatar
Ian Lynagh committed
375
    (runSDoc d (initSDocContext dflags defaultUserStyle))
376

Ian Lynagh's avatar
Ian Lynagh committed
377
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
Ian Lynagh's avatar
Ian Lynagh committed
378
379
renderWithStyle dflags sdoc sty =
  Pretty.render (runSDoc sdoc (initSDocContext dflags sty))
380

381
382
383
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway.
384
showSDocOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
385
showSDocOneLine dflags d
386
 = Pretty.showDocWith PageMode
Ian Lynagh's avatar
Ian Lynagh committed
387
    (runSDoc d (initSDocContext dflags defaultUserStyle))
388

389
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
390
391
showSDocForUser dflags unqual doc
 = show (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
392

393
showSDocUnqual :: DynFlags -> SDoc -> String
394
-- Only used in the gruesome isOperator
Ian Lynagh's avatar
Ian Lynagh committed
395
396
showSDocUnqual dflags d
 = show (runSDoc d (initSDocContext dflags (mkUserStyle neverQualify AllTheWay)))
397

398
showSDocDump :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
399
400
showSDocDump dflags d
 = Pretty.showDocWith PageMode (runSDoc d (initSDocContext dflags defaultDumpStyle))
401

402
showSDocDumpOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
403
404
showSDocDumpOneLine dflags d
 = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext dflags PprDump))
405

406
showSDocDebug :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
407
showSDocDebug dflags d = show (runSDoc d (initSDocContext dflags PprDebug))
408

Ian Lynagh's avatar
Ian Lynagh committed
409
showPpr :: Outputable a => DynFlags -> a -> String
Ian Lynagh's avatar
Ian Lynagh committed
410
showPpr dflags = showSDoc dflags . ppr
411
412
\end{code}

413
\begin{code}
414
docToSDoc :: Doc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
415
docToSDoc d = SDoc (\_ -> d)
416

417
418
empty    :: SDoc
char     :: Char       -> SDoc
batterseapower's avatar
batterseapower committed
419
text     :: String     -> SDoc
420
ftext    :: FastString -> SDoc
421
ptext    :: LitString  -> SDoc
422
423
424
425
426
427
int      :: Int        -> SDoc
integer  :: Integer    -> SDoc
float    :: Float      -> SDoc
double   :: Double     -> SDoc
rational :: Rational   -> SDoc

Thomas Schilling's avatar
Thomas Schilling committed
428
429
430
431
432
433
434
435
436
437
empty       = docToSDoc $ Pretty.empty
char c      = docToSDoc $ Pretty.char c
text s      = docToSDoc $ Pretty.text s
ftext s     = docToSDoc $ Pretty.ftext s
ptext s     = docToSDoc $ Pretty.ptext s
int n       = docToSDoc $ Pretty.int n
integer n   = docToSDoc $ Pretty.integer n
float n     = docToSDoc $ Pretty.float n
double n    = docToSDoc $ Pretty.double n
rational n  = docToSDoc $ Pretty.rational n
438

439
440
parens, braces, brackets, quotes, quote, 
        paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
441

442
443
444
445
446
parens d        = SDoc $ Pretty.parens . runSDoc d
braces d        = SDoc $ Pretty.braces . runSDoc d
brackets d      = SDoc $ Pretty.brackets . runSDoc d
quote d         = SDoc $ Pretty.quote . runSDoc d
doubleQuotes d  = SDoc $ Pretty.doubleQuotes . runSDoc d
Thomas Schilling's avatar
Thomas Schilling committed
447
angleBrackets d = char '<' <> d <> char '>'
448
paBrackets d    = ptext (sLit "[:") <> d <> ptext (sLit ":]")
449

450
451
cparen :: Bool -> SDoc -> SDoc

Thomas Schilling's avatar
Thomas Schilling committed
452
cparen b d     = SDoc $ Pretty.cparen b . runSDoc d
mnislaih's avatar
mnislaih committed
453

454
-- 'quotes' encloses something in single quotes...
455
-- but it omits them if the thing begins or ends in a single quote
456
-- so that we don't get `foo''.  Instead we just have foo'.
dterei's avatar
dterei committed
457
quotes d = SDoc $ \sty ->
458
459
460
461
462
463
           let pp_d = runSDoc d sty
               str  = show pp_d
           in case (str, snocView str) of
             (_, Just (_, '\'')) -> pp_d
             ('\'' : _, _)       -> pp_d
             _other              -> Pretty.quotes pp_d
464

465
semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
466
darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
467

Thomas Schilling's avatar
Thomas Schilling committed
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
blankLine  = docToSDoc $ Pretty.ptext (sLit "")
dcolon     = docToSDoc $ Pretty.ptext (sLit "::")
arrow      = docToSDoc $ Pretty.ptext (sLit "->")
darrow     = docToSDoc $ Pretty.ptext (sLit "=>")
semi       = docToSDoc $ Pretty.semi
comma      = docToSDoc $ Pretty.comma
colon      = docToSDoc $ Pretty.colon
equals     = docToSDoc $ Pretty.equals
space      = docToSDoc $ Pretty.space
underscore = char '_'
dot        = char '.'
lparen     = docToSDoc $ Pretty.lparen
rparen     = docToSDoc $ Pretty.rparen
lbrack     = docToSDoc $ Pretty.lbrack
rbrack     = docToSDoc $ Pretty.rbrack
lbrace     = docToSDoc $ Pretty.lbrace
rbrace     = docToSDoc $ Pretty.rbrace
485
486

nest :: Int -> SDoc -> SDoc
batterseapower's avatar
batterseapower committed
487
488
489
490
491
492
-- ^ 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
dterei's avatar
dterei committed
493
-- ^ Join two 'SDoc' together vertically; if there is
batterseapower's avatar
batterseapower committed
494
495
496
-- no vertical overlap it "dovetails" the two onto one line
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
497

Thomas Schilling's avatar
Thomas Schilling committed
498
499
500
501
502
nest n d    = SDoc $ Pretty.nest n . runSDoc d
(<>) d1 d2  = SDoc $ \sty -> (Pretty.<>)  (runSDoc d1 sty) (runSDoc d2 sty)
(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
($$) d1 d2  = SDoc $ \sty -> (Pretty.$$)  (runSDoc d1 sty) (runSDoc d2 sty)
($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
503

batterseapower's avatar
batterseapower committed
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
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 '<+>'
519
520


Thomas Schilling's avatar
Thomas Schilling committed
521
522
523
524
525
526
527
hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
sep ds  = SDoc $ \sty -> Pretty.sep  [runSDoc d sty | d <- ds]
cat ds  = SDoc $ \sty -> Pretty.cat  [runSDoc d sty | d <- ds]
fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
528

batterseapower's avatar
batterseapower committed
529
530
531
532
hang :: SDoc  -- ^ The header
      -> Int  -- ^ Amount to indent the hung body
      -> SDoc -- ^ The hung body, indented and placed below the header
      -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
533
hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
534

batterseapower's avatar
batterseapower committed
535
536
537
punctuate :: SDoc   -- ^ The punctuation
          -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
          -> [SDoc] -- ^ Punctuated list
538
punctuate _ []     = []
539
punctuate p (d:ds) = go d ds
dterei's avatar
dterei committed
540
541
542
                   where
                     go d [] = [d]
                     go d (e:es) = (d <> p) : go e es
543
544
545
546
547
548
549

ppWhen, ppUnless :: Bool -> SDoc -> SDoc
ppWhen True  doc = doc
ppWhen False _   = empty

ppUnless True  _   = empty
ppUnless False doc = doc
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565

-- | A colour\/style for use with 'coloured'.
newtype PprColour = PprColour String

-- Colours

colType :: PprColour
colType = PprColour "\27[34m"

colBold :: PprColour
colBold = PprColour "\27[;1m"

colCoerc :: PprColour
colCoerc = PprColour "\27[34m"

colDataCon :: PprColour
Thomas Schilling's avatar
Thomas Schilling committed
566
colDataCon = PprColour "\27[31m"
567

Thomas Schilling's avatar
Thomas Schilling committed
568
569
colBinder :: PprColour
colBinder = PprColour "\27[32m"
570
571
572
573
574
575
576
577
578

colReset :: PprColour
colReset = PprColour "\27[0m"

-- | Apply the given colour\/style for the argument.
--
-- Only takes effect if colours are enabled.
coloured :: PprColour -> SDoc -> SDoc
-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
Thomas Schilling's avatar
Thomas Schilling committed
579
580
581
582
coloured col@(PprColour c) sdoc =
  SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
    let ctx' = ctx{ sdocLastColour = col } in
    Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
583
584
585
586
587
588
589

bold :: SDoc -> SDoc
bold = coloured colBold

keyword :: SDoc -> SDoc
keyword = bold

590
\end{code}
sof's avatar
sof committed
591

sof's avatar
sof committed
592
593

%************************************************************************
dterei's avatar
dterei committed
594
%*                                                                      *
sof's avatar
sof committed
595
\subsection[Outputable-class]{The @Outputable@ class}
dterei's avatar
dterei committed
596
%*                                                                      *
sof's avatar
sof committed
597
598
599
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
600
-- | Class designating that some type has an 'SDoc' representation
sof's avatar
sof committed
601
class Outputable a where
dterei's avatar
dterei committed
602
603
604
605
606
        ppr :: a -> SDoc
        pprPrec :: Rational -> a -> SDoc
                -- 0 binds least tightly
                -- We use Rational because there is always a
                -- Rational between any other two Rationals
Simon Peyton Jones's avatar
Simon Peyton Jones committed
607

dterei's avatar
dterei committed
608
609
        ppr = pprPrec 0
        pprPrec _ = ppr
sof's avatar
sof committed
610
611
\end{code}

612
613
\begin{code}
instance Outputable Bool where
Ian Lynagh's avatar
Ian Lynagh committed
614
615
    ppr True  = ptext (sLit "True")
    ppr False = ptext (sLit "False")
616

sof's avatar
sof committed
617
instance Outputable Int where
618
   ppr n = int n
sof's avatar
sof committed
619

620
621
622
instance Outputable Word16 where
   ppr n = integer $ fromIntegral n

623
624
625
instance Outputable Word32 where
   ppr n = integer $ fromIntegral n

626
627
628
instance Outputable Word where
   ppr n = integer $ fromIntegral n

629
630
631
instance Outputable () where
   ppr _ = text "()"

632
instance (Outputable a) => Outputable [a] where
633
    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
634

635
636
637
instance (Outputable a) => Outputable (Set a) where
    ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))

638
instance (Outputable a, Outputable b) => Outputable (a, b) where
639
    ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
640

641
instance Outputable a => Outputable (Maybe a) where
Ian Lynagh's avatar
Ian Lynagh committed
642
643
  ppr Nothing = ptext (sLit "Nothing")
  ppr (Just x) = ptext (sLit "Just") <+> ppr x
644

645
instance (Outputable a, Outputable b) => Outputable (Either a b) where
Ian Lynagh's avatar
Ian Lynagh committed
646
647
  ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
  ppr (Right y) = ptext (sLit "Right") <+> ppr y
648

649
650
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
651
    ppr (x,y,z) =
652
      parens (sep [ppr x <> comma,
dterei's avatar
dterei committed
653
654
                   ppr y <> comma,
                   ppr z ])
655

656
instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
dterei's avatar
dterei committed
657
         Outputable (a, b, c, d) where
658
659
    ppr (a,b,c,d) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
660
661
662
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d])
663
664

instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
dterei's avatar
dterei committed
665
         Outputable (a, b, c, d, e) where
666
667
    ppr (a,b,c,d,e) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
668
669
670
671
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d <> comma,
                   ppr e])
672

673
instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) =>
dterei's avatar
dterei committed
674
         Outputable (a, b, c, d, e, f) where
675
676
    ppr (a,b,c,d,e,f) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
677
678
679
680
681
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d <> comma,
                   ppr e <> comma,
                   ppr f])
682
683

instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>
dterei's avatar
dterei committed
684
         Outputable (a, b, c, d, e, f, g) where
685
686
    ppr (a,b,c,d,e,f,g) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
687
688
689
690
691
692
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d <> comma,
                   ppr e <> comma,
                   ppr f <> comma,
                   ppr g])
693

694
instance Outputable FastString where
dterei's avatar
dterei committed
695
696
    ppr fs = ftext fs           -- Prints an unadorned string,
                                -- no double quotes or anything
697

698
instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
699
    ppr m = ppr (M.toList m)
700
701
instance (Outputable elt) => Outputable (IM.IntMap elt) where
    ppr m = ppr (IM.toList m)
702
703
704
\end{code}

%************************************************************************
dterei's avatar
dterei committed
705
%*                                                                      *
706
\subsection{The @OutputableBndr@ class}
dterei's avatar
dterei committed
707
%*                                                                      *
708
709
710
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
711
712
713
-- | '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.
714
715
data BindingSite = LambdaBind | CaseBind | LetBind

batterseapower's avatar
batterseapower committed
716
717
-- | When we print a binder, we often want to print its type too.
-- The @OutputableBndr@ class encapsulates this idea.
718
719
class Outputable a => OutputableBndr a where
   pprBndr :: BindingSite -> a -> SDoc
720
   pprBndr _b x = ppr x
721
722
723
724
725

   pprPrefixOcc, pprInfixOcc :: a -> SDoc
      -- Print an occurrence of the name, suitable either in the 
      -- prefix position of an application, thus   (f a b) or  ((+) x)
      -- or infix position,                 thus   (a `f` b) or  (x + y)
726
727
728
\end{code}

%************************************************************************
dterei's avatar
dterei committed
729
%*                                                                      *
730
\subsection{Random printing helpers}
dterei's avatar
dterei committed
731
%*                                                                      *
732
733
734
%************************************************************************

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

-- | Special combinator for showing character literals.
738
739
740
pprHsChar :: Char -> SDoc
pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
            | otherwise      = text (show c)
741

batterseapower's avatar
batterseapower committed
742
-- | Special combinator for showing string literals.
743
pprHsString :: FastString -> SDoc
744
pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
745
746
747
748
749
750

---------------------
-- Put a name in parens if it's an operator
pprPrefixVar :: Bool -> SDoc -> SDoc
pprPrefixVar is_operator pp_v
  | is_operator = parens pp_v
dterei's avatar
dterei committed
751
  | otherwise   = pp_v
752
753
754

-- Put a name in backquotes if it's not an operator
pprInfixVar :: Bool -> SDoc -> SDoc
dterei's avatar
dterei committed
755
pprInfixVar is_operator pp_v
756
757
758
759
  | is_operator = pp_v
  | otherwise   = char '`' <> pp_v <> char '`'

---------------------
760
761
pprFastFilePath :: FastString -> SDoc
pprFastFilePath path = text $ normalise $ unpackFS path
sof's avatar
sof committed
762
763
\end{code}

sof's avatar
sof committed
764
%************************************************************************
dterei's avatar
dterei committed
765
%*                                                                      *
sof's avatar
sof committed
766
\subsection{Other helper functions}
dterei's avatar
dterei committed
767
%*                                                                      *
sof's avatar
sof committed
768
769
770
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
771
772
773
774
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.
775
pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
776

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

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

batterseapower's avatar
batterseapower committed
785
786
787
-- | Returns the comma-seperated concatenation of the quoted pretty printed things.
--
-- > [x,y,z]  ==>  `x', `y', `z'
788
pprQuotedList :: Outputable a => [a] -> SDoc
789
790
791
792
793
794
795
796
797
pprQuotedList = quotedList . map ppr

quotedList :: [SDoc] -> SDoc
quotedList xs = hsep (punctuate comma (map quotes xs))

quotedListWithOr :: [SDoc] -> SDoc
-- [x,y,z]  ==>  `x', `y' or `z'
quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
quotedListWithOr xs = quotedList xs
sof's avatar
sof committed
798
799
800
801
\end{code}


%************************************************************************
dterei's avatar
dterei committed
802
%*                                                                      *
sof's avatar
sof committed
803
\subsection{Printing numbers verbally}
dterei's avatar
dterei committed
804
%*                                                                      *
sof's avatar
sof committed
805
%************************************************************************
sof's avatar
sof committed
806
807

\begin{code}
808
809
810
811
812
813
814
815
816
intWithCommas :: Integral a => a -> SDoc
-- Prints a big integer with commas, eg 345,821
intWithCommas n
  | n < 0     = char '-' <> intWithCommas (-n)
  | q == 0    = int (fromIntegral r)
  | otherwise = intWithCommas q <> comma <> int (fromIntegral r)
  where
    (q,r) = n `quotRem` 1000

batterseapower's avatar
batterseapower committed
817
818
819
820
821
-- | Converts an integer to a verbal index:
--
-- > speakNth 1 = text "first"
-- > speakNth 5 = text "fifth"
-- > speakNth 21 = text "21st"
822
speakNth :: Int -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
823
824
825
826
827
828
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")
829
speakNth n = hcat [ int n, text suffix ]
sof's avatar
sof committed
830
  where
dterei's avatar
dterei committed
831
832
833
834
835
    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
836

837
    last_dig = n `rem` 10
838

batterseapower's avatar
batterseapower committed
839
-- | Converts an integer to a verbal multiplicity:
dterei's avatar
dterei committed
840
--
batterseapower's avatar
batterseapower committed
841
842
843
-- > speakN 0 = text "none"
-- > speakN 5 = text "five"
-- > speakN 10 = text "10"
844
speakN :: Int -> SDoc
dterei's avatar
dterei committed
845
846
speakN 0 = ptext (sLit "none")  -- E.g.  "he has none"
speakN 1 = ptext (sLit "one")   -- E.g.  "he has one"
Ian Lynagh's avatar
Ian Lynagh committed
847
848
849
850
851
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")
852
853
speakN n = int n

batterseapower's avatar
batterseapower committed
854
855
856
857
858
859
-- | 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"
860
speakNOf :: Int -> SDoc -> SDoc
batterseapower's avatar
batterseapower committed
861
speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
dterei's avatar
dterei committed
862
863
speakNOf 1 d = ptext (sLit "one") <+> d                 -- E.g. "one argument"
speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
864

batterseapower's avatar
batterseapower committed
865
866
867
868
869
-- | Converts a strictly positive integer into a number of times:
--
-- > speakNTimes 1 = text "once"
-- > speakNTimes 2 = text "twice"
-- > speakNTimes 4 = text "4 times"
870
speakNTimes :: Int {- >=1 -} -> SDoc
dterei's avatar
dterei committed
871
872
speakNTimes t | t == 1     = ptext (sLit "once")
              | t == 2     = ptext (sLit "twice")
Ian Lynagh's avatar
Ian Lynagh committed
873
              | otherwise  = speakN t <+> ptext (sLit "times")
874

batterseapower's avatar
batterseapower committed
875
876
877
878
879
-- | Determines the pluralisation suffix appropriate for the length of a list:
--
-- > plural [] = char 's'
-- > plural ["Hello"] = empty
-- > plural ["Hello", "World"] = char 's'
880
881
882
plural :: [a] -> SDoc
plural [_] = empty  -- a bit frightening, but there you are
plural _   = char 's'
883
884
\end{code}

885

886
%************************************************************************
dterei's avatar
dterei committed
887
%*                                                                      *
888
\subsection{Error handling}
dterei's avatar
dterei committed
889
%*                                                                      *
890
891
892
%************************************************************************

\begin{code}
893

batterseapower's avatar
batterseapower committed
894
895
pprPanic :: String -> SDoc -> a
-- ^ Throw an exception saying "bug in GHC"
Ian Lynagh's avatar
Ian Lynagh committed
896
pprPanic    = panicDoc
batterseapower's avatar
batterseapower committed
897

898
pprSorry :: String -> SDoc -> a
Ian Lynagh's avatar
Ian Lynagh committed
899
-- ^ Throw an exception saying "this isn't finished yet"
900
pprSorry    = sorryDoc
901
902
903
904


pprPgmError :: String -> SDoc -> a
-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
905
pprPgmError = pgmErrorDoc
906

907
908
909

pprTrace :: String -> SDoc -> a -> a
-- ^ If debug output is on, show some 'SDoc' on the screen
Simon Marlow's avatar
Simon Marlow committed
910
911
pprTrace str doc x
   | opt_NoDebugOutput = x
912
   | otherwise         = pprDebugAndThen tracingDynFlags trace str doc x
913

914
pprDefiniteTrace :: DynFlags -> String -> SDoc -> a -> a
915
-- ^ Same as pprTrace, but show even if -dno-debug-output is on
916
pprDefiniteTrace dflags str doc x = pprDebugAndThen dflags trace str doc x
917

918
pprPanicFastInt :: String -> SDoc -> FastInt
batterseapower's avatar
batterseapower committed
919
-- ^ Specialization of pprPanic that can be safely used with 'FastInt'
920
pprPanicFastInt heading pretty_msg = panicDocFastInt heading pretty_msg
921

922
warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
batterseapower's avatar
batterseapower committed
923
924
-- ^ Just warn about an assertion failure, recording the given file and line number.
-- Should typically be accessed with the WARN macros
925
warnPprTrace _     _     _     _    x | not debugIsOn     = x
Simon Marlow's avatar
Simon Marlow committed
926
warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
927
928
warnPprTrace False _file _line _msg x = x
warnPprTrace True   file  line  msg x
929
  = pprDebugAndThen tracingDynFlags trace str msg x
930
  where
Ian Lynagh's avatar
Ian Lynagh committed
931
    str = showSDoc tracingDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line])
932
933
934
935
936

assertPprPanic :: String -> Int -> SDoc -> a
-- ^ Panic with an assertation failure, recording the given file and line number.
-- Should typically be accessed with the ASSERT family of macros
assertPprPanic file line msg
937
  = pprDebugAndThen tracingDynFlags panic "ASSERT failed!" doc
938
939
940
941
942