371856f5eacc84f94c8ffd9001b92a618577ba24
[ghc.git] / compiler / utils / Outputable.hs
1 {-# LANGUAGE CPP, ImplicitParams #-}
2 {-
3 (c) The University of Glasgow 2006-2012
4 (c) The GRASP Project, Glasgow University, 1992-1998
5 -}
6
7 -- | This module defines classes and functions for pretty-printing. It also
8 -- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
9 --
10 -- The interface to this module is very similar to the standard Hughes-PJ pretty printing
11 -- module, except that it exports a number of additional functions that are rarely used,
12 -- and works over the 'SDoc' type.
13 module Outputable (
14 -- * Type classes
15 Outputable(..), OutputableBndr(..),
16
17 -- * Pretty printing combinators
18 SDoc, runSDoc, initSDocContext,
19 docToSDoc,
20 interppSP, interpp'SP,
21 pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
22 pprWithBars,
23 empty, isEmpty, nest,
24 char,
25 text, ftext, ptext, ztext,
26 int, intWithCommas, integer, float, double, rational, doublePrec,
27 parens, cparen, brackets, braces, quotes, quote,
28 doubleQuotes, angleBrackets, paBrackets,
29 semi, comma, colon, dcolon, space, equals, dot, vbar,
30 arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
31 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
32 blankLine, forAllLit, kindStar,
33 (<>), (<+>), hcat, hsep,
34 ($$), ($+$), vcat,
35 sep, cat,
36 fsep, fcat,
37 hang, hangNotEmpty, punctuate, ppWhen, ppUnless,
38 speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes,
39 unicodeSyntax,
40
41 coloured, bold, keyword, PprColour, colReset, colBold, colBlackFg,
42 colRedFg, colGreenFg, colYellowFg, colBlueFg, colMagentaFg, colCyanFg,
43 colWhiteFg, colBinder, colCoerc, colDataCon, colType,
44
45 -- * Converting 'SDoc' into strings and outputing it
46 printForC, printForAsm, printForUser, printForUserPartWay,
47 pprCode, mkCodeStyle,
48 showSDoc, showSDocUnsafe, showSDocOneLine,
49 showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
50 showSDocUnqual, showPpr,
51 renderWithStyle,
52
53 pprInfixVar, pprPrefixVar,
54 pprHsChar, pprHsString, pprHsBytes,
55
56 primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix,
57 primInt64Suffix, primWord64Suffix, primIntSuffix,
58
59 pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64,
60
61 pprFastFilePath,
62
63 -- * Controlling the style in which output is printed
64 BindingSite(..),
65
66 PprStyle, CodeStyle(..), PrintUnqualified(..),
67 QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,
68 reallyAlwaysQualify, reallyAlwaysQualifyNames,
69 alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
70 neverQualify, neverQualifyNames, neverQualifyModules,
71 alwaysQualifyPackages, neverQualifyPackages,
72 QualifyName(..), queryQual,
73 sdocWithDynFlags, sdocWithPlatform,
74 getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured,
75 pprDeeper, pprDeeperList, pprSetDepth,
76 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
77 ifPprDebug, qualName, qualModule, qualPackage,
78 mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,
79 mkUserStyle, cmdlineParserStyle, Depth(..),
80
81 -- * Error handling and debugging utilities
82 pprPanic, pprSorry, assertPprPanic, pprPgmError,
83 pprTrace, pprTraceIt, warnPprTrace, pprSTrace,
84 trace, pgmError, panic, sorry, assertPanic,
85 pprDebugAndThen,
86 ) where
87
88 import {-# SOURCE #-} DynFlags( DynFlags,
89 targetPlatform, pprUserLength, pprCols,
90 useUnicode, useUnicodeSyntax,
91 useColor, canUseColor, overrideWith,
92 unsafeGlobalDynFlags )
93 import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName )
94 import {-# SOURCE #-} OccName( OccName )
95 import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput )
96
97 import FastString
98 import qualified Pretty
99 import Util
100 import Platform
101 import Pretty ( Doc, Mode(..) )
102 import Panic
103 import GHC.Serialized
104 import GHC.LanguageExtensions (Extension)
105
106 import Data.ByteString (ByteString)
107 import qualified Data.ByteString as BS
108 import Data.Char
109 import qualified Data.Map as M
110 import Data.Int
111 import qualified Data.IntMap as IM
112 import Data.Set (Set)
113 import qualified Data.Set as Set
114 import Data.Monoid (Monoid, mappend, mempty)
115 import Data.String
116 import Data.Word
117 import System.IO ( Handle )
118 import System.FilePath
119 import Text.Printf
120 import Numeric (showFFloat)
121 import Data.Graph (SCC(..))
122 import Data.List (intersperse)
123
124 import GHC.Fingerprint
125 import GHC.Show ( showMultiLineString )
126
127 {-
128 ************************************************************************
129 * *
130 \subsection{The @PprStyle@ data type}
131 * *
132 ************************************************************************
133 -}
134
135 data PprStyle
136 = PprUser PrintUnqualified Depth Coloured
137 -- Pretty-print in a way that will make sense to the
138 -- ordinary user; must be very close to Haskell
139 -- syntax, etc.
140 -- Assumes printing tidied code: non-system names are
141 -- printed without uniques.
142
143 | PprDump PrintUnqualified
144 -- For -ddump-foo; less verbose than PprDebug, but more than PprUser
145 -- Does not assume tidied code: non-external names
146 -- are printed with uniques.
147
148 | PprDebug -- Full debugging output
149
150 | PprCode CodeStyle
151 -- Print code; either C or assembler
152
153 data CodeStyle = CStyle -- The format of labels differs for C and assembler
154 | AsmStyle
155
156 data Depth = AllTheWay
157 | PartWay Int -- 0 => stop
158
159 data Coloured
160 = Uncoloured
161 | Coloured
162
163 -- -----------------------------------------------------------------------------
164 -- Printing original names
165
166 -- | When printing code that contains original names, we need to map the
167 -- original names back to something the user understands. This is the
168 -- purpose of the triple of functions that gets passed around
169 -- when rendering 'SDoc'.
170 data PrintUnqualified = QueryQualify {
171 queryQualifyName :: QueryQualifyName,
172 queryQualifyModule :: QueryQualifyModule,
173 queryQualifyPackage :: QueryQualifyPackage
174 }
175
176 -- | given an /original/ name, this function tells you which module
177 -- name it should be qualified with when printing for the user, if
178 -- any. For example, given @Control.Exception.catch@, which is in scope
179 -- as @Exception.catch@, this function will return @Just "Exception"@.
180 -- Note that the return value is a ModuleName, not a Module, because
181 -- in source code, names are qualified by ModuleNames.
182 type QueryQualifyName = Module -> OccName -> QualifyName
183
184 -- | For a given module, we need to know whether to print it with
185 -- a package name to disambiguate it.
186 type QueryQualifyModule = Module -> Bool
187
188 -- | For a given package, we need to know whether to print it with
189 -- the component id to disambiguate it.
190 type QueryQualifyPackage = UnitId -> Bool
191
192 -- See Note [Printing original names] in HscTypes
193 data QualifyName -- Given P:M.T
194 = NameUnqual -- It's in scope unqualified as "T"
195 -- OR nothing called "T" is in scope
196
197 | NameQual ModuleName -- It's in scope qualified as "X.T"
198
199 | NameNotInScope1 -- It's not in scope at all, but M.T is not bound
200 -- in the current scope, so we can refer to it as "M.T"
201
202 | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in
203 -- the current scope, so we must refer to it as "P:M.T"
204
205 reallyAlwaysQualifyNames :: QueryQualifyName
206 reallyAlwaysQualifyNames _ _ = NameNotInScope2
207
208 -- | NB: This won't ever show package IDs
209 alwaysQualifyNames :: QueryQualifyName
210 alwaysQualifyNames m _ = NameQual (moduleName m)
211
212 neverQualifyNames :: QueryQualifyName
213 neverQualifyNames _ _ = NameUnqual
214
215 alwaysQualifyModules :: QueryQualifyModule
216 alwaysQualifyModules _ = True
217
218 neverQualifyModules :: QueryQualifyModule
219 neverQualifyModules _ = False
220
221 alwaysQualifyPackages :: QueryQualifyPackage
222 alwaysQualifyPackages _ = True
223
224 neverQualifyPackages :: QueryQualifyPackage
225 neverQualifyPackages _ = False
226
227 reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified
228 reallyAlwaysQualify
229 = QueryQualify reallyAlwaysQualifyNames
230 alwaysQualifyModules
231 alwaysQualifyPackages
232 alwaysQualify = QueryQualify alwaysQualifyNames
233 alwaysQualifyModules
234 alwaysQualifyPackages
235 neverQualify = QueryQualify neverQualifyNames
236 neverQualifyModules
237 neverQualifyPackages
238
239 defaultUserStyle, defaultDumpStyle :: PprStyle
240
241 defaultUserStyle = mkUserStyle neverQualify AllTheWay
242 -- Print without qualifiers to reduce verbosity, unless -dppr-debug
243
244 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
245 | otherwise = PprDump neverQualify
246
247 mkDumpStyle :: PrintUnqualified -> PprStyle
248 mkDumpStyle print_unqual | opt_PprStyle_Debug = PprDebug
249 | otherwise = PprDump print_unqual
250
251 defaultErrStyle :: DynFlags -> PprStyle
252 -- Default style for error messages, when we don't know PrintUnqualified
253 -- It's a bit of a hack because it doesn't take into account what's in scope
254 -- Only used for desugarer warnings, and typechecker errors in interface sigs
255 -- NB that -dppr-debug will still get into PprDebug style
256 defaultErrStyle dflags = mkErrStyle dflags neverQualify
257
258 -- | Style for printing error messages
259 mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
260 mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags))
261
262 cmdlineParserStyle :: PprStyle
263 cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay
264
265 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
266 mkUserStyle unqual depth
267 | opt_PprStyle_Debug = PprDebug
268 | otherwise = PprUser unqual depth Uncoloured
269
270 setStyleColoured :: Bool -> PprStyle -> PprStyle
271 setStyleColoured col style =
272 case style of
273 PprUser q d _ -> PprUser q d c
274 _ -> style
275 where
276 c | col = Coloured
277 | otherwise = Uncoloured
278
279 instance Outputable PprStyle where
280 ppr (PprUser {}) = text "user-style"
281 ppr (PprCode {}) = text "code-style"
282 ppr (PprDump {}) = text "dump-style"
283 ppr (PprDebug {}) = text "debug-style"
284
285 {-
286 Orthogonal to the above printing styles are (possibly) some
287 command-line flags that affect printing (often carried with the
288 style). The most likely ones are variations on how much type info is
289 shown.
290
291 The following test decides whether or not we are actually generating
292 code (either C or assembly), or generating interface files.
293
294 ************************************************************************
295 * *
296 \subsection{The @SDoc@ data type}
297 * *
298 ************************************************************************
299 -}
300
301 newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
302
303 data SDocContext = SDC
304 { sdocStyle :: !PprStyle
305 , sdocLastColour :: !PprColour
306 -- ^ The most recently used colour. This allows nesting colours.
307 , sdocDynFlags :: !DynFlags
308 }
309
310 instance IsString SDoc where
311 fromString = text
312
313 initSDocContext :: DynFlags -> PprStyle -> SDocContext
314 initSDocContext dflags sty = SDC
315 { sdocStyle = sty
316 , sdocLastColour = colReset
317 , sdocDynFlags = dflags
318 }
319
320 withPprStyle :: PprStyle -> SDoc -> SDoc
321 withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
322
323 withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
324 withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
325
326 pprDeeper :: SDoc -> SDoc
327 pprDeeper d = SDoc $ \ctx -> case ctx of
328 SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..."
329 SDC{sdocStyle=PprUser q (PartWay n) c} ->
330 runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
331 _ -> runSDoc d ctx
332
333 -- | Truncate a list that is longer than the current depth.
334 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
335 pprDeeperList f ds
336 | null ds = f []
337 | otherwise = SDoc work
338 where
339 work ctx@SDC{sdocStyle=PprUser q (PartWay n) c}
340 | n==0 = Pretty.text "..."
341 | otherwise =
342 runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
343 where
344 go _ [] = []
345 go i (d:ds) | i >= n = [text "...."]
346 | otherwise = d : go (i+1) ds
347 work other_ctx = runSDoc (f ds) other_ctx
348
349 pprSetDepth :: Depth -> SDoc -> SDoc
350 pprSetDepth depth doc = SDoc $ \ctx ->
351 case ctx of
352 SDC{sdocStyle=PprUser q _ c} ->
353 runSDoc doc ctx{sdocStyle = PprUser q depth c}
354 _ ->
355 runSDoc doc ctx
356
357 getPprStyle :: (PprStyle -> SDoc) -> SDoc
358 getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
359
360 sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc
361 sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx
362
363 sdocWithPlatform :: (Platform -> SDoc) -> SDoc
364 sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
365
366 qualName :: PprStyle -> QueryQualifyName
367 qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ
368 qualName (PprDump q) mod occ = queryQualifyName q mod occ
369 qualName _other mod _ = NameQual (moduleName mod)
370
371 qualModule :: PprStyle -> QueryQualifyModule
372 qualModule (PprUser q _ _) m = queryQualifyModule q m
373 qualModule (PprDump q) m = queryQualifyModule q m
374 qualModule _other _m = True
375
376 qualPackage :: PprStyle -> QueryQualifyPackage
377 qualPackage (PprUser q _ _) m = queryQualifyPackage q m
378 qualPackage (PprDump q) m = queryQualifyPackage q m
379 qualPackage _other _m = True
380
381 queryQual :: PprStyle -> PrintUnqualified
382 queryQual s = QueryQualify (qualName s)
383 (qualModule s)
384 (qualPackage s)
385
386 codeStyle :: PprStyle -> Bool
387 codeStyle (PprCode _) = True
388 codeStyle _ = False
389
390 asmStyle :: PprStyle -> Bool
391 asmStyle (PprCode AsmStyle) = True
392 asmStyle _other = False
393
394 dumpStyle :: PprStyle -> Bool
395 dumpStyle (PprDump {}) = True
396 dumpStyle _other = False
397
398 debugStyle :: PprStyle -> Bool
399 debugStyle PprDebug = True
400 debugStyle _other = False
401
402 userStyle :: PprStyle -> Bool
403 userStyle (PprUser {}) = True
404 userStyle _other = False
405
406 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
407 ifPprDebug d = SDoc $ \ctx ->
408 case ctx of
409 SDC{sdocStyle=PprDebug} -> runSDoc d ctx
410 _ -> Pretty.empty
411
412 printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
413 printForUser dflags handle unqual doc
414 = Pretty.printDoc PageMode (pprCols dflags) handle
415 (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
416
417 printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
418 -> IO ()
419 printForUserPartWay dflags handle d unqual doc
420 = Pretty.printDoc PageMode (pprCols dflags) handle
421 (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d))))
422
423 -- printForC, printForAsm do what they sound like
424 printForC :: DynFlags -> Handle -> SDoc -> IO ()
425 printForC dflags handle doc =
426 Pretty.printDoc LeftMode (pprCols dflags) handle
427 (runSDoc doc (initSDocContext dflags (PprCode CStyle)))
428
429 printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
430 printForAsm dflags handle doc =
431 Pretty.printDoc LeftMode (pprCols dflags) handle
432 (runSDoc doc (initSDocContext dflags (PprCode AsmStyle)))
433
434 pprCode :: CodeStyle -> SDoc -> SDoc
435 pprCode cs d = withPprStyle (PprCode cs) d
436
437 mkCodeStyle :: CodeStyle -> PprStyle
438 mkCodeStyle = PprCode
439
440 -- Can't make SDoc an instance of Show because SDoc is just a function type
441 -- However, Doc *is* an instance of Show
442 -- showSDoc just blasts it out as a string
443 showSDoc :: DynFlags -> SDoc -> String
444 showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle
445
446 -- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be
447 -- initialised yet.
448 showSDocUnsafe :: SDoc -> String
449 showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc
450
451 showPpr :: Outputable a => DynFlags -> a -> String
452 showPpr dflags thing = showSDoc dflags (ppr thing)
453
454 showSDocUnqual :: DynFlags -> SDoc -> String
455 -- Only used by Haddock
456 showSDocUnqual dflags sdoc = showSDoc dflags sdoc
457
458 showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
459 -- Allows caller to specify the PrintUnqualified to use
460 showSDocForUser dflags unqual doc
461 = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay)
462
463 showSDocDump :: DynFlags -> SDoc -> String
464 showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle
465
466 showSDocDebug :: DynFlags -> SDoc -> String
467 showSDocDebug dflags d = renderWithStyle dflags d PprDebug
468
469 renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
470 renderWithStyle dflags sdoc sty
471 = let s = Pretty.style{ Pretty.mode = PageMode,
472 Pretty.lineLength = pprCols dflags }
473 in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty)
474
475 -- This shows an SDoc, but on one line only. It's cheaper than a full
476 -- showSDoc, designed for when we're getting results like "Foo.bar"
477 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
478 showSDocOneLine :: DynFlags -> SDoc -> String
479 showSDocOneLine dflags d
480 = let s = Pretty.style{ Pretty.mode = OneLineMode,
481 Pretty.lineLength = pprCols dflags } in
482 Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultUserStyle)
483
484 showSDocDumpOneLine :: DynFlags -> SDoc -> String
485 showSDocDumpOneLine dflags d
486 = let s = Pretty.style{ Pretty.mode = OneLineMode,
487 Pretty.lineLength = irrelevantNCols } in
488 Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultDumpStyle)
489
490 irrelevantNCols :: Int
491 -- Used for OneLineMode and LeftMode when number of cols isn't used
492 irrelevantNCols = 1
493
494 isEmpty :: DynFlags -> SDoc -> Bool
495 isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext
496 where dummySDocContext = initSDocContext dflags PprDebug
497
498 docToSDoc :: Doc -> SDoc
499 docToSDoc d = SDoc (\_ -> d)
500
501 empty :: SDoc
502 char :: Char -> SDoc
503 text :: String -> SDoc
504 ftext :: FastString -> SDoc
505 ptext :: LitString -> SDoc
506 ztext :: FastZString -> SDoc
507 int :: Int -> SDoc
508 integer :: Integer -> SDoc
509 float :: Float -> SDoc
510 double :: Double -> SDoc
511 rational :: Rational -> SDoc
512
513 empty = docToSDoc $ Pretty.empty
514 char c = docToSDoc $ Pretty.char c
515
516 text s = docToSDoc $ Pretty.text s
517 {-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire
518
519 ftext s = docToSDoc $ Pretty.ftext s
520 ptext s = docToSDoc $ Pretty.ptext s
521 ztext s = docToSDoc $ Pretty.ztext s
522 int n = docToSDoc $ Pretty.int n
523 integer n = docToSDoc $ Pretty.integer n
524 float n = docToSDoc $ Pretty.float n
525 double n = docToSDoc $ Pretty.double n
526 rational n = docToSDoc $ Pretty.rational n
527
528 -- | @doublePrec p n@ shows a floating point number @n@ with @p@
529 -- digits of precision after the decimal point.
530 doublePrec :: Int -> Double -> SDoc
531 doublePrec p n = text (showFFloat (Just p) n "")
532
533 parens, braces, brackets, quotes, quote,
534 paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
535
536 parens d = SDoc $ Pretty.parens . runSDoc d
537 braces d = SDoc $ Pretty.braces . runSDoc d
538 brackets d = SDoc $ Pretty.brackets . runSDoc d
539 quote d = SDoc $ Pretty.quote . runSDoc d
540 doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
541 angleBrackets d = char '<' <> d <> char '>'
542 paBrackets d = text "[:" <> d <> text ":]"
543
544 cparen :: Bool -> SDoc -> SDoc
545 cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
546
547 -- 'quotes' encloses something in single quotes...
548 -- but it omits them if the thing begins or ends in a single quote
549 -- so that we don't get `foo''. Instead we just have foo'.
550 quotes d =
551 sdocWithDynFlags $ \dflags ->
552 if useUnicode dflags
553 then char '' <> d <> char ''
554 else SDoc $ \sty ->
555 let pp_d = runSDoc d sty
556 str = show pp_d
557 in case (str, snocView str) of
558 (_, Just (_, '\'')) -> pp_d
559 ('\'' : _, _) -> pp_d
560 _other -> Pretty.quotes pp_d
561
562 semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
563 arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
564 lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
565
566 blankLine = docToSDoc $ Pretty.text ""
567 dcolon = unicodeSyntax (char '') (docToSDoc $ Pretty.text "::")
568 arrow = unicodeSyntax (char '') (docToSDoc $ Pretty.text "->")
569 larrow = unicodeSyntax (char '') (docToSDoc $ Pretty.text "<-")
570 darrow = unicodeSyntax (char '') (docToSDoc $ Pretty.text "=>")
571 arrowt = unicodeSyntax (char '') (docToSDoc $ Pretty.text ">-")
572 larrowt = unicodeSyntax (char '') (docToSDoc $ Pretty.text "-<")
573 arrowtt = unicodeSyntax (char '') (docToSDoc $ Pretty.text ">>-")
574 larrowtt = unicodeSyntax (char '') (docToSDoc $ Pretty.text "-<<")
575 semi = docToSDoc $ Pretty.semi
576 comma = docToSDoc $ Pretty.comma
577 colon = docToSDoc $ Pretty.colon
578 equals = docToSDoc $ Pretty.equals
579 space = docToSDoc $ Pretty.space
580 underscore = char '_'
581 dot = char '.'
582 vbar = char '|'
583 lparen = docToSDoc $ Pretty.lparen
584 rparen = docToSDoc $ Pretty.rparen
585 lbrack = docToSDoc $ Pretty.lbrack
586 rbrack = docToSDoc $ Pretty.rbrack
587 lbrace = docToSDoc $ Pretty.lbrace
588 rbrace = docToSDoc $ Pretty.rbrace
589
590 forAllLit :: SDoc
591 forAllLit = unicodeSyntax (char '') (text "forall")
592
593 kindStar :: SDoc
594 kindStar = unicodeSyntax (char '') (char '*')
595
596 unicodeSyntax :: SDoc -> SDoc -> SDoc
597 unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
598 if useUnicode dflags && useUnicodeSyntax dflags
599 then unicode
600 else plain
601
602 nest :: Int -> SDoc -> SDoc
603 -- ^ Indent 'SDoc' some specified amount
604 (<>) :: SDoc -> SDoc -> SDoc
605 -- ^ Join two 'SDoc' together horizontally without a gap
606 (<+>) :: SDoc -> SDoc -> SDoc
607 -- ^ Join two 'SDoc' together horizontally with a gap between them
608 ($$) :: SDoc -> SDoc -> SDoc
609 -- ^ Join two 'SDoc' together vertically; if there is
610 -- no vertical overlap it "dovetails" the two onto one line
611 ($+$) :: SDoc -> SDoc -> SDoc
612 -- ^ Join two 'SDoc' together vertically
613
614 nest n d = SDoc $ Pretty.nest n . runSDoc d
615 (<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty)
616 (<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
617 ($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty)
618 ($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
619
620 hcat :: [SDoc] -> SDoc
621 -- ^ Concatenate 'SDoc' horizontally
622 hsep :: [SDoc] -> SDoc
623 -- ^ Concatenate 'SDoc' horizontally with a space between each one
624 vcat :: [SDoc] -> SDoc
625 -- ^ Concatenate 'SDoc' vertically with dovetailing
626 sep :: [SDoc] -> SDoc
627 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
628 cat :: [SDoc] -> SDoc
629 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
630 fsep :: [SDoc] -> SDoc
631 -- ^ A paragraph-fill combinator. It's much like sep, only it
632 -- keeps fitting things on one line until it can't fit any more.
633 fcat :: [SDoc] -> SDoc
634 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
635
636
637 hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
638 hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
639 vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
640 sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds]
641 cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds]
642 fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
643 fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
644
645 hang :: SDoc -- ^ The header
646 -> Int -- ^ Amount to indent the hung body
647 -> SDoc -- ^ The hung body, indented and placed below the header
648 -> SDoc
649 hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
650
651 -- | This behaves like 'hang', but does not indent the second document
652 -- when the header is empty.
653 hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc
654 hangNotEmpty d1 n d2 =
655 SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty)
656
657 punctuate :: SDoc -- ^ The punctuation
658 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
659 -> [SDoc] -- ^ Punctuated list
660 punctuate _ [] = []
661 punctuate p (d:ds) = go d ds
662 where
663 go d [] = [d]
664 go d (e:es) = (d <> p) : go e es
665
666 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
667 ppWhen True doc = doc
668 ppWhen False _ = empty
669
670 ppUnless True _ = empty
671 ppUnless False doc = doc
672
673 -- | A colour\/style for use with 'coloured'.
674 newtype PprColour = PprColour String
675
676 -- | Allow colours to be combined (e.g. bold + red);
677 -- In case of conflict, right side takes precedence.
678 instance Monoid PprColour where
679 mempty = PprColour mempty
680 PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2)
681
682 -- Colours
683
684 colReset :: PprColour
685 colReset = PprColour "\27[0m"
686
687 colBold :: PprColour
688 colBold = PprColour "\27[;1m"
689
690 colBlackFg :: PprColour
691 colBlackFg = PprColour "\27[30m"
692
693 colRedFg :: PprColour
694 colRedFg = PprColour "\27[31m"
695
696 colGreenFg :: PprColour
697 colGreenFg = PprColour "\27[32m"
698
699 colYellowFg :: PprColour
700 colYellowFg = PprColour "\27[33m"
701
702 colBlueFg :: PprColour
703 colBlueFg = PprColour "\27[34m"
704
705 colMagentaFg :: PprColour
706 colMagentaFg = PprColour "\27[35m"
707
708 colCyanFg :: PprColour
709 colCyanFg = PprColour "\27[36m"
710
711 colWhiteFg :: PprColour
712 colWhiteFg = PprColour "\27[37m"
713
714 colBinder :: PprColour
715 colBinder = colGreenFg
716
717 colCoerc :: PprColour
718 colCoerc = colBlueFg
719
720 colDataCon :: PprColour
721 colDataCon = colRedFg
722
723 colType :: PprColour
724 colType = colBlueFg
725
726 -- | Apply the given colour\/style for the argument.
727 --
728 -- Only takes effect if colours are enabled.
729 coloured :: PprColour -> SDoc -> SDoc
730 coloured col@(PprColour c) sdoc =
731 sdocWithDynFlags $ \dflags ->
732 if overrideWith (canUseColor dflags) (useColor dflags)
733 then SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
734 case ctx of
735 SDC{ sdocStyle = PprUser _ _ Coloured } ->
736 let ctx' = ctx{ sdocLastColour = col } in
737 Pretty.zeroWidthText c
738 Pretty.<> runSDoc sdoc ctx'
739 Pretty.<> Pretty.zeroWidthText lc
740 _ -> runSDoc sdoc ctx
741 else sdoc
742
743 bold :: SDoc -> SDoc
744 bold = coloured colBold
745
746 keyword :: SDoc -> SDoc
747 keyword = bold
748
749 {-
750 ************************************************************************
751 * *
752 \subsection[Outputable-class]{The @Outputable@ class}
753 * *
754 ************************************************************************
755 -}
756
757 -- | Class designating that some type has an 'SDoc' representation
758 class Outputable a where
759 ppr :: a -> SDoc
760 pprPrec :: Rational -> a -> SDoc
761 -- 0 binds least tightly
762 -- We use Rational because there is always a
763 -- Rational between any other two Rationals
764
765 ppr = pprPrec 0
766 pprPrec _ = ppr
767
768 instance Outputable Char where
769 ppr c = text [c]
770
771 instance Outputable Bool where
772 ppr True = text "True"
773 ppr False = text "False"
774
775 instance Outputable Ordering where
776 ppr LT = text "LT"
777 ppr EQ = text "EQ"
778 ppr GT = text "GT"
779
780 instance Outputable Int32 where
781 ppr n = integer $ fromIntegral n
782
783 instance Outputable Int64 where
784 ppr n = integer $ fromIntegral n
785
786 instance Outputable Int where
787 ppr n = int n
788
789 instance Outputable Word16 where
790 ppr n = integer $ fromIntegral n
791
792 instance Outputable Word32 where
793 ppr n = integer $ fromIntegral n
794
795 instance Outputable Word where
796 ppr n = integer $ fromIntegral n
797
798 instance Outputable () where
799 ppr _ = text "()"
800
801 instance (Outputable a) => Outputable [a] where
802 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
803
804 instance (Outputable a) => Outputable (Set a) where
805 ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))
806
807 instance (Outputable a, Outputable b) => Outputable (a, b) where
808 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
809
810 instance Outputable a => Outputable (Maybe a) where
811 ppr Nothing = text "Nothing"
812 ppr (Just x) = text "Just" <+> ppr x
813
814 instance (Outputable a, Outputable b) => Outputable (Either a b) where
815 ppr (Left x) = text "Left" <+> ppr x
816 ppr (Right y) = text "Right" <+> ppr y
817
818 -- ToDo: may not be used
819 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
820 ppr (x,y,z) =
821 parens (sep [ppr x <> comma,
822 ppr y <> comma,
823 ppr z ])
824
825 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
826 Outputable (a, b, c, d) where
827 ppr (a,b,c,d) =
828 parens (sep [ppr a <> comma,
829 ppr b <> comma,
830 ppr c <> comma,
831 ppr d])
832
833 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
834 Outputable (a, b, c, d, e) where
835 ppr (a,b,c,d,e) =
836 parens (sep [ppr a <> comma,
837 ppr b <> comma,
838 ppr c <> comma,
839 ppr d <> comma,
840 ppr e])
841
842 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) =>
843 Outputable (a, b, c, d, e, f) where
844 ppr (a,b,c,d,e,f) =
845 parens (sep [ppr a <> comma,
846 ppr b <> comma,
847 ppr c <> comma,
848 ppr d <> comma,
849 ppr e <> comma,
850 ppr f])
851
852 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>
853 Outputable (a, b, c, d, e, f, g) where
854 ppr (a,b,c,d,e,f,g) =
855 parens (sep [ppr a <> comma,
856 ppr b <> comma,
857 ppr c <> comma,
858 ppr d <> comma,
859 ppr e <> comma,
860 ppr f <> comma,
861 ppr g])
862
863 instance Outputable FastString where
864 ppr fs = ftext fs -- Prints an unadorned string,
865 -- no double quotes or anything
866
867 instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
868 ppr m = ppr (M.toList m)
869 instance (Outputable elt) => Outputable (IM.IntMap elt) where
870 ppr m = ppr (IM.toList m)
871
872 instance Outputable Fingerprint where
873 ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2)
874
875 instance Outputable a => Outputable (SCC a) where
876 ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
877 ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
878
879 instance Outputable Serialized where
880 ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type)
881
882 instance Outputable Extension where
883 ppr = text . show
884
885 {-
886 ************************************************************************
887 * *
888 \subsection{The @OutputableBndr@ class}
889 * *
890 ************************************************************************
891 -}
892
893 -- | 'BindingSite' is used to tell the thing that prints binder what
894 -- language construct is binding the identifier. This can be used
895 -- to decide how much info to print.
896 -- Also see Note [Binding-site specific printing] in PprCore
897 data BindingSite
898 = LambdaBind -- ^ The x in (\x. e)
899 | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... }
900 | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }
901 | LetBind -- ^ The x in (let x = rhs in e)
902
903 -- | When we print a binder, we often want to print its type too.
904 -- The @OutputableBndr@ class encapsulates this idea.
905 class Outputable a => OutputableBndr a where
906 pprBndr :: BindingSite -> a -> SDoc
907 pprBndr _b x = ppr x
908
909 pprPrefixOcc, pprInfixOcc :: a -> SDoc
910 -- Print an occurrence of the name, suitable either in the
911 -- prefix position of an application, thus (f a b) or ((+) x)
912 -- or infix position, thus (a `f` b) or (x + y)
913
914 {-
915 ************************************************************************
916 * *
917 \subsection{Random printing helpers}
918 * *
919 ************************************************************************
920 -}
921
922 -- We have 31-bit Chars and will simply use Show instances of Char and String.
923
924 -- | Special combinator for showing character literals.
925 pprHsChar :: Char -> SDoc
926 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
927 | otherwise = text (show c)
928
929 -- | Special combinator for showing string literals.
930 pprHsString :: FastString -> SDoc
931 pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
932
933 -- | Special combinator for showing bytestring literals.
934 pprHsBytes :: ByteString -> SDoc
935 pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
936 in vcat (map text (showMultiLineString escaped)) <> char '#'
937 where escape :: Word8 -> String
938 escape w = let c = chr (fromIntegral w)
939 in if isAscii c
940 then [c]
941 else '\\' : show w
942
943 -- Postfix modifiers for unboxed literals.
944 -- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`.
945 primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc
946 primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc
947 primCharSuffix = char '#'
948 primFloatSuffix = char '#'
949 primIntSuffix = char '#'
950 primDoubleSuffix = text "##"
951 primWordSuffix = text "##"
952 primInt64Suffix = text "L#"
953 primWord64Suffix = text "L##"
954
955 -- | Special combinator for showing unboxed literals.
956 pprPrimChar :: Char -> SDoc
957 pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc
958 pprPrimChar c = pprHsChar c <> primCharSuffix
959 pprPrimInt i = integer i <> primIntSuffix
960 pprPrimWord w = integer w <> primWordSuffix
961 pprPrimInt64 i = integer i <> primInt64Suffix
962 pprPrimWord64 w = integer w <> primWord64Suffix
963
964 ---------------------
965 -- Put a name in parens if it's an operator
966 pprPrefixVar :: Bool -> SDoc -> SDoc
967 pprPrefixVar is_operator pp_v
968 | is_operator = parens pp_v
969 | otherwise = pp_v
970
971 -- Put a name in backquotes if it's not an operator
972 pprInfixVar :: Bool -> SDoc -> SDoc
973 pprInfixVar is_operator pp_v
974 | is_operator = pp_v
975 | otherwise = char '`' <> pp_v <> char '`'
976
977 ---------------------
978 pprFastFilePath :: FastString -> SDoc
979 pprFastFilePath path = text $ normalise $ unpackFS path
980
981 {-
982 ************************************************************************
983 * *
984 \subsection{Other helper functions}
985 * *
986 ************************************************************************
987 -}
988
989 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
990 -> [a] -- ^ The things to be pretty printed
991 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
992 -- comma-separated and finally packed into a paragraph.
993 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
994
995 pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use
996 -> [a] -- ^ The things to be pretty printed
997 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
998 -- bar-separated and finally packed into a paragraph.
999 pprWithBars pp xs = fsep (intersperse vbar (map pp xs))
1000
1001 -- | Returns the separated concatenation of the pretty printed things.
1002 interppSP :: Outputable a => [a] -> SDoc
1003 interppSP xs = sep (map ppr xs)
1004
1005 -- | Returns the comma-separated concatenation of the pretty printed things.
1006 interpp'SP :: Outputable a => [a] -> SDoc
1007 interpp'SP xs = sep (punctuate comma (map ppr xs))
1008
1009 -- | Returns the comma-separated concatenation of the quoted pretty printed things.
1010 --
1011 -- > [x,y,z] ==> `x', `y', `z'
1012 pprQuotedList :: Outputable a => [a] -> SDoc
1013 pprQuotedList = quotedList . map ppr
1014
1015 quotedList :: [SDoc] -> SDoc
1016 quotedList xs = hsep (punctuate comma (map quotes xs))
1017
1018 quotedListWithOr :: [SDoc] -> SDoc
1019 -- [x,y,z] ==> `x', `y' or `z'
1020 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs)
1021 quotedListWithOr xs = quotedList xs
1022
1023 quotedListWithNor :: [SDoc] -> SDoc
1024 -- [x,y,z] ==> `x', `y' nor `z'
1025 quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs)
1026 quotedListWithNor xs = quotedList xs
1027
1028 {-
1029 ************************************************************************
1030 * *
1031 \subsection{Printing numbers verbally}
1032 * *
1033 ************************************************************************
1034 -}
1035
1036 intWithCommas :: Integral a => a -> SDoc
1037 -- Prints a big integer with commas, eg 345,821
1038 intWithCommas n
1039 | n < 0 = char '-' <> intWithCommas (-n)
1040 | q == 0 = int (fromIntegral r)
1041 | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r)
1042 where
1043 (q,r) = n `quotRem` 1000
1044 zeroes | r >= 100 = empty
1045 | r >= 10 = char '0'
1046 | otherwise = text "00"
1047
1048 -- | Converts an integer to a verbal index:
1049 --
1050 -- > speakNth 1 = text "first"
1051 -- > speakNth 5 = text "fifth"
1052 -- > speakNth 21 = text "21st"
1053 speakNth :: Int -> SDoc
1054 speakNth 1 = text "first"
1055 speakNth 2 = text "second"
1056 speakNth 3 = text "third"
1057 speakNth 4 = text "fourth"
1058 speakNth 5 = text "fifth"
1059 speakNth 6 = text "sixth"
1060 speakNth n = hcat [ int n, text suffix ]
1061 where
1062 suffix | n <= 20 = "th" -- 11,12,13 are non-std
1063 | last_dig == 1 = "st"
1064 | last_dig == 2 = "nd"
1065 | last_dig == 3 = "rd"
1066 | otherwise = "th"
1067
1068 last_dig = n `rem` 10
1069
1070 -- | Converts an integer to a verbal multiplicity:
1071 --
1072 -- > speakN 0 = text "none"
1073 -- > speakN 5 = text "five"
1074 -- > speakN 10 = text "10"
1075 speakN :: Int -> SDoc
1076 speakN 0 = text "none" -- E.g. "he has none"
1077 speakN 1 = text "one" -- E.g. "he has one"
1078 speakN 2 = text "two"
1079 speakN 3 = text "three"
1080 speakN 4 = text "four"
1081 speakN 5 = text "five"
1082 speakN 6 = text "six"
1083 speakN n = int n
1084
1085 -- | Converts an integer and object description to a statement about the
1086 -- multiplicity of those objects:
1087 --
1088 -- > speakNOf 0 (text "melon") = text "no melons"
1089 -- > speakNOf 1 (text "melon") = text "one melon"
1090 -- > speakNOf 3 (text "melon") = text "three melons"
1091 speakNOf :: Int -> SDoc -> SDoc
1092 speakNOf 0 d = text "no" <+> d <> char 's'
1093 speakNOf 1 d = text "one" <+> d -- E.g. "one argument"
1094 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
1095
1096 -- | Determines the pluralisation suffix appropriate for the length of a list:
1097 --
1098 -- > plural [] = char 's'
1099 -- > plural ["Hello"] = empty
1100 -- > plural ["Hello", "World"] = char 's'
1101 plural :: [a] -> SDoc
1102 plural [_] = empty -- a bit frightening, but there you are
1103 plural _ = char 's'
1104
1105 -- | Determines the form of to be appropriate for the length of a list:
1106 --
1107 -- > isOrAre [] = text "are"
1108 -- > isOrAre ["Hello"] = text "is"
1109 -- > isOrAre ["Hello", "World"] = text "are"
1110 isOrAre :: [a] -> SDoc
1111 isOrAre [_] = text "is"
1112 isOrAre _ = text "are"
1113
1114 -- | Determines the form of to do appropriate for the length of a list:
1115 --
1116 -- > doOrDoes [] = text "do"
1117 -- > doOrDoes ["Hello"] = text "does"
1118 -- > doOrDoes ["Hello", "World"] = text "do"
1119 doOrDoes :: [a] -> SDoc
1120 doOrDoes [_] = text "does"
1121 doOrDoes _ = text "do"
1122
1123 {-
1124 ************************************************************************
1125 * *
1126 \subsection{Error handling}
1127 * *
1128 ************************************************************************
1129 -}
1130
1131 callStackDoc :: HasCallStack => SDoc
1132 callStackDoc =
1133 hang (text "Call stack:") 4 (vcat $ map text $ lines prettyCurrentCallStack)
1134
1135 pprPanic :: HasCallStack => String -> SDoc -> a
1136 -- ^ Throw an exception saying "bug in GHC"
1137 pprPanic s doc = panicDoc s (doc $$ callStackDoc)
1138
1139 pprSorry :: String -> SDoc -> a
1140 -- ^ Throw an exception saying "this isn't finished yet"
1141 pprSorry = sorryDoc
1142
1143
1144 pprPgmError :: String -> SDoc -> a
1145 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
1146 pprPgmError = pgmErrorDoc
1147
1148
1149 pprTrace :: String -> SDoc -> a -> a
1150 -- ^ If debug output is on, show some 'SDoc' on the screen
1151 pprTrace str doc x
1152 | opt_NoDebugOutput = x
1153 | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x
1154
1155 -- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@
1156 pprTraceIt :: Outputable a => String -> a -> a
1157 pprTraceIt desc x = pprTrace desc (ppr x) x
1158
1159
1160 -- | If debug output is on, show some 'SDoc' on the screen along
1161 -- with a call stack when available.
1162 pprSTrace :: HasCallStack => SDoc -> a -> a
1163 pprSTrace doc = pprTrace "" (doc $$ callStackDoc)
1164
1165 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
1166 -- ^ Just warn about an assertion failure, recording the given file and line number.
1167 -- Should typically be accessed with the WARN macros
1168 warnPprTrace _ _ _ _ x | not debugIsOn = x
1169 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
1170 warnPprTrace False _file _line _msg x = x
1171 warnPprTrace True file line msg x
1172 = pprDebugAndThen unsafeGlobalDynFlags trace heading msg x
1173 where
1174 heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]
1175
1176 -- | Panic with an assertation failure, recording the given file and
1177 -- line number. Should typically be accessed with the ASSERT family of macros
1178 assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a
1179 assertPprPanic _file _line msg
1180 = pprPanic "ASSERT failed!" doc
1181 where
1182 doc = sep [ msg, callStackDoc ]
1183
1184 pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a
1185 pprDebugAndThen dflags cont heading pretty_msg
1186 = cont (showSDocDump dflags doc)
1187 where
1188 doc = sep [heading, nest 2 pretty_msg]