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