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