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