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, darrow,
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 qualified Data.Map as M
81 import System.IO ( Handle, stderr, stdout, hFlush )
82 import System.FilePath
86 %************************************************************************
88 \subsection{The @PprStyle@ data type}
90 %************************************************************************
95 = PprUser PrintUnqualified Depth
96 -- Pretty-print in a way that will make sense to the
97 -- ordinary user; must be very close to Haskell
99 -- Assumes printing tidied code: non-system names are
100 -- printed without uniques.
103 -- Print code; either C or assembler
105 | PprDump -- For -ddump-foo; less verbose than PprDebug.
106 -- Does not assume tidied code: non-external names
107 -- are printed with uniques.
109 | PprDebug -- Full debugging output
111 data CodeStyle = CStyle -- The format of labels differs for C and assembler
114 data Depth = AllTheWay
115 | PartWay Int -- 0 => stop
118 -- -----------------------------------------------------------------------------
119 -- Printing original names
121 -- When printing code that contains original names, we need to map the
122 -- original names back to something the user understands. This is the
123 -- purpose of the pair of functions that gets passed around
124 -- when rendering 'SDoc'.
126 -- | given an /original/ name, this function tells you which module
127 -- name it should be qualified with when printing for the user, if
128 -- any. For example, given @Control.Exception.catch@, which is in scope
129 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
130 -- Note that the return value is a ModuleName, not a Module, because
131 -- in source code, names are qualified by ModuleNames.
132 type QueryQualifyName = Module -> OccName -> QualifyName
134 -- See Note [Printing original names] in HscTypes
135 data QualifyName -- given P:M.T
136 = NameUnqual -- refer to it as "T"
137 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
139 -- it is not in scope at all, but M.T is not bound in the current
140 -- scope, so we can refer to it as "M.T"
142 -- it is not in scope at all, and M.T is already bound in the
143 -- current scope, so we must refer to it as "P:M.T"
146 -- | For a given module, we need to know whether to print it with
147 -- a package name to disambiguate it.
148 type QueryQualifyModule = Module -> Bool
150 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
152 alwaysQualifyNames :: QueryQualifyName
153 alwaysQualifyNames m _ = NameQual (moduleName m)
155 neverQualifyNames :: QueryQualifyName
156 neverQualifyNames _ _ = NameUnqual
158 alwaysQualifyModules :: QueryQualifyModule
159 alwaysQualifyModules _ = True
161 neverQualifyModules :: QueryQualifyModule
162 neverQualifyModules _ = False
164 alwaysQualify, neverQualify :: PrintUnqualified
165 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
166 neverQualify = (neverQualifyNames, neverQualifyModules)
168 defaultUserStyle, defaultDumpStyle :: PprStyle
170 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
172 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
173 | otherwise = PprDump
175 -- | Style for printing error messages
176 mkErrStyle :: PrintUnqualified -> PprStyle
177 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
179 defaultErrStyle :: PprStyle
180 -- Default style for error messages
181 -- It's a bit of a hack because it doesn't take into account what's in scope
182 -- Only used for desugarer warnings, and typechecker errors in interface sigs
184 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
185 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
187 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
188 mkUserStyle unqual depth
189 | opt_PprStyle_Debug = PprDebug
190 | otherwise = PprUser unqual depth
192 cmdlineParserStyle :: PprStyle
193 cmdlineParserStyle = PprUser alwaysQualify AllTheWay
196 Orthogonal to the above printing styles are (possibly) some
197 command-line flags that affect printing (often carried with the
198 style). The most likely ones are variations on how much type info is
201 The following test decides whether or not we are actually generating
202 code (either C or assembly), or generating interface files.
204 %************************************************************************
206 \subsection{The @SDoc@ data type}
208 %************************************************************************
211 type SDoc = PprStyle -> Doc
213 withPprStyle :: PprStyle -> SDoc -> SDoc
214 withPprStyle sty d _sty' = d sty
216 withPprStyleDoc :: PprStyle -> SDoc -> Doc
217 withPprStyleDoc sty d = d sty
219 pprDeeper :: SDoc -> SDoc
220 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
221 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
222 pprDeeper d other_sty = d other_sty
224 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
225 -- Truncate a list that list that is longer than the current depth
226 pprDeeperList f ds (PprUser q (PartWay n))
227 | n==0 = Pretty.text "..."
228 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
231 go i (d:ds) | i >= n = [text "...."]
232 | otherwise = d : go (i+1) ds
234 pprDeeperList f ds other_sty
237 pprSetDepth :: Depth -> SDoc -> SDoc
238 pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
239 pprSetDepth _depth doc other_sty = doc other_sty
241 getPprStyle :: (PprStyle -> SDoc) -> SDoc
242 getPprStyle df sty = df sty sty
246 qualName :: PprStyle -> QueryQualifyName
247 qualName (PprUser (qual_name,_) _) m n = qual_name m n
248 qualName _other m _n = NameQual (moduleName m)
250 qualModule :: PprStyle -> QueryQualifyModule
251 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
252 qualModule _other _m = True
254 codeStyle :: PprStyle -> Bool
255 codeStyle (PprCode _) = True
258 asmStyle :: PprStyle -> Bool
259 asmStyle (PprCode AsmStyle) = True
260 asmStyle _other = False
262 dumpStyle :: PprStyle -> Bool
263 dumpStyle PprDump = True
264 dumpStyle _other = False
266 debugStyle :: PprStyle -> Bool
267 debugStyle PprDebug = True
268 debugStyle _other = False
270 userStyle :: PprStyle -> Bool
271 userStyle (PprUser _ _) = True
272 userStyle _other = False
274 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
275 ifPprDebug d sty@PprDebug = d sty
276 ifPprDebug _ _ = Pretty.empty
281 printSDoc :: SDoc -> PprStyle -> IO ()
283 Pretty.printDoc PageMode stdout (d sty)
286 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
287 -- above is better or worse than the put-big-string approach here
288 printErrs :: Doc -> IO ()
289 printErrs doc = do Pretty.printDoc PageMode stderr doc
292 printOutput :: Doc -> IO ()
293 printOutput doc = Pretty.printDoc PageMode stdout doc
295 printDump :: SDoc -> IO ()
296 printDump doc = hPrintDump stdout doc
298 hPrintDump :: Handle -> SDoc -> IO ()
299 hPrintDump h doc = do
300 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
303 better_doc = doc $$ blankLine
305 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
306 printForUser handle unqual doc
307 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
309 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
310 printForUserPartWay handle d unqual doc
311 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
313 -- printForC, printForAsm do what they sound like
314 printForC :: Handle -> SDoc -> IO ()
315 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
317 printForAsm :: Handle -> SDoc -> IO ()
318 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
320 pprCode :: CodeStyle -> SDoc -> SDoc
321 pprCode cs d = withPprStyle (PprCode cs) d
323 mkCodeStyle :: CodeStyle -> PprStyle
324 mkCodeStyle = PprCode
326 -- Can't make SDoc an instance of Show because SDoc is just a function type
327 -- However, Doc *is* an instance of Show
328 -- showSDoc just blasts it out as a string
329 showSDoc :: SDoc -> String
330 showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
332 -- This shows an SDoc, but on one line only. It's cheaper than a full
333 -- showSDoc, designed for when we're getting results like "Foo.bar"
334 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
335 showSDocOneLine :: SDoc -> String
336 showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
338 showSDocForUser :: PrintUnqualified -> SDoc -> String
339 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
341 showSDocUnqual :: SDoc -> String
342 -- Only used in the gruesome isOperator
343 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
345 showsPrecSDoc :: Int -> SDoc -> ShowS
346 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
348 showSDocDump :: SDoc -> String
349 showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
351 showSDocDumpOneLine :: SDoc -> String
352 showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
354 showSDocDebug :: SDoc -> String
355 showSDocDebug d = show (d PprDebug)
357 showPpr :: Outputable a => a -> String
358 showPpr = showSDoc . ppr
362 docToSDoc :: Doc -> SDoc
363 docToSDoc d = \_ -> d
367 text :: String -> SDoc
368 ftext :: FastString -> SDoc
369 ptext :: LitString -> SDoc
371 integer :: Integer -> SDoc
372 float :: Float -> SDoc
373 double :: Double -> SDoc
374 rational :: Rational -> SDoc
376 empty _sty = Pretty.empty
377 char c _sty = Pretty.char c
378 text s _sty = Pretty.text s
379 ftext s _sty = Pretty.ftext s
380 ptext s _sty = Pretty.ptext s
381 int n _sty = Pretty.int n
382 integer n _sty = Pretty.integer n
383 float n _sty = Pretty.float n
384 double n _sty = Pretty.double n
385 rational n _sty = Pretty.rational n
387 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
389 parens d sty = Pretty.parens (d sty)
390 braces d sty = Pretty.braces (d sty)
391 brackets d sty = Pretty.brackets (d sty)
392 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
393 angleBrackets d = char '<' <> d <> char '>'
395 cparen :: Bool -> SDoc -> SDoc
397 cparen b d sty = Pretty.cparen b (d sty)
399 -- quotes encloses something in single quotes...
400 -- but it omits them if the thing ends in a single quote
401 -- so that we don't get `foo''. Instead we just have foo'.
402 quotes d sty = case show pp_d of
404 _other -> Pretty.quotes pp_d
408 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
409 darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
411 blankLine _sty = Pretty.ptext (sLit "")
412 dcolon _sty = Pretty.ptext (sLit "::")
413 arrow _sty = Pretty.ptext (sLit "->")
414 darrow _sty = Pretty.ptext (sLit "=>")
415 semi _sty = Pretty.semi
416 comma _sty = Pretty.comma
417 colon _sty = Pretty.colon
418 equals _sty = Pretty.equals
419 space _sty = Pretty.space
420 underscore = char '_'
422 lparen _sty = Pretty.lparen
423 rparen _sty = Pretty.rparen
424 lbrack _sty = Pretty.lbrack
425 rbrack _sty = Pretty.rbrack
426 lbrace _sty = Pretty.lbrace
427 rbrace _sty = Pretty.rbrace
429 nest :: Int -> SDoc -> SDoc
430 -- ^ Indent 'SDoc' some specified amount
431 (<>) :: SDoc -> SDoc -> SDoc
432 -- ^ Join two 'SDoc' together horizontally without a gap
433 (<+>) :: SDoc -> SDoc -> SDoc
434 -- ^ Join two 'SDoc' together horizontally with a gap between them
435 ($$) :: SDoc -> SDoc -> SDoc
436 -- ^ Join two 'SDoc' together vertically; if there is
437 -- no vertical overlap it "dovetails" the two onto one line
438 ($+$) :: SDoc -> SDoc -> SDoc
439 -- ^ Join two 'SDoc' together vertically
441 nest n d sty = Pretty.nest n (d sty)
442 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
443 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
444 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
445 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
447 hcat :: [SDoc] -> SDoc
448 -- ^ Concatenate 'SDoc' horizontally
449 hsep :: [SDoc] -> SDoc
450 -- ^ Concatenate 'SDoc' horizontally with a space between each one
451 vcat :: [SDoc] -> SDoc
452 -- ^ Concatenate 'SDoc' vertically with dovetailing
453 sep :: [SDoc] -> SDoc
454 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
455 cat :: [SDoc] -> SDoc
456 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
457 fsep :: [SDoc] -> SDoc
458 -- ^ A paragraph-fill combinator. It's much like sep, only it
459 -- keeps fitting things on one line until it can't fit any more.
460 fcat :: [SDoc] -> SDoc
461 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
464 hcat ds sty = Pretty.hcat [d sty | d <- ds]
465 hsep ds sty = Pretty.hsep [d sty | d <- ds]
466 vcat ds sty = Pretty.vcat [d sty | d <- ds]
467 sep ds sty = Pretty.sep [d sty | d <- ds]
468 cat ds sty = Pretty.cat [d sty | d <- ds]
469 fsep ds sty = Pretty.fsep [d sty | d <- ds]
470 fcat ds sty = Pretty.fcat [d sty | d <- ds]
472 hang :: SDoc -- ^ The header
473 -> Int -- ^ Amount to indent the hung body
474 -> SDoc -- ^ The hung body, indented and placed below the header
476 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
478 punctuate :: SDoc -- ^ The punctuation
479 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
480 -> [SDoc] -- ^ Punctuated list
482 punctuate p (d:ds) = go d ds
485 go d (e:es) = (d <> p) : go e es
487 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
488 ppWhen True doc = doc
489 ppWhen False _ = empty
491 ppUnless True _ = empty
492 ppUnless False doc = doc
496 %************************************************************************
498 \subsection[Outputable-class]{The @Outputable@ class}
500 %************************************************************************
503 -- | Class designating that some type has an 'SDoc' representation
504 class Outputable a where
509 instance Outputable Bool where
510 ppr True = ptext (sLit "True")
511 ppr False = ptext (sLit "False")
513 instance Outputable Int where
516 instance Outputable Word16 where
517 ppr n = integer $ fromIntegral n
519 instance Outputable Word32 where
520 ppr n = integer $ fromIntegral n
522 instance Outputable Word where
523 ppr n = integer $ fromIntegral n
525 instance Outputable () where
528 instance (Outputable a) => Outputable [a] where
529 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
531 instance (Outputable a, Outputable b) => Outputable (a, b) where
532 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
534 instance Outputable a => Outputable (Maybe a) where
535 ppr Nothing = ptext (sLit "Nothing")
536 ppr (Just x) = ptext (sLit "Just") <+> ppr x
538 instance (Outputable a, Outputable b) => Outputable (Either a b) where
539 ppr (Left x) = ptext (sLit "Left") <+> ppr x
540 ppr (Right y) = ptext (sLit "Right") <+> ppr y
542 -- ToDo: may not be used
543 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
545 parens (sep [ppr x <> comma,
549 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
550 Outputable (a, b, c, d) where
552 parens (sep [ppr a <> comma,
557 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
558 Outputable (a, b, c, d, e) where
560 parens (sep [ppr a <> comma,
566 instance Outputable FastString where
567 ppr fs = ftext fs -- Prints an unadorned string,
568 -- no double quotes or anything
570 instance (Outputable key, Outputable elt) => Outputable (Map key elt) where
571 ppr m = ppr (M.toList m)
574 %************************************************************************
576 \subsection{The @OutputableBndr@ class}
578 %************************************************************************
581 -- | 'BindingSite' is used to tell the thing that prints binder what
582 -- language construct is binding the identifier. This can be used
583 -- to decide how much info to print.
584 data BindingSite = LambdaBind | CaseBind | LetBind
586 -- | When we print a binder, we often want to print its type too.
587 -- The @OutputableBndr@ class encapsulates this idea.
588 class Outputable a => OutputableBndr a where
589 pprBndr :: BindingSite -> a -> SDoc
593 %************************************************************************
595 \subsection{Random printing helpers}
597 %************************************************************************
600 -- We have 31-bit Chars and will simply use Show instances of Char and String.
602 -- | Special combinator for showing character literals.
603 pprHsChar :: Char -> SDoc
604 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
605 | otherwise = text (show c)
607 -- | Special combinator for showing string literals.
608 pprHsString :: FastString -> SDoc
609 pprHsString fs = text (show (unpackFS fs))
611 ---------------------
612 -- Put a name in parens if it's an operator
613 pprPrefixVar :: Bool -> SDoc -> SDoc
614 pprPrefixVar is_operator pp_v
615 | is_operator = parens pp_v
618 -- Put a name in backquotes if it's not an operator
619 pprInfixVar :: Bool -> SDoc -> SDoc
620 pprInfixVar is_operator pp_v
622 | otherwise = char '`' <> pp_v <> char '`'
624 ---------------------
625 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
626 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
627 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
628 -- which none of the HsSyn printing functions do
629 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
630 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
632 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
635 isOperator :: SDoc -> Bool
637 = case showSDocUnqual ppr_v of
638 ('(':_) -> False -- (), (,) etc
639 ('[':_) -> False -- []
640 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
641 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
642 ('_':_) -> False -- Not an operator
643 (c:_) -> not (isAlpha c) -- Starts with non-alpha
646 pprFastFilePath :: FastString -> SDoc
647 pprFastFilePath path = text $ normalise $ unpackFS path
650 %************************************************************************
652 \subsection{Other helper functions}
654 %************************************************************************
657 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
658 -> [a] -- ^ The things to be pretty printed
659 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
660 -- comma-separated and finally packed into a paragraph.
661 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
663 -- | Returns the seperated concatenation of the pretty printed things.
664 interppSP :: Outputable a => [a] -> SDoc
665 interppSP xs = sep (map ppr xs)
667 -- | Returns the comma-seperated concatenation of the pretty printed things.
668 interpp'SP :: Outputable a => [a] -> SDoc
669 interpp'SP xs = sep (punctuate comma (map ppr xs))
671 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
673 -- > [x,y,z] ==> `x', `y', `z'
674 pprQuotedList :: Outputable a => [a] -> SDoc
675 pprQuotedList = quotedList . map ppr
677 quotedList :: [SDoc] -> SDoc
678 quotedList xs = hsep (punctuate comma (map quotes xs))
680 quotedListWithOr :: [SDoc] -> SDoc
681 -- [x,y,z] ==> `x', `y' or `z'
682 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
683 quotedListWithOr xs = quotedList xs
687 %************************************************************************
689 \subsection{Printing numbers verbally}
691 %************************************************************************
694 -- | Converts an integer to a verbal index:
696 -- > speakNth 1 = text "first"
697 -- > speakNth 5 = text "fifth"
698 -- > speakNth 21 = text "21st"
699 speakNth :: Int -> SDoc
700 speakNth 1 = ptext (sLit "first")
701 speakNth 2 = ptext (sLit "second")
702 speakNth 3 = ptext (sLit "third")
703 speakNth 4 = ptext (sLit "fourth")
704 speakNth 5 = ptext (sLit "fifth")
705 speakNth 6 = ptext (sLit "sixth")
706 speakNth n = hcat [ int n, text suffix ]
708 suffix | n <= 20 = "th" -- 11,12,13 are non-std
709 | last_dig == 1 = "st"
710 | last_dig == 2 = "nd"
711 | last_dig == 3 = "rd"
714 last_dig = n `rem` 10
716 -- | Converts an integer to a verbal multiplicity:
718 -- > speakN 0 = text "none"
719 -- > speakN 5 = text "five"
720 -- > speakN 10 = text "10"
721 speakN :: Int -> SDoc
722 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
723 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
724 speakN 2 = ptext (sLit "two")
725 speakN 3 = ptext (sLit "three")
726 speakN 4 = ptext (sLit "four")
727 speakN 5 = ptext (sLit "five")
728 speakN 6 = ptext (sLit "six")
731 -- | Converts an integer and object description to a statement about the
732 -- multiplicity of those objects:
734 -- > speakNOf 0 (text "melon") = text "no melons"
735 -- > speakNOf 1 (text "melon") = text "one melon"
736 -- > speakNOf 3 (text "melon") = text "three melons"
737 speakNOf :: Int -> SDoc -> SDoc
738 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
739 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
740 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
742 -- | Converts a strictly positive integer into a number of times:
744 -- > speakNTimes 1 = text "once"
745 -- > speakNTimes 2 = text "twice"
746 -- > speakNTimes 4 = text "4 times"
747 speakNTimes :: Int {- >=1 -} -> SDoc
748 speakNTimes t | t == 1 = ptext (sLit "once")
749 | t == 2 = ptext (sLit "twice")
750 | otherwise = speakN t <+> ptext (sLit "times")
752 -- | Determines the pluralisation suffix appropriate for the length of a list:
754 -- > plural [] = char 's'
755 -- > plural ["Hello"] = empty
756 -- > plural ["Hello", "World"] = char 's'
757 plural :: [a] -> SDoc
758 plural [_] = empty -- a bit frightening, but there you are
763 %************************************************************************
765 \subsection{Error handling}
767 %************************************************************************
770 pprPanic :: String -> SDoc -> a
771 -- ^ Throw an exception saying "bug in GHC"
772 pprPgmError :: String -> SDoc -> a
773 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
774 pprTrace :: String -> SDoc -> a -> a
775 -- ^ If debug output is on, show some 'SDoc' on the screen
777 pprPanic = pprAndThen panic
779 pprPgmError = pprAndThen pgmError
782 | opt_NoDebugOutput = x
783 | otherwise = pprAndThen trace str doc x
785 pprPanicFastInt :: String -> SDoc -> FastInt
786 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
787 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
789 doc = text heading <+> pretty_msg
791 pprAndThen :: (String -> a) -> String -> SDoc -> a
792 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
794 doc = sep [text heading, nest 4 pretty_msg]
796 assertPprPanic :: String -> Int -> SDoc -> a
797 -- ^ Panic with an assertation failure, recording the given file and line number.
798 -- Should typically be accessed with the ASSERT family of macros
799 assertPprPanic file line msg
800 = panic (show (doc PprDebug))
802 doc = sep [hsep[text "ASSERT failed! file",
804 text "line", int line],
807 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
808 -- ^ Just warn about an assertion failure, recording the given file and line number.
809 -- Should typically be accessed with the WARN macros
810 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
811 warnPprTrace False _file _line _msg x = x
812 warnPprTrace True file line msg x
813 = trace (show (doc defaultDumpStyle)) x
815 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],