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, 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 printDump :: SDoc -> IO ()
291 printDump doc = hPrintDump stdout doc
293 hPrintDump :: Handle -> SDoc -> IO ()
294 hPrintDump h doc = do
295 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
298 better_doc = doc $$ blankLine
300 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
301 printForUser handle unqual doc
302 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
304 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
305 printForUserPartWay handle d unqual doc
306 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
308 -- printForC, printForAsm do what they sound like
309 printForC :: Handle -> SDoc -> IO ()
310 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
312 printForAsm :: Handle -> SDoc -> IO ()
313 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
315 pprCode :: CodeStyle -> SDoc -> SDoc
316 pprCode cs d = withPprStyle (PprCode cs) d
318 mkCodeStyle :: CodeStyle -> PprStyle
319 mkCodeStyle = PprCode
321 -- Can't make SDoc an instance of Show because SDoc is just a function type
322 -- However, Doc *is* an instance of Show
323 -- showSDoc just blasts it out as a string
324 showSDoc :: SDoc -> String
325 showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
327 -- This shows an SDoc, but on one line only. It's cheaper than a full
328 -- showSDoc, designed for when we're getting results like "Foo.bar"
329 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
330 showSDocOneLine :: SDoc -> String
331 showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
333 showSDocForUser :: PrintUnqualified -> SDoc -> String
334 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
336 showSDocUnqual :: SDoc -> String
337 -- Only used in the gruesome isOperator
338 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
340 showsPrecSDoc :: Int -> SDoc -> ShowS
341 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
343 showSDocDump :: SDoc -> String
344 showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
346 showSDocDumpOneLine :: SDoc -> String
347 showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
349 showSDocDebug :: SDoc -> String
350 showSDocDebug d = show (d PprDebug)
352 showPpr :: Outputable a => a -> String
353 showPpr = showSDoc . ppr
357 docToSDoc :: Doc -> SDoc
358 docToSDoc d = \_ -> d
362 text :: String -> SDoc
363 ftext :: FastString -> SDoc
364 ptext :: LitString -> SDoc
366 integer :: Integer -> SDoc
367 float :: Float -> SDoc
368 double :: Double -> SDoc
369 rational :: Rational -> SDoc
371 empty _sty = Pretty.empty
372 char c _sty = Pretty.char c
373 text s _sty = Pretty.text s
374 ftext s _sty = Pretty.ftext s
375 ptext s _sty = Pretty.ptext s
376 int n _sty = Pretty.int n
377 integer n _sty = Pretty.integer n
378 float n _sty = Pretty.float n
379 double n _sty = Pretty.double n
380 rational n _sty = Pretty.rational n
382 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
384 parens d sty = Pretty.parens (d sty)
385 braces d sty = Pretty.braces (d sty)
386 brackets d sty = Pretty.brackets (d sty)
387 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
388 angleBrackets d = char '<' <> d <> char '>'
390 cparen :: Bool -> SDoc -> SDoc
392 cparen b d sty = Pretty.cparen b (d sty)
394 -- quotes encloses something in single quotes...
395 -- but it omits them if the thing ends in a single quote
396 -- so that we don't get `foo''. Instead we just have foo'.
397 quotes d sty = case show pp_d of
399 _other -> Pretty.quotes pp_d
403 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
404 lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
406 blankLine _sty = Pretty.ptext (sLit "")
407 dcolon _sty = Pretty.ptext (sLit "::")
408 arrow _sty = Pretty.ptext (sLit "->")
409 semi _sty = Pretty.semi
410 comma _sty = Pretty.comma
411 colon _sty = Pretty.colon
412 equals _sty = Pretty.equals
413 space _sty = Pretty.space
414 underscore = char '_'
416 lparen _sty = Pretty.lparen
417 rparen _sty = Pretty.rparen
418 lbrack _sty = Pretty.lbrack
419 rbrack _sty = Pretty.rbrack
420 lbrace _sty = Pretty.lbrace
421 rbrace _sty = Pretty.rbrace
423 nest :: Int -> SDoc -> SDoc
424 -- ^ Indent 'SDoc' some specified amount
425 (<>) :: SDoc -> SDoc -> SDoc
426 -- ^ Join two 'SDoc' together horizontally without a gap
427 (<+>) :: SDoc -> SDoc -> SDoc
428 -- ^ Join two 'SDoc' together horizontally with a gap between them
429 ($$) :: SDoc -> SDoc -> SDoc
430 -- ^ Join two 'SDoc' together vertically; if there is
431 -- no vertical overlap it "dovetails" the two onto one line
432 ($+$) :: SDoc -> SDoc -> SDoc
433 -- ^ Join two 'SDoc' together vertically
435 nest n d sty = Pretty.nest n (d sty)
436 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
437 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
438 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
439 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
441 hcat :: [SDoc] -> SDoc
442 -- ^ Concatenate 'SDoc' horizontally
443 hsep :: [SDoc] -> SDoc
444 -- ^ Concatenate 'SDoc' horizontally with a space between each one
445 vcat :: [SDoc] -> SDoc
446 -- ^ Concatenate 'SDoc' vertically with dovetailing
447 sep :: [SDoc] -> SDoc
448 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
449 cat :: [SDoc] -> SDoc
450 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
451 fsep :: [SDoc] -> SDoc
452 -- ^ A paragraph-fill combinator. It's much like sep, only it
453 -- keeps fitting things on one line until it can't fit any more.
454 fcat :: [SDoc] -> SDoc
455 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
458 hcat ds sty = Pretty.hcat [d sty | d <- ds]
459 hsep ds sty = Pretty.hsep [d sty | d <- ds]
460 vcat ds sty = Pretty.vcat [d sty | d <- ds]
461 sep ds sty = Pretty.sep [d sty | d <- ds]
462 cat ds sty = Pretty.cat [d sty | d <- ds]
463 fsep ds sty = Pretty.fsep [d sty | d <- ds]
464 fcat ds sty = Pretty.fcat [d sty | d <- ds]
466 hang :: SDoc -- ^ The header
467 -> Int -- ^ Amount to indent the hung body
468 -> SDoc -- ^ The hung body, indented and placed below the header
470 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
472 punctuate :: SDoc -- ^ The punctuation
473 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
474 -> [SDoc] -- ^ Punctuated list
476 punctuate p (d:ds) = go d ds
479 go d (e:es) = (d <> p) : go e es
481 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
482 ppWhen True doc = doc
483 ppWhen False _ = empty
485 ppUnless True _ = empty
486 ppUnless False doc = doc
490 %************************************************************************
492 \subsection[Outputable-class]{The @Outputable@ class}
494 %************************************************************************
497 -- | Class designating that some type has an 'SDoc' representation
498 class Outputable a where
503 instance Outputable Bool where
504 ppr True = ptext (sLit "True")
505 ppr False = ptext (sLit "False")
507 instance Outputable Int where
510 instance Outputable Word16 where
511 ppr n = integer $ fromIntegral n
513 instance Outputable Word32 where
514 ppr n = integer $ fromIntegral n
516 instance Outputable Word where
517 ppr n = integer $ fromIntegral n
519 instance Outputable () where
522 instance (Outputable a) => Outputable [a] where
523 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
525 instance (Outputable a, Outputable b) => Outputable (a, b) where
526 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
528 instance Outputable a => Outputable (Maybe a) where
529 ppr Nothing = ptext (sLit "Nothing")
530 ppr (Just x) = ptext (sLit "Just") <+> ppr x
532 instance (Outputable a, Outputable b) => Outputable (Either a b) where
533 ppr (Left x) = ptext (sLit "Left") <+> ppr x
534 ppr (Right y) = ptext (sLit "Right") <+> ppr y
536 -- ToDo: may not be used
537 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
539 parens (sep [ppr x <> comma,
543 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
544 Outputable (a, b, c, d) where
546 parens (sep [ppr a <> comma,
551 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
552 Outputable (a, b, c, d, e) where
554 parens (sep [ppr a <> comma,
560 instance Outputable FastString where
561 ppr fs = ftext fs -- Prints an unadorned string,
562 -- no double quotes or anything
565 %************************************************************************
567 \subsection{The @OutputableBndr@ class}
569 %************************************************************************
572 -- | 'BindingSite' is used to tell the thing that prints binder what
573 -- language construct is binding the identifier. This can be used
574 -- to decide how much info to print.
575 data BindingSite = LambdaBind | CaseBind | LetBind
577 -- | When we print a binder, we often want to print its type too.
578 -- The @OutputableBndr@ class encapsulates this idea.
579 class Outputable a => OutputableBndr a where
580 pprBndr :: BindingSite -> a -> SDoc
584 %************************************************************************
586 \subsection{Random printing helpers}
588 %************************************************************************
591 -- We have 31-bit Chars and will simply use Show instances of Char and String.
593 -- | Special combinator for showing character literals.
594 pprHsChar :: Char -> SDoc
595 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
596 | otherwise = text (show c)
598 -- | Special combinator for showing string literals.
599 pprHsString :: FastString -> SDoc
600 pprHsString fs = text (show (unpackFS fs))
602 ---------------------
603 -- Put a name in parens if it's an operator
604 pprPrefixVar :: Bool -> SDoc -> SDoc
605 pprPrefixVar is_operator pp_v
606 | is_operator = parens pp_v
609 -- Put a name in backquotes if it's not an operator
610 pprInfixVar :: Bool -> SDoc -> SDoc
611 pprInfixVar is_operator pp_v
613 | otherwise = char '`' <> pp_v <> char '`'
615 ---------------------
616 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
617 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
618 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
619 -- which none of the HsSyn printing functions do
620 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
621 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
623 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
626 isOperator :: SDoc -> Bool
628 = case showSDocUnqual ppr_v of
629 ('(':_) -> False -- (), (,) etc
630 ('[':_) -> False -- []
631 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
632 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
633 ('_':_) -> False -- Not an operator
634 (c:_) -> not (isAlpha c) -- Starts with non-alpha
637 pprFastFilePath :: FastString -> SDoc
638 pprFastFilePath path = text $ normalise $ unpackFS path
641 %************************************************************************
643 \subsection{Other helper functions}
645 %************************************************************************
648 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
649 -> [a] -- ^ The things to be pretty printed
650 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
651 -- comma-separated and finally packed into a paragraph.
652 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
654 -- | Returns the seperated concatenation of the pretty printed things.
655 interppSP :: Outputable a => [a] -> SDoc
656 interppSP xs = sep (map ppr xs)
658 -- | Returns the comma-seperated concatenation of the pretty printed things.
659 interpp'SP :: Outputable a => [a] -> SDoc
660 interpp'SP xs = sep (punctuate comma (map ppr xs))
662 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
664 -- > [x,y,z] ==> `x', `y', `z'
665 pprQuotedList :: Outputable a => [a] -> SDoc
666 pprQuotedList = quotedList . map ppr
668 quotedList :: [SDoc] -> SDoc
669 quotedList xs = hsep (punctuate comma (map quotes xs))
671 quotedListWithOr :: [SDoc] -> SDoc
672 -- [x,y,z] ==> `x', `y' or `z'
673 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
674 quotedListWithOr xs = quotedList xs
678 %************************************************************************
680 \subsection{Printing numbers verbally}
682 %************************************************************************
685 -- | Converts an integer to a verbal index:
687 -- > speakNth 1 = text "first"
688 -- > speakNth 5 = text "fifth"
689 -- > speakNth 21 = text "21st"
690 speakNth :: Int -> SDoc
691 speakNth 1 = ptext (sLit "first")
692 speakNth 2 = ptext (sLit "second")
693 speakNth 3 = ptext (sLit "third")
694 speakNth 4 = ptext (sLit "fourth")
695 speakNth 5 = ptext (sLit "fifth")
696 speakNth 6 = ptext (sLit "sixth")
697 speakNth n = hcat [ int n, text suffix ]
699 suffix | n <= 20 = "th" -- 11,12,13 are non-std
700 | last_dig == 1 = "st"
701 | last_dig == 2 = "nd"
702 | last_dig == 3 = "rd"
705 last_dig = n `rem` 10
707 -- | Converts an integer to a verbal multiplicity:
709 -- > speakN 0 = text "none"
710 -- > speakN 5 = text "five"
711 -- > speakN 10 = text "10"
712 speakN :: Int -> SDoc
713 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
714 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
715 speakN 2 = ptext (sLit "two")
716 speakN 3 = ptext (sLit "three")
717 speakN 4 = ptext (sLit "four")
718 speakN 5 = ptext (sLit "five")
719 speakN 6 = ptext (sLit "six")
722 -- | Converts an integer and object description to a statement about the
723 -- multiplicity of those objects:
725 -- > speakNOf 0 (text "melon") = text "no melons"
726 -- > speakNOf 1 (text "melon") = text "one melon"
727 -- > speakNOf 3 (text "melon") = text "three melons"
728 speakNOf :: Int -> SDoc -> SDoc
729 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
730 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
731 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
733 -- | Converts a strictly positive integer into a number of times:
735 -- > speakNTimes 1 = text "once"
736 -- > speakNTimes 2 = text "twice"
737 -- > speakNTimes 4 = text "4 times"
738 speakNTimes :: Int {- >=1 -} -> SDoc
739 speakNTimes t | t == 1 = ptext (sLit "once")
740 | t == 2 = ptext (sLit "twice")
741 | otherwise = speakN t <+> ptext (sLit "times")
743 -- | Determines the pluralisation suffix appropriate for the length of a list:
745 -- > plural [] = char 's'
746 -- > plural ["Hello"] = empty
747 -- > plural ["Hello", "World"] = char 's'
748 plural :: [a] -> SDoc
749 plural [_] = empty -- a bit frightening, but there you are
754 %************************************************************************
756 \subsection{Error handling}
758 %************************************************************************
761 pprPanic :: String -> SDoc -> a
762 -- ^ Throw an exception saying "bug in GHC"
763 pprPgmError :: String -> SDoc -> a
764 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
765 pprTrace :: String -> SDoc -> a -> a
766 -- ^ If debug output is on, show some 'SDoc' on the screen
768 pprPanic = pprAndThen panic
770 pprPgmError = pprAndThen pgmError
773 | opt_NoDebugOutput = x
774 | otherwise = pprAndThen trace str doc x
776 pprPanicFastInt :: String -> SDoc -> FastInt
777 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
778 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
780 doc = text heading <+> pretty_msg
782 pprAndThen :: (String -> a) -> String -> SDoc -> a
783 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
785 doc = sep [text heading, nest 4 pretty_msg]
787 assertPprPanic :: String -> Int -> SDoc -> a
788 -- ^ Panic with an assertation failure, recording the given file and line number.
789 -- Should typically be accessed with the ASSERT family of macros
790 assertPprPanic file line msg
791 = panic (show (doc PprDebug))
793 doc = sep [hsep[text "ASSERT failed! file",
795 text "line", int line],
798 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
799 -- ^ Just warn about an assertion failure, recording the given file and line number.
800 -- Should typically be accessed with the WARN macros
801 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
802 warnPprTrace False _file _line _msg x = x
803 warnPprTrace True file line msg x
804 = trace (show (doc defaultDumpStyle)) x
806 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],