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 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 darrow, 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 darrow _sty = Pretty.ptext (sLit "=>")
413 semi _sty = Pretty.semi
414 comma _sty = Pretty.comma
415 colon _sty = Pretty.colon
416 equals _sty = Pretty.equals
417 space _sty = Pretty.space
418 underscore = char '_'
420 lparen _sty = Pretty.lparen
421 rparen _sty = Pretty.rparen
422 lbrack _sty = Pretty.lbrack
423 rbrack _sty = Pretty.rbrack
424 lbrace _sty = Pretty.lbrace
425 rbrace _sty = Pretty.rbrace
427 nest :: Int -> SDoc -> SDoc
428 -- ^ Indent 'SDoc' some specified amount
429 (<>) :: SDoc -> SDoc -> SDoc
430 -- ^ Join two 'SDoc' together horizontally without a gap
431 (<+>) :: SDoc -> SDoc -> SDoc
432 -- ^ Join two 'SDoc' together horizontally with a gap between them
433 ($$) :: SDoc -> SDoc -> SDoc
434 -- ^ Join two 'SDoc' together vertically; if there is
435 -- no vertical overlap it "dovetails" the two onto one line
436 ($+$) :: SDoc -> SDoc -> SDoc
437 -- ^ Join two 'SDoc' together vertically
439 nest n d sty = Pretty.nest n (d 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)
443 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
445 hcat :: [SDoc] -> SDoc
446 -- ^ Concatenate 'SDoc' horizontally
447 hsep :: [SDoc] -> SDoc
448 -- ^ Concatenate 'SDoc' horizontally with a space between each one
449 vcat :: [SDoc] -> SDoc
450 -- ^ Concatenate 'SDoc' vertically with dovetailing
451 sep :: [SDoc] -> SDoc
452 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
453 cat :: [SDoc] -> SDoc
454 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
455 fsep :: [SDoc] -> SDoc
456 -- ^ A paragraph-fill combinator. It's much like sep, only it
457 -- keeps fitting things on one line until it can't fit any more.
458 fcat :: [SDoc] -> SDoc
459 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
462 hcat ds sty = Pretty.hcat [d sty | d <- ds]
463 hsep ds sty = Pretty.hsep [d sty | d <- ds]
464 vcat ds sty = Pretty.vcat [d sty | d <- ds]
465 sep ds sty = Pretty.sep [d sty | d <- ds]
466 cat ds sty = Pretty.cat [d sty | d <- ds]
467 fsep ds sty = Pretty.fsep [d sty | d <- ds]
468 fcat ds sty = Pretty.fcat [d sty | d <- ds]
470 hang :: SDoc -- ^ The header
471 -> Int -- ^ Amount to indent the hung body
472 -> SDoc -- ^ The hung body, indented and placed below the header
474 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
476 punctuate :: SDoc -- ^ The punctuation
477 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
478 -> [SDoc] -- ^ Punctuated list
480 punctuate p (d:ds) = go d ds
483 go d (e:es) = (d <> p) : go e es
485 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
486 ppWhen True doc = doc
487 ppWhen False _ = empty
489 ppUnless True _ = empty
490 ppUnless False doc = doc
494 %************************************************************************
496 \subsection[Outputable-class]{The @Outputable@ class}
498 %************************************************************************
501 -- | Class designating that some type has an 'SDoc' representation
502 class Outputable a where
507 instance Outputable Bool where
508 ppr True = ptext (sLit "True")
509 ppr False = ptext (sLit "False")
511 instance Outputable Int where
514 instance Outputable Word16 where
515 ppr n = integer $ fromIntegral n
517 instance Outputable Word32 where
518 ppr n = integer $ fromIntegral n
520 instance Outputable Word where
521 ppr n = integer $ fromIntegral n
523 instance Outputable () where
526 instance (Outputable a) => Outputable [a] where
527 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
529 instance (Outputable a, Outputable b) => Outputable (a, b) where
530 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
532 instance Outputable a => Outputable (Maybe a) where
533 ppr Nothing = ptext (sLit "Nothing")
534 ppr (Just x) = ptext (sLit "Just") <+> ppr x
536 instance (Outputable a, Outputable b) => Outputable (Either a b) where
537 ppr (Left x) = ptext (sLit "Left") <+> ppr x
538 ppr (Right y) = ptext (sLit "Right") <+> ppr y
540 -- ToDo: may not be used
541 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
543 parens (sep [ppr x <> comma,
547 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
548 Outputable (a, b, c, d) where
550 parens (sep [ppr a <> comma,
555 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
556 Outputable (a, b, c, d, e) where
558 parens (sep [ppr a <> comma,
564 instance Outputable FastString where
565 ppr fs = ftext fs -- Prints an unadorned string,
566 -- no double quotes or anything
569 %************************************************************************
571 \subsection{The @OutputableBndr@ class}
573 %************************************************************************
576 -- | 'BindingSite' is used to tell the thing that prints binder what
577 -- language construct is binding the identifier. This can be used
578 -- to decide how much info to print.
579 data BindingSite = LambdaBind | CaseBind | LetBind
581 -- | When we print a binder, we often want to print its type too.
582 -- The @OutputableBndr@ class encapsulates this idea.
583 class Outputable a => OutputableBndr a where
584 pprBndr :: BindingSite -> a -> SDoc
588 %************************************************************************
590 \subsection{Random printing helpers}
592 %************************************************************************
595 -- We have 31-bit Chars and will simply use Show instances of Char and String.
597 -- | Special combinator for showing character literals.
598 pprHsChar :: Char -> SDoc
599 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
600 | otherwise = text (show c)
602 -- | Special combinator for showing string literals.
603 pprHsString :: FastString -> SDoc
604 pprHsString fs = text (show (unpackFS fs))
606 ---------------------
607 -- Put a name in parens if it's an operator
608 pprPrefixVar :: Bool -> SDoc -> SDoc
609 pprPrefixVar is_operator pp_v
610 | is_operator = parens pp_v
613 -- Put a name in backquotes if it's not an operator
614 pprInfixVar :: Bool -> SDoc -> SDoc
615 pprInfixVar is_operator pp_v
617 | otherwise = char '`' <> pp_v <> char '`'
619 ---------------------
620 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
621 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
622 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
623 -- which none of the HsSyn printing functions do
624 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
625 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
627 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
630 isOperator :: SDoc -> Bool
632 = case showSDocUnqual ppr_v of
633 ('(':_) -> False -- (), (,) etc
634 ('[':_) -> False -- []
635 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
636 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
637 ('_':_) -> False -- Not an operator
638 (c:_) -> not (isAlpha c) -- Starts with non-alpha
641 pprFastFilePath :: FastString -> SDoc
642 pprFastFilePath path = text $ normalise $ unpackFS path
645 %************************************************************************
647 \subsection{Other helper functions}
649 %************************************************************************
652 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
653 -> [a] -- ^ The things to be pretty printed
654 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
655 -- comma-separated and finally packed into a paragraph.
656 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
658 -- | Returns the seperated concatenation of the pretty printed things.
659 interppSP :: Outputable a => [a] -> SDoc
660 interppSP xs = sep (map ppr xs)
662 -- | Returns the comma-seperated concatenation of the pretty printed things.
663 interpp'SP :: Outputable a => [a] -> SDoc
664 interpp'SP xs = sep (punctuate comma (map ppr xs))
666 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
668 -- > [x,y,z] ==> `x', `y', `z'
669 pprQuotedList :: Outputable a => [a] -> SDoc
670 pprQuotedList = quotedList . map ppr
672 quotedList :: [SDoc] -> SDoc
673 quotedList xs = hsep (punctuate comma (map quotes xs))
675 quotedListWithOr :: [SDoc] -> SDoc
676 -- [x,y,z] ==> `x', `y' or `z'
677 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
678 quotedListWithOr xs = quotedList xs
682 %************************************************************************
684 \subsection{Printing numbers verbally}
686 %************************************************************************
689 -- | Converts an integer to a verbal index:
691 -- > speakNth 1 = text "first"
692 -- > speakNth 5 = text "fifth"
693 -- > speakNth 21 = text "21st"
694 speakNth :: Int -> SDoc
695 speakNth 1 = ptext (sLit "first")
696 speakNth 2 = ptext (sLit "second")
697 speakNth 3 = ptext (sLit "third")
698 speakNth 4 = ptext (sLit "fourth")
699 speakNth 5 = ptext (sLit "fifth")
700 speakNth 6 = ptext (sLit "sixth")
701 speakNth n = hcat [ int n, text suffix ]
703 suffix | n <= 20 = "th" -- 11,12,13 are non-std
704 | last_dig == 1 = "st"
705 | last_dig == 2 = "nd"
706 | last_dig == 3 = "rd"
709 last_dig = n `rem` 10
711 -- | Converts an integer to a verbal multiplicity:
713 -- > speakN 0 = text "none"
714 -- > speakN 5 = text "five"
715 -- > speakN 10 = text "10"
716 speakN :: Int -> SDoc
717 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
718 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
719 speakN 2 = ptext (sLit "two")
720 speakN 3 = ptext (sLit "three")
721 speakN 4 = ptext (sLit "four")
722 speakN 5 = ptext (sLit "five")
723 speakN 6 = ptext (sLit "six")
726 -- | Converts an integer and object description to a statement about the
727 -- multiplicity of those objects:
729 -- > speakNOf 0 (text "melon") = text "no melons"
730 -- > speakNOf 1 (text "melon") = text "one melon"
731 -- > speakNOf 3 (text "melon") = text "three melons"
732 speakNOf :: Int -> SDoc -> SDoc
733 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
734 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
735 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
737 -- | Converts a strictly positive integer into a number of times:
739 -- > speakNTimes 1 = text "once"
740 -- > speakNTimes 2 = text "twice"
741 -- > speakNTimes 4 = text "4 times"
742 speakNTimes :: Int {- >=1 -} -> SDoc
743 speakNTimes t | t == 1 = ptext (sLit "once")
744 | t == 2 = ptext (sLit "twice")
745 | otherwise = speakN t <+> ptext (sLit "times")
747 -- | Determines the pluralisation suffix appropriate for the length of a list:
749 -- > plural [] = char 's'
750 -- > plural ["Hello"] = empty
751 -- > plural ["Hello", "World"] = char 's'
752 plural :: [a] -> SDoc
753 plural [_] = empty -- a bit frightening, but there you are
758 %************************************************************************
760 \subsection{Error handling}
762 %************************************************************************
765 pprPanic :: String -> SDoc -> a
766 -- ^ Throw an exception saying "bug in GHC"
767 pprPgmError :: String -> SDoc -> a
768 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
769 pprTrace :: String -> SDoc -> a -> a
770 -- ^ If debug output is on, show some 'SDoc' on the screen
772 pprPanic = pprAndThen panic
774 pprPgmError = pprAndThen pgmError
777 | opt_NoDebugOutput = x
778 | otherwise = pprAndThen trace str doc x
780 pprPanicFastInt :: String -> SDoc -> FastInt
781 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
782 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
784 doc = text heading <+> pretty_msg
786 pprAndThen :: (String -> a) -> String -> SDoc -> a
787 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
789 doc = sep [text heading, nest 4 pretty_msg]
791 assertPprPanic :: String -> Int -> SDoc -> a
792 -- ^ Panic with an assertation failure, recording the given file and line number.
793 -- Should typically be accessed with the ASSERT family of macros
794 assertPprPanic file line msg
795 = panic (show (doc PprDebug))
797 doc = sep [hsep[text "ASSERT failed! file",
799 text "line", int line],
802 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
803 -- ^ Just warn about an assertion failure, recording the given file and line number.
804 -- Should typically be accessed with the WARN macros
805 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
806 warnPprTrace False _file _line _msg x = x
807 warnPprTrace True file line msg x
808 = trace (show (doc defaultDumpStyle)) x
810 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],