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,
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
478 %************************************************************************
480 \subsection[Outputable-class]{The @Outputable@ class}
482 %************************************************************************
485 -- | Class designating that some type has an 'SDoc' representation
486 class Outputable a where
491 instance Outputable Bool where
492 ppr True = ptext (sLit "True")
493 ppr False = ptext (sLit "False")
495 instance Outputable Int where
498 instance Outputable Word16 where
499 ppr n = integer $ fromIntegral n
501 instance Outputable Word32 where
502 ppr n = integer $ fromIntegral n
504 instance Outputable Word where
505 ppr n = integer $ fromIntegral n
507 instance Outputable () where
510 instance (Outputable a) => Outputable [a] where
511 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
513 instance (Outputable a, Outputable b) => Outputable (a, b) where
514 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
516 instance Outputable a => Outputable (Maybe a) where
517 ppr Nothing = ptext (sLit "Nothing")
518 ppr (Just x) = ptext (sLit "Just") <+> ppr x
520 instance (Outputable a, Outputable b) => Outputable (Either a b) where
521 ppr (Left x) = ptext (sLit "Left") <+> ppr x
522 ppr (Right y) = ptext (sLit "Right") <+> ppr y
524 -- ToDo: may not be used
525 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
527 parens (sep [ppr x <> comma,
531 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
532 Outputable (a, b, c, d) where
534 parens (sep [ppr a <> comma,
539 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
540 Outputable (a, b, c, d, e) where
542 parens (sep [ppr a <> comma,
548 instance Outputable FastString where
549 ppr fs = ftext fs -- Prints an unadorned string,
550 -- no double quotes or anything
553 %************************************************************************
555 \subsection{The @OutputableBndr@ class}
557 %************************************************************************
560 -- | 'BindingSite' is used to tell the thing that prints binder what
561 -- language construct is binding the identifier. This can be used
562 -- to decide how much info to print.
563 data BindingSite = LambdaBind | CaseBind | LetBind
565 -- | When we print a binder, we often want to print its type too.
566 -- The @OutputableBndr@ class encapsulates this idea.
567 class Outputable a => OutputableBndr a where
568 pprBndr :: BindingSite -> a -> SDoc
572 %************************************************************************
574 \subsection{Random printing helpers}
576 %************************************************************************
579 -- We have 31-bit Chars and will simply use Show instances of Char and String.
581 -- | Special combinator for showing character literals.
582 pprHsChar :: Char -> SDoc
583 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
584 | otherwise = text (show c)
586 -- | Special combinator for showing string literals.
587 pprHsString :: FastString -> SDoc
588 pprHsString fs = text (show (unpackFS fs))
590 ---------------------
591 -- Put a name in parens if it's an operator
592 pprPrefixVar :: Bool -> SDoc -> SDoc
593 pprPrefixVar is_operator pp_v
594 | is_operator = parens pp_v
597 -- Put a name in backquotes if it's not an operator
598 pprInfixVar :: Bool -> SDoc -> SDoc
599 pprInfixVar is_operator pp_v
601 | otherwise = char '`' <> pp_v <> char '`'
603 ---------------------
604 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
605 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
606 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
607 -- which none of the HsSyn printing functions do
608 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
609 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
611 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
614 isOperator :: SDoc -> Bool
616 = case showSDocUnqual ppr_v of
617 ('(':_) -> False -- (), (,) etc
618 ('[':_) -> False -- []
619 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
620 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
621 ('_':_) -> False -- Not an operator
622 (c:_) -> not (isAlpha c) -- Starts with non-alpha
625 pprFastFilePath :: FastString -> SDoc
626 pprFastFilePath path = text $ normalise $ unpackFS path
629 %************************************************************************
631 \subsection{Other helper functions}
633 %************************************************************************
636 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
637 -> [a] -- ^ The things to be pretty printed
638 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
639 -- comma-separated and finally packed into a paragraph.
640 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
642 -- | Returns the seperated concatenation of the pretty printed things.
643 interppSP :: Outputable a => [a] -> SDoc
644 interppSP xs = sep (map ppr xs)
646 -- | Returns the comma-seperated concatenation of the pretty printed things.
647 interpp'SP :: Outputable a => [a] -> SDoc
648 interpp'SP xs = sep (punctuate comma (map ppr xs))
650 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
652 -- > [x,y,z] ==> `x', `y', `z'
653 pprQuotedList :: Outputable a => [a] -> SDoc
654 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
658 %************************************************************************
660 \subsection{Printing numbers verbally}
662 %************************************************************************
665 -- | Converts an integer to a verbal index:
667 -- > speakNth 1 = text "first"
668 -- > speakNth 5 = text "fifth"
669 -- > speakNth 21 = text "21st"
670 speakNth :: Int -> SDoc
671 speakNth 1 = ptext (sLit "first")
672 speakNth 2 = ptext (sLit "second")
673 speakNth 3 = ptext (sLit "third")
674 speakNth 4 = ptext (sLit "fourth")
675 speakNth 5 = ptext (sLit "fifth")
676 speakNth 6 = ptext (sLit "sixth")
677 speakNth n = hcat [ int n, text suffix ]
679 suffix | n <= 20 = "th" -- 11,12,13 are non-std
680 | last_dig == 1 = "st"
681 | last_dig == 2 = "nd"
682 | last_dig == 3 = "rd"
685 last_dig = n `rem` 10
687 -- | Converts an integer to a verbal multiplicity:
689 -- > speakN 0 = text "none"
690 -- > speakN 5 = text "five"
691 -- > speakN 10 = text "10"
692 speakN :: Int -> SDoc
693 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
694 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
695 speakN 2 = ptext (sLit "two")
696 speakN 3 = ptext (sLit "three")
697 speakN 4 = ptext (sLit "four")
698 speakN 5 = ptext (sLit "five")
699 speakN 6 = ptext (sLit "six")
702 -- | Converts an integer and object description to a statement about the
703 -- multiplicity of those objects:
705 -- > speakNOf 0 (text "melon") = text "no melons"
706 -- > speakNOf 1 (text "melon") = text "one melon"
707 -- > speakNOf 3 (text "melon") = text "three melons"
708 speakNOf :: Int -> SDoc -> SDoc
709 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
710 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
711 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
713 -- | Converts a strictly positive integer into a number of times:
715 -- > speakNTimes 1 = text "once"
716 -- > speakNTimes 2 = text "twice"
717 -- > speakNTimes 4 = text "4 times"
718 speakNTimes :: Int {- >=1 -} -> SDoc
719 speakNTimes t | t == 1 = ptext (sLit "once")
720 | t == 2 = ptext (sLit "twice")
721 | otherwise = speakN t <+> ptext (sLit "times")
723 -- | Determines the pluralisation suffix appropriate for the length of a list:
725 -- > plural [] = char 's'
726 -- > plural ["Hello"] = empty
727 -- > plural ["Hello", "World"] = char 's'
728 plural :: [a] -> SDoc
729 plural [_] = empty -- a bit frightening, but there you are
734 %************************************************************************
736 \subsection{Error handling}
738 %************************************************************************
741 pprPanic :: String -> SDoc -> a
742 -- ^ Throw an exception saying "bug in GHC"
743 pprPgmError :: String -> SDoc -> a
744 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
745 pprTrace :: String -> SDoc -> a -> a
746 -- ^ If debug output is on, show some 'SDoc' on the screen
748 pprPanic = pprAndThen panic
750 pprPgmError = pprAndThen pgmError
753 | opt_NoDebugOutput = x
754 | otherwise = pprAndThen trace str doc x
756 pprPanicFastInt :: String -> SDoc -> FastInt
757 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
758 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
760 doc = text heading <+> pretty_msg
762 pprAndThen :: (String -> a) -> String -> SDoc -> a
763 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
765 doc = sep [text heading, nest 4 pretty_msg]
767 assertPprPanic :: String -> Int -> SDoc -> a
768 -- ^ Panic with an assertation failure, recording the given file and line number.
769 -- Should typically be accessed with the ASSERT family of macros
770 assertPprPanic file line msg
771 = panic (show (doc PprDebug))
773 doc = sep [hsep[text "ASSERT failed! file",
775 text "line", int line],
778 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
779 -- ^ Just warn about an assertion failure, recording the given file and line number.
780 -- Should typically be accessed with the WARN macros
781 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
782 warnPprTrace False _file _line _msg x = x
783 warnPprTrace True file line msg x
784 = trace (show (doc PprDebug)) x
786 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],