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(..) )
74 import Char ( isAlpha )
77 import Data.Word ( Word32 )
78 import System.IO ( Handle, stderr, stdout, hFlush )
79 import Data.Char ( ord )
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 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 :: Int -> SDoc -> SDoc
232 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
233 pprSetDepth _n d other_sty = d 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 Word32 where
499 ppr n = integer $ fromIntegral n
501 instance Outputable () where
504 instance (Outputable a) => Outputable [a] where
505 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
507 instance (Outputable a, Outputable b) => Outputable (a, b) where
508 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
510 instance Outputable a => Outputable (Maybe a) where
511 ppr Nothing = ptext (sLit "Nothing")
512 ppr (Just x) = ptext (sLit "Just") <+> ppr x
514 instance (Outputable a, Outputable b) => Outputable (Either a b) where
515 ppr (Left x) = ptext (sLit "Left") <+> ppr x
516 ppr (Right y) = ptext (sLit "Right") <+> ppr y
518 -- ToDo: may not be used
519 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
521 parens (sep [ppr x <> comma,
525 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
526 Outputable (a, b, c, d) where
528 parens (sep [ppr a <> comma,
533 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
534 Outputable (a, b, c, d, e) where
536 parens (sep [ppr a <> comma,
542 instance Outputable FastString where
543 ppr fs = ftext fs -- Prints an unadorned string,
544 -- no double quotes or anything
547 %************************************************************************
549 \subsection{The @OutputableBndr@ class}
551 %************************************************************************
554 -- | 'BindingSite' is used to tell the thing that prints binder what
555 -- language construct is binding the identifier. This can be used
556 -- to decide how much info to print.
557 data BindingSite = LambdaBind | CaseBind | LetBind
559 -- | When we print a binder, we often want to print its type too.
560 -- The @OutputableBndr@ class encapsulates this idea.
561 class Outputable a => OutputableBndr a where
562 pprBndr :: BindingSite -> a -> SDoc
566 %************************************************************************
568 \subsection{Random printing helpers}
570 %************************************************************************
573 -- We have 31-bit Chars and will simply use Show instances of Char and String.
575 -- | Special combinator for showing character literals.
576 pprHsChar :: Char -> SDoc
577 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
578 | otherwise = text (show c)
580 -- | Special combinator for showing string literals.
581 pprHsString :: FastString -> SDoc
582 pprHsString fs = text (show (unpackFS fs))
584 ---------------------
585 -- Put a name in parens if it's an operator
586 pprPrefixVar :: Bool -> SDoc -> SDoc
587 pprPrefixVar is_operator pp_v
588 | is_operator = parens pp_v
591 -- Put a name in backquotes if it's not an operator
592 pprInfixVar :: Bool -> SDoc -> SDoc
593 pprInfixVar is_operator pp_v
595 | otherwise = char '`' <> pp_v <> char '`'
597 ---------------------
598 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
599 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
600 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
601 -- which none of the HsSyn printing functions do
602 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
603 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
605 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
608 isOperator :: SDoc -> Bool
610 = case showSDocUnqual ppr_v of
611 ('(':_) -> False -- (), (,) etc
612 ('[':_) -> False -- []
613 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
614 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
615 ('_':_) -> False -- Not an operator
616 (c:_) -> not (isAlpha c) -- Starts with non-alpha
619 pprFastFilePath :: FastString -> SDoc
620 pprFastFilePath path = text $ normalise $ unpackFS path
623 %************************************************************************
625 \subsection{Other helper functions}
627 %************************************************************************
630 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
631 -> [a] -- ^ The things to be pretty printed
632 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
633 -- comma-separated and finally packed into a paragraph.
634 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
636 -- | Returns the seperated concatenation of the pretty printed things.
637 interppSP :: Outputable a => [a] -> SDoc
638 interppSP xs = sep (map ppr xs)
640 -- | Returns the comma-seperated concatenation of the pretty printed things.
641 interpp'SP :: Outputable a => [a] -> SDoc
642 interpp'SP xs = sep (punctuate comma (map ppr xs))
644 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
646 -- > [x,y,z] ==> `x', `y', `z'
647 pprQuotedList :: Outputable a => [a] -> SDoc
648 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
652 %************************************************************************
654 \subsection{Printing numbers verbally}
656 %************************************************************************
659 -- | Converts an integer to a verbal index:
661 -- > speakNth 1 = text "first"
662 -- > speakNth 5 = text "fifth"
663 -- > speakNth 21 = text "21st"
664 speakNth :: Int -> SDoc
665 speakNth 1 = ptext (sLit "first")
666 speakNth 2 = ptext (sLit "second")
667 speakNth 3 = ptext (sLit "third")
668 speakNth 4 = ptext (sLit "fourth")
669 speakNth 5 = ptext (sLit "fifth")
670 speakNth 6 = ptext (sLit "sixth")
671 speakNth n = hcat [ int n, text suffix ]
673 suffix | n <= 20 = "th" -- 11,12,13 are non-std
674 | last_dig == 1 = "st"
675 | last_dig == 2 = "nd"
676 | last_dig == 3 = "rd"
679 last_dig = n `rem` 10
681 -- | Converts an integer to a verbal multiplicity:
683 -- > speakN 0 = text "none"
684 -- > speakN 5 = text "five"
685 -- > speakN 10 = text "10"
686 speakN :: Int -> SDoc
687 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
688 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
689 speakN 2 = ptext (sLit "two")
690 speakN 3 = ptext (sLit "three")
691 speakN 4 = ptext (sLit "four")
692 speakN 5 = ptext (sLit "five")
693 speakN 6 = ptext (sLit "six")
696 -- | Converts an integer and object description to a statement about the
697 -- multiplicity of those objects:
699 -- > speakNOf 0 (text "melon") = text "no melons"
700 -- > speakNOf 1 (text "melon") = text "one melon"
701 -- > speakNOf 3 (text "melon") = text "three melons"
702 speakNOf :: Int -> SDoc -> SDoc
703 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
704 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
705 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
707 -- | Converts a strictly positive integer into a number of times:
709 -- > speakNTimes 1 = text "once"
710 -- > speakNTimes 2 = text "twice"
711 -- > speakNTimes 4 = text "4 times"
712 speakNTimes :: Int {- >=1 -} -> SDoc
713 speakNTimes t | t == 1 = ptext (sLit "once")
714 | t == 2 = ptext (sLit "twice")
715 | otherwise = speakN t <+> ptext (sLit "times")
717 -- | Determines the pluralisation suffix appropriate for the length of a list:
719 -- > plural [] = char 's'
720 -- > plural ["Hello"] = empty
721 -- > plural ["Hello", "World"] = char 's'
722 plural :: [a] -> SDoc
723 plural [_] = empty -- a bit frightening, but there you are
728 %************************************************************************
730 \subsection{Error handling}
732 %************************************************************************
735 pprPanic :: String -> SDoc -> a
736 -- ^ Throw an exception saying "bug in GHC"
737 pprPgmError :: String -> SDoc -> a
738 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
739 pprTrace :: String -> SDoc -> a -> a
740 -- ^ If debug output is on, show some 'SDoc' on the screen
742 pprPanic = pprAndThen panic
744 pprPgmError = pprAndThen pgmError
747 | opt_NoDebugOutput = x
748 | otherwise = pprAndThen trace str doc x
750 pprPanicFastInt :: String -> SDoc -> FastInt
751 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
752 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
754 doc = text heading <+> pretty_msg
756 pprAndThen :: (String -> a) -> String -> SDoc -> a
757 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
759 doc = sep [text heading, nest 4 pretty_msg]
761 assertPprPanic :: String -> Int -> SDoc -> a
762 -- ^ Panic with an assertation failure, recording the given file and line number.
763 -- Should typically be accessed with the ASSERT family of macros
764 assertPprPanic file line msg
765 = panic (show (doc PprDebug))
767 doc = sep [hsep[text "ASSERT failed! file",
769 text "line", int line],
772 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
773 -- ^ Just warn about an assertion failure, recording the given file and line number.
774 -- Should typically be accessed with the WARN macros
775 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
776 warnPprTrace False _file _line _msg x = x
777 warnPprTrace True file line msg x
778 = trace (show (doc PprDebug)) x
780 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],