2 % (c) The University of Glasgow 2006
3 % (c) The GRASP Project, Glasgow University, 1992-1998
7 -- | This module defines classes and functions for pretty-printing. It also
8 -- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
10 -- The interface to this module is very similar to the standard Hughes-PJ pretty printing
11 -- module, except that it exports a number of additional functions that are rarely used,
12 -- and works over the 'SDoc' type.
15 Outputable(..), OutputableBndr(..),
17 -- * Pretty printing combinators
20 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
24 int, integer, float, double, rational,
25 parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
26 semi, comma, colon, dcolon, space, equals, dot, arrow,
27 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
28 (<>), (<+>), hcat, hsep,
32 hang, punctuate, ppWhen, ppUnless,
33 speakNth, speakNTimes, speakN, speakNOf, plural,
35 -- * Converting 'SDoc' into strings and outputing it
36 printSDoc, printErrs, hPrintDump, printDump,
37 printForC, printForAsm, printForUser, printForUserPartWay,
39 showSDoc, showSDocOneLine,
40 showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
42 showSDocUnqual, showsPrecSDoc,
44 pprInfixVar, pprPrefixVar,
45 pprHsChar, pprHsString, pprHsInfix, pprHsVar,
48 -- * Controlling the style in which output is printed
51 PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
53 getPprStyle, withPprStyle, withPprStyleDoc,
54 pprDeeper, pprDeeperList, pprSetDepth,
55 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
56 ifPprDebug, qualName, qualModule,
57 mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
58 mkUserStyle, Depth(..),
60 -- * Error handling and debugging utilities
61 pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
62 pprTrace, warnPprTrace,
63 trace, pgmError, panic, panicFastInt, assertPanic
66 import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
67 import {-# SOURCE #-} OccName( OccName )
72 import qualified Pretty
73 import Pretty ( Doc, Mode(..) )
78 import System.IO ( Handle, stderr, stdout, hFlush )
79 import System.FilePath
83 %************************************************************************
85 \subsection{The @PprStyle@ data type}
87 %************************************************************************
92 = PprUser PrintUnqualified Depth
93 -- Pretty-print in a way that will make sense to the
94 -- ordinary user; must be very close to Haskell
96 -- Assumes printing tidied code: non-system names are
97 -- printed without uniques.
100 -- Print code; either C or assembler
102 | PprDump -- For -ddump-foo; less verbose than PprDebug.
103 -- Does not assume tidied code: non-external names
104 -- are printed with uniques.
106 | PprDebug -- Full debugging output
108 data CodeStyle = CStyle -- The format of labels differs for C and assembler
111 data Depth = AllTheWay
112 | PartWay Int -- 0 => stop
115 -- -----------------------------------------------------------------------------
116 -- Printing original names
118 -- When printing code that contains original names, we need to map the
119 -- original names back to something the user understands. This is the
120 -- purpose of the pair of functions that gets passed around
121 -- when rendering 'SDoc'.
123 -- | given an /original/ name, this function tells you which module
124 -- name it should be qualified with when printing for the user, if
125 -- any. For example, given @Control.Exception.catch@, which is in scope
126 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
127 -- Note that the return value is a ModuleName, not a Module, because
128 -- in source code, names are qualified by ModuleNames.
129 type QueryQualifyName = Module -> OccName -> QualifyName
131 -- See Note [Printing original names] in HscTypes
132 data QualifyName -- given P:M.T
133 = NameUnqual -- refer to it as "T"
134 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
136 -- it is not in scope at all, but M.T is not bound in the current
137 -- scope, so we can refer to it as "M.T"
139 -- it is not in scope at all, and M.T is already bound in the
140 -- current scope, so we must refer to it as "P:M.T"
143 -- | For a given module, we need to know whether to print it with
144 -- a package name to disambiguate it.
145 type QueryQualifyModule = Module -> Bool
147 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
149 alwaysQualifyNames :: QueryQualifyName
150 alwaysQualifyNames m _ = NameQual (moduleName m)
152 neverQualifyNames :: QueryQualifyName
153 neverQualifyNames _ _ = NameUnqual
155 alwaysQualifyModules :: QueryQualifyModule
156 alwaysQualifyModules _ = True
158 neverQualifyModules :: QueryQualifyModule
159 neverQualifyModules _ = False
161 alwaysQualify, neverQualify :: PrintUnqualified
162 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
163 neverQualify = (neverQualifyNames, neverQualifyModules)
165 defaultUserStyle, defaultDumpStyle :: PprStyle
167 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
169 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
170 | otherwise = PprDump
172 -- | Style for printing error messages
173 mkErrStyle :: PrintUnqualified -> PprStyle
174 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
176 defaultErrStyle :: PprStyle
177 -- Default style for error messages
178 -- It's a bit of a hack because it doesn't take into account what's in scope
179 -- Only used for desugarer warnings, and typechecker errors in interface sigs
181 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
182 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
184 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
185 mkUserStyle unqual depth
186 | opt_PprStyle_Debug = PprDebug
187 | otherwise = PprUser unqual depth
190 Orthogonal to the above printing styles are (possibly) some
191 command-line flags that affect printing (often carried with the
192 style). The most likely ones are variations on how much type info is
195 The following test decides whether or not we are actually generating
196 code (either C or assembly), or generating interface files.
198 %************************************************************************
200 \subsection{The @SDoc@ data type}
202 %************************************************************************
205 type SDoc = PprStyle -> Doc
207 withPprStyle :: PprStyle -> SDoc -> SDoc
208 withPprStyle sty d _sty' = d sty
210 withPprStyleDoc :: PprStyle -> SDoc -> Doc
211 withPprStyleDoc sty d = d sty
213 pprDeeper :: SDoc -> SDoc
214 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
215 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
216 pprDeeper d other_sty = d other_sty
218 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
219 -- Truncate a list that list that is longer than the current depth
220 pprDeeperList f ds (PprUser q (PartWay n))
221 | n==0 = Pretty.text "..."
222 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
225 go i (d:ds) | i >= n = [text "...."]
226 | otherwise = d : go (i+1) ds
228 pprDeeperList f ds other_sty
231 pprSetDepth :: Depth -> SDoc -> SDoc
232 pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
233 pprSetDepth _depth doc other_sty = doc other_sty
235 getPprStyle :: (PprStyle -> SDoc) -> SDoc
236 getPprStyle df sty = df sty sty
240 qualName :: PprStyle -> QueryQualifyName
241 qualName (PprUser (qual_name,_) _) m n = qual_name m n
242 qualName _other m _n = NameQual (moduleName m)
244 qualModule :: PprStyle -> QueryQualifyModule
245 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
246 qualModule _other _m = True
248 codeStyle :: PprStyle -> Bool
249 codeStyle (PprCode _) = True
252 asmStyle :: PprStyle -> Bool
253 asmStyle (PprCode AsmStyle) = True
254 asmStyle _other = False
256 dumpStyle :: PprStyle -> Bool
257 dumpStyle PprDump = True
258 dumpStyle _other = False
260 debugStyle :: PprStyle -> Bool
261 debugStyle PprDebug = True
262 debugStyle _other = False
264 userStyle :: PprStyle -> Bool
265 userStyle (PprUser _ _) = True
266 userStyle _other = False
268 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
269 ifPprDebug d sty@PprDebug = d sty
270 ifPprDebug _ _ = Pretty.empty
275 printSDoc :: SDoc -> PprStyle -> IO ()
277 Pretty.printDoc PageMode stdout (d sty)
280 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
281 -- above is better or worse than the put-big-string approach here
282 printErrs :: Doc -> IO ()
283 printErrs doc = do Pretty.printDoc PageMode stderr doc
286 printDump :: SDoc -> IO ()
287 printDump doc = hPrintDump stdout doc
289 hPrintDump :: Handle -> SDoc -> IO ()
290 hPrintDump h doc = do
291 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
294 better_doc = doc $$ text ""
296 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
297 printForUser handle unqual doc
298 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
300 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
301 printForUserPartWay handle d unqual doc
302 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
304 -- printForC, printForAsm do what they sound like
305 printForC :: Handle -> SDoc -> IO ()
306 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
308 printForAsm :: Handle -> SDoc -> IO ()
309 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
311 pprCode :: CodeStyle -> SDoc -> SDoc
312 pprCode cs d = withPprStyle (PprCode cs) d
314 mkCodeStyle :: CodeStyle -> PprStyle
315 mkCodeStyle = PprCode
317 -- Can't make SDoc an instance of Show because SDoc is just a function type
318 -- However, Doc *is* an instance of Show
319 -- showSDoc just blasts it out as a string
320 showSDoc :: SDoc -> String
321 showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
323 -- This shows an SDoc, but on one line only. It's cheaper than a full
324 -- showSDoc, designed for when we're getting results like "Foo.bar"
325 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
326 showSDocOneLine :: SDoc -> String
327 showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
329 showSDocForUser :: PrintUnqualified -> SDoc -> String
330 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
332 showSDocUnqual :: SDoc -> String
333 -- Only used in the gruesome isOperator
334 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
336 showsPrecSDoc :: Int -> SDoc -> ShowS
337 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
339 showSDocDump :: SDoc -> String
340 showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
342 showSDocDumpOneLine :: SDoc -> String
343 showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
345 showSDocDebug :: SDoc -> String
346 showSDocDebug d = show (d PprDebug)
348 showPpr :: Outputable a => a -> String
349 showPpr = showSDoc . ppr
353 docToSDoc :: Doc -> SDoc
354 docToSDoc d = \_ -> d
358 text :: String -> SDoc
359 ftext :: FastString -> SDoc
360 ptext :: LitString -> SDoc
362 integer :: Integer -> SDoc
363 float :: Float -> SDoc
364 double :: Double -> SDoc
365 rational :: Rational -> SDoc
367 empty _sty = Pretty.empty
368 char c _sty = Pretty.char c
369 text s _sty = Pretty.text s
370 ftext s _sty = Pretty.ftext s
371 ptext s _sty = Pretty.ptext s
372 int n _sty = Pretty.int n
373 integer n _sty = Pretty.integer n
374 float n _sty = Pretty.float n
375 double n _sty = Pretty.double n
376 rational n _sty = Pretty.rational n
378 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
380 parens d sty = Pretty.parens (d sty)
381 braces d sty = Pretty.braces (d sty)
382 brackets d sty = Pretty.brackets (d sty)
383 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
384 angleBrackets d = char '<' <> d <> char '>'
386 cparen :: Bool -> SDoc -> SDoc
388 cparen b d sty = Pretty.cparen b (d sty)
390 -- quotes encloses something in single quotes...
391 -- but it omits them if the thing ends in a single quote
392 -- so that we don't get `foo''. Instead we just have foo'.
393 quotes d sty = case show pp_d of
395 _other -> Pretty.quotes pp_d
399 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
400 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
402 semi _sty = Pretty.semi
403 comma _sty = Pretty.comma
404 colon _sty = Pretty.colon
405 equals _sty = Pretty.equals
406 space _sty = Pretty.space
407 dcolon _sty = Pretty.ptext (sLit "::")
408 arrow _sty = Pretty.ptext (sLit "->")
409 underscore = char '_'
411 lparen _sty = Pretty.lparen
412 rparen _sty = Pretty.rparen
413 lbrack _sty = Pretty.lbrack
414 rbrack _sty = Pretty.rbrack
415 lbrace _sty = Pretty.lbrace
416 rbrace _sty = Pretty.rbrace
418 nest :: Int -> SDoc -> SDoc
419 -- ^ Indent 'SDoc' some specified amount
420 (<>) :: SDoc -> SDoc -> SDoc
421 -- ^ Join two 'SDoc' together horizontally without a gap
422 (<+>) :: SDoc -> SDoc -> SDoc
423 -- ^ Join two 'SDoc' together horizontally with a gap between them
424 ($$) :: SDoc -> SDoc -> SDoc
425 -- ^ Join two 'SDoc' together vertically; if there is
426 -- no vertical overlap it "dovetails" the two onto one line
427 ($+$) :: SDoc -> SDoc -> SDoc
428 -- ^ Join two 'SDoc' together vertically
430 nest n d sty = Pretty.nest n (d sty)
431 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
432 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
433 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
434 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
436 hcat :: [SDoc] -> SDoc
437 -- ^ Concatenate 'SDoc' horizontally
438 hsep :: [SDoc] -> SDoc
439 -- ^ Concatenate 'SDoc' horizontally with a space between each one
440 vcat :: [SDoc] -> SDoc
441 -- ^ Concatenate 'SDoc' vertically with dovetailing
442 sep :: [SDoc] -> SDoc
443 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
444 cat :: [SDoc] -> SDoc
445 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
446 fsep :: [SDoc] -> SDoc
447 -- ^ A paragraph-fill combinator. It's much like sep, only it
448 -- keeps fitting things on one line until it can't fit any more.
449 fcat :: [SDoc] -> SDoc
450 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
453 hcat ds sty = Pretty.hcat [d sty | d <- ds]
454 hsep ds sty = Pretty.hsep [d sty | d <- ds]
455 vcat ds sty = Pretty.vcat [d sty | d <- ds]
456 sep ds sty = Pretty.sep [d sty | d <- ds]
457 cat ds sty = Pretty.cat [d sty | d <- ds]
458 fsep ds sty = Pretty.fsep [d sty | d <- ds]
459 fcat ds sty = Pretty.fcat [d sty | d <- ds]
461 hang :: SDoc -- ^ The header
462 -> Int -- ^ Amount to indent the hung body
463 -> SDoc -- ^ The hung body, indented and placed below the header
465 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
467 punctuate :: SDoc -- ^ The punctuation
468 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
469 -> [SDoc] -- ^ Punctuated list
471 punctuate p (d:ds) = go d ds
474 go d (e:es) = (d <> p) : go e es
476 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
477 ppWhen True doc = doc
478 ppWhen False _ = empty
480 ppUnless True _ = empty
481 ppUnless False doc = doc
485 %************************************************************************
487 \subsection[Outputable-class]{The @Outputable@ class}
489 %************************************************************************
492 -- | Class designating that some type has an 'SDoc' representation
493 class Outputable a where
498 instance Outputable Bool where
499 ppr True = ptext (sLit "True")
500 ppr False = ptext (sLit "False")
502 instance Outputable Int where
505 instance Outputable Word16 where
506 ppr n = integer $ fromIntegral n
508 instance Outputable Word32 where
509 ppr n = integer $ fromIntegral n
511 instance Outputable Word where
512 ppr n = integer $ fromIntegral n
514 instance Outputable () where
517 instance (Outputable a) => Outputable [a] where
518 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
520 instance (Outputable a, Outputable b) => Outputable (a, b) where
521 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
523 instance Outputable a => Outputable (Maybe a) where
524 ppr Nothing = ptext (sLit "Nothing")
525 ppr (Just x) = ptext (sLit "Just") <+> ppr x
527 instance (Outputable a, Outputable b) => Outputable (Either a b) where
528 ppr (Left x) = ptext (sLit "Left") <+> ppr x
529 ppr (Right y) = ptext (sLit "Right") <+> ppr y
531 -- ToDo: may not be used
532 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
534 parens (sep [ppr x <> comma,
538 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
539 Outputable (a, b, c, d) where
541 parens (sep [ppr a <> comma,
546 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
547 Outputable (a, b, c, d, e) where
549 parens (sep [ppr a <> comma,
555 instance Outputable FastString where
556 ppr fs = ftext fs -- Prints an unadorned string,
557 -- no double quotes or anything
560 %************************************************************************
562 \subsection{The @OutputableBndr@ class}
564 %************************************************************************
567 -- | 'BindingSite' is used to tell the thing that prints binder what
568 -- language construct is binding the identifier. This can be used
569 -- to decide how much info to print.
570 data BindingSite = LambdaBind | CaseBind | LetBind
572 -- | When we print a binder, we often want to print its type too.
573 -- The @OutputableBndr@ class encapsulates this idea.
574 class Outputable a => OutputableBndr a where
575 pprBndr :: BindingSite -> a -> SDoc
579 %************************************************************************
581 \subsection{Random printing helpers}
583 %************************************************************************
586 -- We have 31-bit Chars and will simply use Show instances of Char and String.
588 -- | Special combinator for showing character literals.
589 pprHsChar :: Char -> SDoc
590 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
591 | otherwise = text (show c)
593 -- | Special combinator for showing string literals.
594 pprHsString :: FastString -> SDoc
595 pprHsString fs = text (show (unpackFS fs))
597 ---------------------
598 -- Put a name in parens if it's an operator
599 pprPrefixVar :: Bool -> SDoc -> SDoc
600 pprPrefixVar is_operator pp_v
601 | is_operator = parens pp_v
604 -- Put a name in backquotes if it's not an operator
605 pprInfixVar :: Bool -> SDoc -> SDoc
606 pprInfixVar is_operator pp_v
608 | otherwise = char '`' <> pp_v <> char '`'
610 ---------------------
611 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
612 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
613 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
614 -- which none of the HsSyn printing functions do
615 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
616 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
618 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
621 isOperator :: SDoc -> Bool
623 = case showSDocUnqual ppr_v of
624 ('(':_) -> False -- (), (,) etc
625 ('[':_) -> False -- []
626 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
627 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
628 ('_':_) -> False -- Not an operator
629 (c:_) -> not (isAlpha c) -- Starts with non-alpha
632 pprFastFilePath :: FastString -> SDoc
633 pprFastFilePath path = text $ normalise $ unpackFS path
636 %************************************************************************
638 \subsection{Other helper functions}
640 %************************************************************************
643 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
644 -> [a] -- ^ The things to be pretty printed
645 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
646 -- comma-separated and finally packed into a paragraph.
647 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
649 -- | Returns the seperated concatenation of the pretty printed things.
650 interppSP :: Outputable a => [a] -> SDoc
651 interppSP xs = sep (map ppr xs)
653 -- | Returns the comma-seperated concatenation of the pretty printed things.
654 interpp'SP :: Outputable a => [a] -> SDoc
655 interpp'SP xs = sep (punctuate comma (map ppr xs))
657 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
659 -- > [x,y,z] ==> `x', `y', `z'
660 pprQuotedList :: Outputable a => [a] -> SDoc
661 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
665 %************************************************************************
667 \subsection{Printing numbers verbally}
669 %************************************************************************
672 -- | Converts an integer to a verbal index:
674 -- > speakNth 1 = text "first"
675 -- > speakNth 5 = text "fifth"
676 -- > speakNth 21 = text "21st"
677 speakNth :: Int -> SDoc
678 speakNth 1 = ptext (sLit "first")
679 speakNth 2 = ptext (sLit "second")
680 speakNth 3 = ptext (sLit "third")
681 speakNth 4 = ptext (sLit "fourth")
682 speakNth 5 = ptext (sLit "fifth")
683 speakNth 6 = ptext (sLit "sixth")
684 speakNth n = hcat [ int n, text suffix ]
686 suffix | n <= 20 = "th" -- 11,12,13 are non-std
687 | last_dig == 1 = "st"
688 | last_dig == 2 = "nd"
689 | last_dig == 3 = "rd"
692 last_dig = n `rem` 10
694 -- | Converts an integer to a verbal multiplicity:
696 -- > speakN 0 = text "none"
697 -- > speakN 5 = text "five"
698 -- > speakN 10 = text "10"
699 speakN :: Int -> SDoc
700 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
701 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
702 speakN 2 = ptext (sLit "two")
703 speakN 3 = ptext (sLit "three")
704 speakN 4 = ptext (sLit "four")
705 speakN 5 = ptext (sLit "five")
706 speakN 6 = ptext (sLit "six")
709 -- | Converts an integer and object description to a statement about the
710 -- multiplicity of those objects:
712 -- > speakNOf 0 (text "melon") = text "no melons"
713 -- > speakNOf 1 (text "melon") = text "one melon"
714 -- > speakNOf 3 (text "melon") = text "three melons"
715 speakNOf :: Int -> SDoc -> SDoc
716 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
717 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
718 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
720 -- | Converts a strictly positive integer into a number of times:
722 -- > speakNTimes 1 = text "once"
723 -- > speakNTimes 2 = text "twice"
724 -- > speakNTimes 4 = text "4 times"
725 speakNTimes :: Int {- >=1 -} -> SDoc
726 speakNTimes t | t == 1 = ptext (sLit "once")
727 | t == 2 = ptext (sLit "twice")
728 | otherwise = speakN t <+> ptext (sLit "times")
730 -- | Determines the pluralisation suffix appropriate for the length of a list:
732 -- > plural [] = char 's'
733 -- > plural ["Hello"] = empty
734 -- > plural ["Hello", "World"] = char 's'
735 plural :: [a] -> SDoc
736 plural [_] = empty -- a bit frightening, but there you are
741 %************************************************************************
743 \subsection{Error handling}
745 %************************************************************************
748 pprPanic :: String -> SDoc -> a
749 -- ^ Throw an exception saying "bug in GHC"
750 pprPgmError :: String -> SDoc -> a
751 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
752 pprTrace :: String -> SDoc -> a -> a
753 -- ^ If debug output is on, show some 'SDoc' on the screen
755 pprPanic = pprAndThen panic
757 pprPgmError = pprAndThen pgmError
760 | opt_NoDebugOutput = x
761 | otherwise = pprAndThen trace str doc x
763 pprPanicFastInt :: String -> SDoc -> FastInt
764 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
765 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
767 doc = text heading <+> pretty_msg
769 pprAndThen :: (String -> a) -> String -> SDoc -> a
770 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
772 doc = sep [text heading, nest 4 pretty_msg]
774 assertPprPanic :: String -> Int -> SDoc -> a
775 -- ^ Panic with an assertation failure, recording the given file and line number.
776 -- Should typically be accessed with the ASSERT family of macros
777 assertPprPanic file line msg
778 = panic (show (doc PprDebug))
780 doc = sep [hsep[text "ASSERT failed! file",
782 text "line", int line],
785 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
786 -- ^ Just warn about an assertion failure, recording the given file and line number.
787 -- Should typically be accessed with the WARN macros
788 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
789 warnPprTrace False _file _line _msg x = x
790 warnPprTrace True file line msg x
791 = trace (show (doc PprDebug)) x
793 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],