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,
29 (<>), (<+>), hcat, hsep,
33 hang, punctuate, ppWhen, ppUnless,
34 speakNth, speakNTimes, speakN, speakNOf, plural,
36 -- * Converting 'SDoc' into strings and outputing it
37 printSDoc, printErrs, hPrintDump, printDump,
38 printForC, printForAsm, printForUser, printForUserPartWay,
40 showSDoc, showSDocOneLine,
41 showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
43 showSDocUnqual, showsPrecSDoc,
45 pprInfixVar, pprPrefixVar,
46 pprHsChar, pprHsString, pprHsInfix, pprHsVar,
49 -- * Controlling the style in which output is printed
52 PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
54 getPprStyle, withPprStyle, withPprStyleDoc,
55 pprDeeper, pprDeeperList, pprSetDepth,
56 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
57 ifPprDebug, qualName, qualModule,
58 mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
59 mkUserStyle, Depth(..),
61 -- * Error handling and debugging utilities
62 pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
63 pprTrace, warnPprTrace,
64 trace, pgmError, panic, panicFastInt, assertPanic
67 import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
68 import {-# SOURCE #-} OccName( OccName )
73 import qualified Pretty
74 import Pretty ( Doc, Mode(..) )
79 import System.IO ( Handle, stderr, stdout, hFlush )
80 import System.FilePath
84 %************************************************************************
86 \subsection{The @PprStyle@ data type}
88 %************************************************************************
93 = PprUser PrintUnqualified Depth
94 -- Pretty-print in a way that will make sense to the
95 -- ordinary user; must be very close to Haskell
97 -- Assumes printing tidied code: non-system names are
98 -- printed without uniques.
101 -- Print code; either C or assembler
103 | PprDump -- For -ddump-foo; less verbose than PprDebug.
104 -- Does not assume tidied code: non-external names
105 -- are printed with uniques.
107 | PprDebug -- Full debugging output
109 data CodeStyle = CStyle -- The format of labels differs for C and assembler
112 data Depth = AllTheWay
113 | PartWay Int -- 0 => stop
116 -- -----------------------------------------------------------------------------
117 -- Printing original names
119 -- When printing code that contains original names, we need to map the
120 -- original names back to something the user understands. This is the
121 -- purpose of the pair of functions that gets passed around
122 -- when rendering 'SDoc'.
124 -- | given an /original/ name, this function tells you which module
125 -- name it should be qualified with when printing for the user, if
126 -- any. For example, given @Control.Exception.catch@, which is in scope
127 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
128 -- Note that the return value is a ModuleName, not a Module, because
129 -- in source code, names are qualified by ModuleNames.
130 type QueryQualifyName = Module -> OccName -> QualifyName
132 -- See Note [Printing original names] in HscTypes
133 data QualifyName -- given P:M.T
134 = NameUnqual -- refer to it as "T"
135 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
137 -- it is not in scope at all, but M.T is not bound in the current
138 -- scope, so we can refer to it as "M.T"
140 -- it is not in scope at all, and M.T is already bound in the
141 -- current scope, so we must refer to it as "P:M.T"
144 -- | For a given module, we need to know whether to print it with
145 -- a package name to disambiguate it.
146 type QueryQualifyModule = Module -> Bool
148 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
150 alwaysQualifyNames :: QueryQualifyName
151 alwaysQualifyNames m _ = NameQual (moduleName m)
153 neverQualifyNames :: QueryQualifyName
154 neverQualifyNames _ _ = NameUnqual
156 alwaysQualifyModules :: QueryQualifyModule
157 alwaysQualifyModules _ = True
159 neverQualifyModules :: QueryQualifyModule
160 neverQualifyModules _ = False
162 alwaysQualify, neverQualify :: PrintUnqualified
163 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
164 neverQualify = (neverQualifyNames, neverQualifyModules)
166 defaultUserStyle, defaultDumpStyle :: PprStyle
168 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
170 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
171 | otherwise = PprDump
173 -- | Style for printing error messages
174 mkErrStyle :: PrintUnqualified -> PprStyle
175 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
177 defaultErrStyle :: PprStyle
178 -- Default style for error messages
179 -- It's a bit of a hack because it doesn't take into account what's in scope
180 -- Only used for desugarer warnings, and typechecker errors in interface sigs
182 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
183 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
185 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
186 mkUserStyle unqual depth
187 | opt_PprStyle_Debug = PprDebug
188 | otherwise = PprUser unqual depth
191 Orthogonal to the above printing styles are (possibly) some
192 command-line flags that affect printing (often carried with the
193 style). The most likely ones are variations on how much type info is
196 The following test decides whether or not we are actually generating
197 code (either C or assembly), or generating interface files.
199 %************************************************************************
201 \subsection{The @SDoc@ data type}
203 %************************************************************************
206 type SDoc = PprStyle -> Doc
208 withPprStyle :: PprStyle -> SDoc -> SDoc
209 withPprStyle sty d _sty' = d sty
211 withPprStyleDoc :: PprStyle -> SDoc -> Doc
212 withPprStyleDoc sty d = d sty
214 pprDeeper :: SDoc -> SDoc
215 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
216 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
217 pprDeeper d other_sty = d other_sty
219 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
220 -- Truncate a list that list that is longer than the current depth
221 pprDeeperList f ds (PprUser q (PartWay n))
222 | n==0 = Pretty.text "..."
223 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
226 go i (d:ds) | i >= n = [text "...."]
227 | otherwise = d : go (i+1) ds
229 pprDeeperList f ds other_sty
232 pprSetDepth :: Depth -> SDoc -> SDoc
233 pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
234 pprSetDepth _depth doc other_sty = doc other_sty
236 getPprStyle :: (PprStyle -> SDoc) -> SDoc
237 getPprStyle df sty = df sty sty
241 qualName :: PprStyle -> QueryQualifyName
242 qualName (PprUser (qual_name,_) _) m n = qual_name m n
243 qualName _other m _n = NameQual (moduleName m)
245 qualModule :: PprStyle -> QueryQualifyModule
246 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
247 qualModule _other _m = True
249 codeStyle :: PprStyle -> Bool
250 codeStyle (PprCode _) = True
253 asmStyle :: PprStyle -> Bool
254 asmStyle (PprCode AsmStyle) = True
255 asmStyle _other = False
257 dumpStyle :: PprStyle -> Bool
258 dumpStyle PprDump = True
259 dumpStyle _other = False
261 debugStyle :: PprStyle -> Bool
262 debugStyle PprDebug = True
263 debugStyle _other = False
265 userStyle :: PprStyle -> Bool
266 userStyle (PprUser _ _) = True
267 userStyle _other = False
269 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
270 ifPprDebug d sty@PprDebug = d sty
271 ifPprDebug _ _ = Pretty.empty
276 printSDoc :: SDoc -> PprStyle -> IO ()
278 Pretty.printDoc PageMode stdout (d sty)
281 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
282 -- above is better or worse than the put-big-string approach here
283 printErrs :: Doc -> IO ()
284 printErrs doc = do Pretty.printDoc PageMode stderr doc
287 printDump :: SDoc -> IO ()
288 printDump doc = hPrintDump stdout doc
290 hPrintDump :: Handle -> SDoc -> IO ()
291 hPrintDump h doc = do
292 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
295 better_doc = doc $$ blankLine
297 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
298 printForUser handle unqual doc
299 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
301 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
302 printForUserPartWay handle d unqual doc
303 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
305 -- printForC, printForAsm do what they sound like
306 printForC :: Handle -> SDoc -> IO ()
307 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
309 printForAsm :: Handle -> SDoc -> IO ()
310 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
312 pprCode :: CodeStyle -> SDoc -> SDoc
313 pprCode cs d = withPprStyle (PprCode cs) d
315 mkCodeStyle :: CodeStyle -> PprStyle
316 mkCodeStyle = PprCode
318 -- Can't make SDoc an instance of Show because SDoc is just a function type
319 -- However, Doc *is* an instance of Show
320 -- showSDoc just blasts it out as a string
321 showSDoc :: SDoc -> String
322 showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
324 -- This shows an SDoc, but on one line only. It's cheaper than a full
325 -- showSDoc, designed for when we're getting results like "Foo.bar"
326 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
327 showSDocOneLine :: SDoc -> String
328 showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
330 showSDocForUser :: PrintUnqualified -> SDoc -> String
331 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
333 showSDocUnqual :: SDoc -> String
334 -- Only used in the gruesome isOperator
335 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
337 showsPrecSDoc :: Int -> SDoc -> ShowS
338 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
340 showSDocDump :: SDoc -> String
341 showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
343 showSDocDumpOneLine :: SDoc -> String
344 showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
346 showSDocDebug :: SDoc -> String
347 showSDocDebug d = show (d PprDebug)
349 showPpr :: Outputable a => a -> String
350 showPpr = showSDoc . ppr
354 docToSDoc :: Doc -> SDoc
355 docToSDoc d = \_ -> d
359 text :: String -> SDoc
360 ftext :: FastString -> SDoc
361 ptext :: LitString -> SDoc
363 integer :: Integer -> SDoc
364 float :: Float -> SDoc
365 double :: Double -> SDoc
366 rational :: Rational -> SDoc
368 empty _sty = Pretty.empty
369 char c _sty = Pretty.char c
370 text s _sty = Pretty.text s
371 ftext s _sty = Pretty.ftext s
372 ptext s _sty = Pretty.ptext s
373 int n _sty = Pretty.int n
374 integer n _sty = Pretty.integer n
375 float n _sty = Pretty.float n
376 double n _sty = Pretty.double n
377 rational n _sty = Pretty.rational n
379 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
381 parens d sty = Pretty.parens (d sty)
382 braces d sty = Pretty.braces (d sty)
383 brackets d sty = Pretty.brackets (d sty)
384 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
385 angleBrackets d = char '<' <> d <> char '>'
387 cparen :: Bool -> SDoc -> SDoc
389 cparen b d sty = Pretty.cparen b (d sty)
391 -- quotes encloses something in single quotes...
392 -- but it omits them if the thing ends in a single quote
393 -- so that we don't get `foo''. Instead we just have foo'.
394 quotes d sty = case show pp_d of
396 _other -> Pretty.quotes pp_d
400 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
401 lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
403 blankLine _sty = Pretty.ptext (sLit "")
404 dcolon _sty = Pretty.ptext (sLit "::")
405 arrow _sty = Pretty.ptext (sLit "->")
406 semi _sty = Pretty.semi
407 comma _sty = Pretty.comma
408 colon _sty = Pretty.colon
409 equals _sty = Pretty.equals
410 space _sty = Pretty.space
411 underscore = char '_'
413 lparen _sty = Pretty.lparen
414 rparen _sty = Pretty.rparen
415 lbrack _sty = Pretty.lbrack
416 rbrack _sty = Pretty.rbrack
417 lbrace _sty = Pretty.lbrace
418 rbrace _sty = Pretty.rbrace
420 nest :: Int -> SDoc -> SDoc
421 -- ^ Indent 'SDoc' some specified amount
422 (<>) :: SDoc -> SDoc -> SDoc
423 -- ^ Join two 'SDoc' together horizontally without a gap
424 (<+>) :: SDoc -> SDoc -> SDoc
425 -- ^ Join two 'SDoc' together horizontally with a gap between them
426 ($$) :: SDoc -> SDoc -> SDoc
427 -- ^ Join two 'SDoc' together vertically; if there is
428 -- no vertical overlap it "dovetails" the two onto one line
429 ($+$) :: SDoc -> SDoc -> SDoc
430 -- ^ Join two 'SDoc' together vertically
432 nest n d sty = Pretty.nest n (d sty)
433 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
434 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
435 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
436 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
438 hcat :: [SDoc] -> SDoc
439 -- ^ Concatenate 'SDoc' horizontally
440 hsep :: [SDoc] -> SDoc
441 -- ^ Concatenate 'SDoc' horizontally with a space between each one
442 vcat :: [SDoc] -> SDoc
443 -- ^ Concatenate 'SDoc' vertically with dovetailing
444 sep :: [SDoc] -> SDoc
445 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
446 cat :: [SDoc] -> SDoc
447 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
448 fsep :: [SDoc] -> SDoc
449 -- ^ A paragraph-fill combinator. It's much like sep, only it
450 -- keeps fitting things on one line until it can't fit any more.
451 fcat :: [SDoc] -> SDoc
452 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
455 hcat ds sty = Pretty.hcat [d sty | d <- ds]
456 hsep ds sty = Pretty.hsep [d sty | d <- ds]
457 vcat ds sty = Pretty.vcat [d sty | d <- ds]
458 sep ds sty = Pretty.sep [d sty | d <- ds]
459 cat ds sty = Pretty.cat [d sty | d <- ds]
460 fsep ds sty = Pretty.fsep [d sty | d <- ds]
461 fcat ds sty = Pretty.fcat [d sty | d <- ds]
463 hang :: SDoc -- ^ The header
464 -> Int -- ^ Amount to indent the hung body
465 -> SDoc -- ^ The hung body, indented and placed below the header
467 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
469 punctuate :: SDoc -- ^ The punctuation
470 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
471 -> [SDoc] -- ^ Punctuated list
473 punctuate p (d:ds) = go d ds
476 go d (e:es) = (d <> p) : go e es
478 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
479 ppWhen True doc = doc
480 ppWhen False _ = empty
482 ppUnless True _ = empty
483 ppUnless False doc = doc
487 %************************************************************************
489 \subsection[Outputable-class]{The @Outputable@ class}
491 %************************************************************************
494 -- | Class designating that some type has an 'SDoc' representation
495 class Outputable a where
500 instance Outputable Bool where
501 ppr True = ptext (sLit "True")
502 ppr False = ptext (sLit "False")
504 instance Outputable Int where
507 instance Outputable Word16 where
508 ppr n = integer $ fromIntegral n
510 instance Outputable Word32 where
511 ppr n = integer $ fromIntegral n
513 instance Outputable Word where
514 ppr n = integer $ fromIntegral n
516 instance Outputable () where
519 instance (Outputable a) => Outputable [a] where
520 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
522 instance (Outputable a, Outputable b) => Outputable (a, b) where
523 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
525 instance Outputable a => Outputable (Maybe a) where
526 ppr Nothing = ptext (sLit "Nothing")
527 ppr (Just x) = ptext (sLit "Just") <+> ppr x
529 instance (Outputable a, Outputable b) => Outputable (Either a b) where
530 ppr (Left x) = ptext (sLit "Left") <+> ppr x
531 ppr (Right y) = ptext (sLit "Right") <+> ppr y
533 -- ToDo: may not be used
534 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
536 parens (sep [ppr x <> comma,
540 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
541 Outputable (a, b, c, d) where
543 parens (sep [ppr a <> comma,
548 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
549 Outputable (a, b, c, d, e) where
551 parens (sep [ppr a <> comma,
557 instance Outputable FastString where
558 ppr fs = ftext fs -- Prints an unadorned string,
559 -- no double quotes or anything
562 %************************************************************************
564 \subsection{The @OutputableBndr@ class}
566 %************************************************************************
569 -- | 'BindingSite' is used to tell the thing that prints binder what
570 -- language construct is binding the identifier. This can be used
571 -- to decide how much info to print.
572 data BindingSite = LambdaBind | CaseBind | LetBind
574 -- | When we print a binder, we often want to print its type too.
575 -- The @OutputableBndr@ class encapsulates this idea.
576 class Outputable a => OutputableBndr a where
577 pprBndr :: BindingSite -> a -> SDoc
581 %************************************************************************
583 \subsection{Random printing helpers}
585 %************************************************************************
588 -- We have 31-bit Chars and will simply use Show instances of Char and String.
590 -- | Special combinator for showing character literals.
591 pprHsChar :: Char -> SDoc
592 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
593 | otherwise = text (show c)
595 -- | Special combinator for showing string literals.
596 pprHsString :: FastString -> SDoc
597 pprHsString fs = text (show (unpackFS fs))
599 ---------------------
600 -- Put a name in parens if it's an operator
601 pprPrefixVar :: Bool -> SDoc -> SDoc
602 pprPrefixVar is_operator pp_v
603 | is_operator = parens pp_v
606 -- Put a name in backquotes if it's not an operator
607 pprInfixVar :: Bool -> SDoc -> SDoc
608 pprInfixVar is_operator pp_v
610 | otherwise = char '`' <> pp_v <> char '`'
612 ---------------------
613 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
614 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
615 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
616 -- which none of the HsSyn printing functions do
617 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
618 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
620 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
623 isOperator :: SDoc -> Bool
625 = case showSDocUnqual ppr_v of
626 ('(':_) -> False -- (), (,) etc
627 ('[':_) -> False -- []
628 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
629 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
630 ('_':_) -> False -- Not an operator
631 (c:_) -> not (isAlpha c) -- Starts with non-alpha
634 pprFastFilePath :: FastString -> SDoc
635 pprFastFilePath path = text $ normalise $ unpackFS path
638 %************************************************************************
640 \subsection{Other helper functions}
642 %************************************************************************
645 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
646 -> [a] -- ^ The things to be pretty printed
647 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
648 -- comma-separated and finally packed into a paragraph.
649 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
651 -- | Returns the seperated concatenation of the pretty printed things.
652 interppSP :: Outputable a => [a] -> SDoc
653 interppSP xs = sep (map ppr xs)
655 -- | Returns the comma-seperated concatenation of the pretty printed things.
656 interpp'SP :: Outputable a => [a] -> SDoc
657 interpp'SP xs = sep (punctuate comma (map ppr xs))
659 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
661 -- > [x,y,z] ==> `x', `y', `z'
662 pprQuotedList :: Outputable a => [a] -> SDoc
663 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
667 %************************************************************************
669 \subsection{Printing numbers verbally}
671 %************************************************************************
674 -- | Converts an integer to a verbal index:
676 -- > speakNth 1 = text "first"
677 -- > speakNth 5 = text "fifth"
678 -- > speakNth 21 = text "21st"
679 speakNth :: Int -> SDoc
680 speakNth 1 = ptext (sLit "first")
681 speakNth 2 = ptext (sLit "second")
682 speakNth 3 = ptext (sLit "third")
683 speakNth 4 = ptext (sLit "fourth")
684 speakNth 5 = ptext (sLit "fifth")
685 speakNth 6 = ptext (sLit "sixth")
686 speakNth n = hcat [ int n, text suffix ]
688 suffix | n <= 20 = "th" -- 11,12,13 are non-std
689 | last_dig == 1 = "st"
690 | last_dig == 2 = "nd"
691 | last_dig == 3 = "rd"
694 last_dig = n `rem` 10
696 -- | Converts an integer to a verbal multiplicity:
698 -- > speakN 0 = text "none"
699 -- > speakN 5 = text "five"
700 -- > speakN 10 = text "10"
701 speakN :: Int -> SDoc
702 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
703 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
704 speakN 2 = ptext (sLit "two")
705 speakN 3 = ptext (sLit "three")
706 speakN 4 = ptext (sLit "four")
707 speakN 5 = ptext (sLit "five")
708 speakN 6 = ptext (sLit "six")
711 -- | Converts an integer and object description to a statement about the
712 -- multiplicity of those objects:
714 -- > speakNOf 0 (text "melon") = text "no melons"
715 -- > speakNOf 1 (text "melon") = text "one melon"
716 -- > speakNOf 3 (text "melon") = text "three melons"
717 speakNOf :: Int -> SDoc -> SDoc
718 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
719 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
720 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
722 -- | Converts a strictly positive integer into a number of times:
724 -- > speakNTimes 1 = text "once"
725 -- > speakNTimes 2 = text "twice"
726 -- > speakNTimes 4 = text "4 times"
727 speakNTimes :: Int {- >=1 -} -> SDoc
728 speakNTimes t | t == 1 = ptext (sLit "once")
729 | t == 2 = ptext (sLit "twice")
730 | otherwise = speakN t <+> ptext (sLit "times")
732 -- | Determines the pluralisation suffix appropriate for the length of a list:
734 -- > plural [] = char 's'
735 -- > plural ["Hello"] = empty
736 -- > plural ["Hello", "World"] = char 's'
737 plural :: [a] -> SDoc
738 plural [_] = empty -- a bit frightening, but there you are
743 %************************************************************************
745 \subsection{Error handling}
747 %************************************************************************
750 pprPanic :: String -> SDoc -> a
751 -- ^ Throw an exception saying "bug in GHC"
752 pprPgmError :: String -> SDoc -> a
753 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
754 pprTrace :: String -> SDoc -> a -> a
755 -- ^ If debug output is on, show some 'SDoc' on the screen
757 pprPanic = pprAndThen panic
759 pprPgmError = pprAndThen pgmError
762 | opt_NoDebugOutput = x
763 | otherwise = pprAndThen trace str doc x
765 pprPanicFastInt :: String -> SDoc -> FastInt
766 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
767 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
769 doc = text heading <+> pretty_msg
771 pprAndThen :: (String -> a) -> String -> SDoc -> a
772 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
774 doc = sep [text heading, nest 4 pretty_msg]
776 assertPprPanic :: String -> Int -> SDoc -> a
777 -- ^ Panic with an assertation failure, recording the given file and line number.
778 -- Should typically be accessed with the ASSERT family of macros
779 assertPprPanic file line msg
780 = panic (show (doc PprDebug))
782 doc = sep [hsep[text "ASSERT failed! file",
784 text "line", int line],
787 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
788 -- ^ Just warn about an assertion failure, recording the given file and line number.
789 -- Should typically be accessed with the WARN macros
790 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
791 warnPprTrace False _file _line _msg x = x
792 warnPprTrace True file line msg x
793 = trace (show (doc PprDebug)) x
795 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],