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, quotedListWithOr,
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, printOutput, 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, cmdlineParserStyle, 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
190 cmdlineParserStyle :: PprStyle
191 cmdlineParserStyle = PprUser alwaysQualify AllTheWay
194 Orthogonal to the above printing styles are (possibly) some
195 command-line flags that affect printing (often carried with the
196 style). The most likely ones are variations on how much type info is
199 The following test decides whether or not we are actually generating
200 code (either C or assembly), or generating interface files.
202 %************************************************************************
204 \subsection{The @SDoc@ data type}
206 %************************************************************************
209 type SDoc = PprStyle -> Doc
211 withPprStyle :: PprStyle -> SDoc -> SDoc
212 withPprStyle sty d _sty' = d sty
214 withPprStyleDoc :: PprStyle -> SDoc -> Doc
215 withPprStyleDoc sty d = d sty
217 pprDeeper :: SDoc -> SDoc
218 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
219 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
220 pprDeeper d other_sty = d other_sty
222 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
223 -- Truncate a list that list that is longer than the current depth
224 pprDeeperList f ds (PprUser q (PartWay n))
225 | n==0 = Pretty.text "..."
226 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
229 go i (d:ds) | i >= n = [text "...."]
230 | otherwise = d : go (i+1) ds
232 pprDeeperList f ds other_sty
235 pprSetDepth :: Depth -> SDoc -> SDoc
236 pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
237 pprSetDepth _depth doc other_sty = doc other_sty
239 getPprStyle :: (PprStyle -> SDoc) -> SDoc
240 getPprStyle df sty = df sty sty
244 qualName :: PprStyle -> QueryQualifyName
245 qualName (PprUser (qual_name,_) _) m n = qual_name m n
246 qualName _other m _n = NameQual (moduleName m)
248 qualModule :: PprStyle -> QueryQualifyModule
249 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
250 qualModule _other _m = True
252 codeStyle :: PprStyle -> Bool
253 codeStyle (PprCode _) = True
256 asmStyle :: PprStyle -> Bool
257 asmStyle (PprCode AsmStyle) = True
258 asmStyle _other = False
260 dumpStyle :: PprStyle -> Bool
261 dumpStyle PprDump = True
262 dumpStyle _other = False
264 debugStyle :: PprStyle -> Bool
265 debugStyle PprDebug = True
266 debugStyle _other = False
268 userStyle :: PprStyle -> Bool
269 userStyle (PprUser _ _) = True
270 userStyle _other = False
272 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
273 ifPprDebug d sty@PprDebug = d sty
274 ifPprDebug _ _ = Pretty.empty
279 printSDoc :: SDoc -> PprStyle -> IO ()
281 Pretty.printDoc PageMode stdout (d sty)
284 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
285 -- above is better or worse than the put-big-string approach here
286 printErrs :: Doc -> IO ()
287 printErrs doc = do Pretty.printDoc PageMode stderr doc
290 printOutput :: Doc -> IO ()
291 printOutput doc = Pretty.printDoc PageMode stdout doc
293 printDump :: SDoc -> IO ()
294 printDump doc = hPrintDump stdout doc
296 hPrintDump :: Handle -> SDoc -> IO ()
297 hPrintDump h doc = do
298 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
301 better_doc = doc $$ blankLine
303 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
304 printForUser handle unqual doc
305 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
307 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
308 printForUserPartWay handle d unqual doc
309 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
311 -- printForC, printForAsm do what they sound like
312 printForC :: Handle -> SDoc -> IO ()
313 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
315 printForAsm :: Handle -> SDoc -> IO ()
316 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
318 pprCode :: CodeStyle -> SDoc -> SDoc
319 pprCode cs d = withPprStyle (PprCode cs) d
321 mkCodeStyle :: CodeStyle -> PprStyle
322 mkCodeStyle = PprCode
324 -- Can't make SDoc an instance of Show because SDoc is just a function type
325 -- However, Doc *is* an instance of Show
326 -- showSDoc just blasts it out as a string
327 showSDoc :: SDoc -> String
328 showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
330 -- This shows an SDoc, but on one line only. It's cheaper than a full
331 -- showSDoc, designed for when we're getting results like "Foo.bar"
332 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
333 showSDocOneLine :: SDoc -> String
334 showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
336 showSDocForUser :: PrintUnqualified -> SDoc -> String
337 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
339 showSDocUnqual :: SDoc -> String
340 -- Only used in the gruesome isOperator
341 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
343 showsPrecSDoc :: Int -> SDoc -> ShowS
344 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
346 showSDocDump :: SDoc -> String
347 showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
349 showSDocDumpOneLine :: SDoc -> String
350 showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
352 showSDocDebug :: SDoc -> String
353 showSDocDebug d = show (d PprDebug)
355 showPpr :: Outputable a => a -> String
356 showPpr = showSDoc . ppr
360 docToSDoc :: Doc -> SDoc
361 docToSDoc d = \_ -> d
365 text :: String -> SDoc
366 ftext :: FastString -> SDoc
367 ptext :: LitString -> SDoc
369 integer :: Integer -> SDoc
370 float :: Float -> SDoc
371 double :: Double -> SDoc
372 rational :: Rational -> SDoc
374 empty _sty = Pretty.empty
375 char c _sty = Pretty.char c
376 text s _sty = Pretty.text s
377 ftext s _sty = Pretty.ftext s
378 ptext s _sty = Pretty.ptext s
379 int n _sty = Pretty.int n
380 integer n _sty = Pretty.integer n
381 float n _sty = Pretty.float n
382 double n _sty = Pretty.double n
383 rational n _sty = Pretty.rational n
385 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
387 parens d sty = Pretty.parens (d sty)
388 braces d sty = Pretty.braces (d sty)
389 brackets d sty = Pretty.brackets (d sty)
390 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
391 angleBrackets d = char '<' <> d <> char '>'
393 cparen :: Bool -> SDoc -> SDoc
395 cparen b d sty = Pretty.cparen b (d sty)
397 -- quotes encloses something in single quotes...
398 -- but it omits them if the thing ends in a single quote
399 -- so that we don't get `foo''. Instead we just have foo'.
400 quotes d sty = case show pp_d of
402 _other -> Pretty.quotes pp_d
406 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
407 lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
409 blankLine _sty = Pretty.ptext (sLit "")
410 dcolon _sty = Pretty.ptext (sLit "::")
411 arrow _sty = Pretty.ptext (sLit "->")
412 semi _sty = Pretty.semi
413 comma _sty = Pretty.comma
414 colon _sty = Pretty.colon
415 equals _sty = Pretty.equals
416 space _sty = Pretty.space
417 underscore = char '_'
419 lparen _sty = Pretty.lparen
420 rparen _sty = Pretty.rparen
421 lbrack _sty = Pretty.lbrack
422 rbrack _sty = Pretty.rbrack
423 lbrace _sty = Pretty.lbrace
424 rbrace _sty = Pretty.rbrace
426 nest :: Int -> SDoc -> SDoc
427 -- ^ Indent 'SDoc' some specified amount
428 (<>) :: SDoc -> SDoc -> SDoc
429 -- ^ Join two 'SDoc' together horizontally without a gap
430 (<+>) :: SDoc -> SDoc -> SDoc
431 -- ^ Join two 'SDoc' together horizontally with a gap between them
432 ($$) :: SDoc -> SDoc -> SDoc
433 -- ^ Join two 'SDoc' together vertically; if there is
434 -- no vertical overlap it "dovetails" the two onto one line
435 ($+$) :: SDoc -> SDoc -> SDoc
436 -- ^ Join two 'SDoc' together vertically
438 nest n d sty = Pretty.nest n (d sty)
439 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
440 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
441 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
442 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
444 hcat :: [SDoc] -> SDoc
445 -- ^ Concatenate 'SDoc' horizontally
446 hsep :: [SDoc] -> SDoc
447 -- ^ Concatenate 'SDoc' horizontally with a space between each one
448 vcat :: [SDoc] -> SDoc
449 -- ^ Concatenate 'SDoc' vertically with dovetailing
450 sep :: [SDoc] -> SDoc
451 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
452 cat :: [SDoc] -> SDoc
453 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
454 fsep :: [SDoc] -> SDoc
455 -- ^ A paragraph-fill combinator. It's much like sep, only it
456 -- keeps fitting things on one line until it can't fit any more.
457 fcat :: [SDoc] -> SDoc
458 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
461 hcat ds sty = Pretty.hcat [d sty | d <- ds]
462 hsep ds sty = Pretty.hsep [d sty | d <- ds]
463 vcat ds sty = Pretty.vcat [d sty | d <- ds]
464 sep ds sty = Pretty.sep [d sty | d <- ds]
465 cat ds sty = Pretty.cat [d sty | d <- ds]
466 fsep ds sty = Pretty.fsep [d sty | d <- ds]
467 fcat ds sty = Pretty.fcat [d sty | d <- ds]
469 hang :: SDoc -- ^ The header
470 -> Int -- ^ Amount to indent the hung body
471 -> SDoc -- ^ The hung body, indented and placed below the header
473 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
475 punctuate :: SDoc -- ^ The punctuation
476 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
477 -> [SDoc] -- ^ Punctuated list
479 punctuate p (d:ds) = go d ds
482 go d (e:es) = (d <> p) : go e es
484 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
485 ppWhen True doc = doc
486 ppWhen False _ = empty
488 ppUnless True _ = empty
489 ppUnless False doc = doc
493 %************************************************************************
495 \subsection[Outputable-class]{The @Outputable@ class}
497 %************************************************************************
500 -- | Class designating that some type has an 'SDoc' representation
501 class Outputable a where
506 instance Outputable Bool where
507 ppr True = ptext (sLit "True")
508 ppr False = ptext (sLit "False")
510 instance Outputable Int where
513 instance Outputable Word16 where
514 ppr n = integer $ fromIntegral n
516 instance Outputable Word32 where
517 ppr n = integer $ fromIntegral n
519 instance Outputable Word where
520 ppr n = integer $ fromIntegral n
522 instance Outputable () where
525 instance (Outputable a) => Outputable [a] where
526 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
528 instance (Outputable a, Outputable b) => Outputable (a, b) where
529 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
531 instance Outputable a => Outputable (Maybe a) where
532 ppr Nothing = ptext (sLit "Nothing")
533 ppr (Just x) = ptext (sLit "Just") <+> ppr x
535 instance (Outputable a, Outputable b) => Outputable (Either a b) where
536 ppr (Left x) = ptext (sLit "Left") <+> ppr x
537 ppr (Right y) = ptext (sLit "Right") <+> ppr y
539 -- ToDo: may not be used
540 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
542 parens (sep [ppr x <> comma,
546 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
547 Outputable (a, b, c, d) where
549 parens (sep [ppr a <> comma,
554 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
555 Outputable (a, b, c, d, e) where
557 parens (sep [ppr a <> comma,
563 instance Outputable FastString where
564 ppr fs = ftext fs -- Prints an unadorned string,
565 -- no double quotes or anything
568 %************************************************************************
570 \subsection{The @OutputableBndr@ class}
572 %************************************************************************
575 -- | 'BindingSite' is used to tell the thing that prints binder what
576 -- language construct is binding the identifier. This can be used
577 -- to decide how much info to print.
578 data BindingSite = LambdaBind | CaseBind | LetBind
580 -- | When we print a binder, we often want to print its type too.
581 -- The @OutputableBndr@ class encapsulates this idea.
582 class Outputable a => OutputableBndr a where
583 pprBndr :: BindingSite -> a -> SDoc
587 %************************************************************************
589 \subsection{Random printing helpers}
591 %************************************************************************
594 -- We have 31-bit Chars and will simply use Show instances of Char and String.
596 -- | Special combinator for showing character literals.
597 pprHsChar :: Char -> SDoc
598 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
599 | otherwise = text (show c)
601 -- | Special combinator for showing string literals.
602 pprHsString :: FastString -> SDoc
603 pprHsString fs = text (show (unpackFS fs))
605 ---------------------
606 -- Put a name in parens if it's an operator
607 pprPrefixVar :: Bool -> SDoc -> SDoc
608 pprPrefixVar is_operator pp_v
609 | is_operator = parens pp_v
612 -- Put a name in backquotes if it's not an operator
613 pprInfixVar :: Bool -> SDoc -> SDoc
614 pprInfixVar is_operator pp_v
616 | otherwise = char '`' <> pp_v <> char '`'
618 ---------------------
619 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
620 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
621 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
622 -- which none of the HsSyn printing functions do
623 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
624 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
626 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
629 isOperator :: SDoc -> Bool
631 = case showSDocUnqual ppr_v of
632 ('(':_) -> False -- (), (,) etc
633 ('[':_) -> False -- []
634 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
635 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
636 ('_':_) -> False -- Not an operator
637 (c:_) -> not (isAlpha c) -- Starts with non-alpha
640 pprFastFilePath :: FastString -> SDoc
641 pprFastFilePath path = text $ normalise $ unpackFS path
644 %************************************************************************
646 \subsection{Other helper functions}
648 %************************************************************************
651 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
652 -> [a] -- ^ The things to be pretty printed
653 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
654 -- comma-separated and finally packed into a paragraph.
655 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
657 -- | Returns the seperated concatenation of the pretty printed things.
658 interppSP :: Outputable a => [a] -> SDoc
659 interppSP xs = sep (map ppr xs)
661 -- | Returns the comma-seperated concatenation of the pretty printed things.
662 interpp'SP :: Outputable a => [a] -> SDoc
663 interpp'SP xs = sep (punctuate comma (map ppr xs))
665 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
667 -- > [x,y,z] ==> `x', `y', `z'
668 pprQuotedList :: Outputable a => [a] -> SDoc
669 pprQuotedList = quotedList . map ppr
671 quotedList :: [SDoc] -> SDoc
672 quotedList xs = hsep (punctuate comma (map quotes xs))
674 quotedListWithOr :: [SDoc] -> SDoc
675 -- [x,y,z] ==> `x', `y' or `z'
676 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
677 quotedListWithOr xs = quotedList xs
681 %************************************************************************
683 \subsection{Printing numbers verbally}
685 %************************************************************************
688 -- | Converts an integer to a verbal index:
690 -- > speakNth 1 = text "first"
691 -- > speakNth 5 = text "fifth"
692 -- > speakNth 21 = text "21st"
693 speakNth :: Int -> SDoc
694 speakNth 1 = ptext (sLit "first")
695 speakNth 2 = ptext (sLit "second")
696 speakNth 3 = ptext (sLit "third")
697 speakNth 4 = ptext (sLit "fourth")
698 speakNth 5 = ptext (sLit "fifth")
699 speakNth 6 = ptext (sLit "sixth")
700 speakNth n = hcat [ int n, text suffix ]
702 suffix | n <= 20 = "th" -- 11,12,13 are non-std
703 | last_dig == 1 = "st"
704 | last_dig == 2 = "nd"
705 | last_dig == 3 = "rd"
708 last_dig = n `rem` 10
710 -- | Converts an integer to a verbal multiplicity:
712 -- > speakN 0 = text "none"
713 -- > speakN 5 = text "five"
714 -- > speakN 10 = text "10"
715 speakN :: Int -> SDoc
716 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
717 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
718 speakN 2 = ptext (sLit "two")
719 speakN 3 = ptext (sLit "three")
720 speakN 4 = ptext (sLit "four")
721 speakN 5 = ptext (sLit "five")
722 speakN 6 = ptext (sLit "six")
725 -- | Converts an integer and object description to a statement about the
726 -- multiplicity of those objects:
728 -- > speakNOf 0 (text "melon") = text "no melons"
729 -- > speakNOf 1 (text "melon") = text "one melon"
730 -- > speakNOf 3 (text "melon") = text "three melons"
731 speakNOf :: Int -> SDoc -> SDoc
732 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
733 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
734 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
736 -- | Converts a strictly positive integer into a number of times:
738 -- > speakNTimes 1 = text "once"
739 -- > speakNTimes 2 = text "twice"
740 -- > speakNTimes 4 = text "4 times"
741 speakNTimes :: Int {- >=1 -} -> SDoc
742 speakNTimes t | t == 1 = ptext (sLit "once")
743 | t == 2 = ptext (sLit "twice")
744 | otherwise = speakN t <+> ptext (sLit "times")
746 -- | Determines the pluralisation suffix appropriate for the length of a list:
748 -- > plural [] = char 's'
749 -- > plural ["Hello"] = empty
750 -- > plural ["Hello", "World"] = char 's'
751 plural :: [a] -> SDoc
752 plural [_] = empty -- a bit frightening, but there you are
757 %************************************************************************
759 \subsection{Error handling}
761 %************************************************************************
764 pprPanic :: String -> SDoc -> a
765 -- ^ Throw an exception saying "bug in GHC"
766 pprPgmError :: String -> SDoc -> a
767 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
768 pprTrace :: String -> SDoc -> a -> a
769 -- ^ If debug output is on, show some 'SDoc' on the screen
771 pprPanic = pprAndThen panic
773 pprPgmError = pprAndThen pgmError
776 | opt_NoDebugOutput = x
777 | otherwise = pprAndThen trace str doc x
779 pprPanicFastInt :: String -> SDoc -> FastInt
780 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
781 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
783 doc = text heading <+> pretty_msg
785 pprAndThen :: (String -> a) -> String -> SDoc -> a
786 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
788 doc = sep [text heading, nest 4 pretty_msg]
790 assertPprPanic :: String -> Int -> SDoc -> a
791 -- ^ Panic with an assertation failure, recording the given file and line number.
792 -- Should typically be accessed with the ASSERT family of macros
793 assertPprPanic file line msg
794 = panic (show (doc PprDebug))
796 doc = sep [hsep[text "ASSERT failed! file",
798 text "line", int line],
801 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
802 -- ^ Just warn about an assertion failure, recording the given file and line number.
803 -- Should typically be accessed with the WARN macros
804 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
805 warnPprTrace False _file _line _msg x = x
806 warnPprTrace True file line msg x
807 = trace (show (doc defaultDumpStyle)) x
809 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],