2 % (c) The University of Glasgow 2006
3 % (c) The GRASP Project, Glasgow University, 1992-1998
7 -- | This module defines classes and functions for pretty-printing. It also
8 -- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
10 -- The interface to this module is very similar to the standard Hughes-PJ pretty printing
11 -- module, except that it exports a number of additional functions that are rarely used,
12 -- and works over the 'SDoc' type.
15 Outputable(..), OutputableBndr(..),
17 -- * Pretty printing combinators
20 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
24 int, integer, float, double, rational,
25 parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
26 semi, comma, colon, dcolon, space, equals, dot, arrow,
27 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
28 (<>), (<+>), hcat, hsep,
33 speakNth, speakNTimes, speakN, speakNOf, plural,
35 -- * Converting 'SDoc' into strings and outputing it
36 printSDoc, printErrs, hPrintDump, printDump,
37 printForC, printForAsm, printForUser, printForUserPartWay,
39 showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
40 showSDocUnqual, showsPrecSDoc,
42 pprInfixVar, pprPrefixVar,
43 pprHsChar, pprHsString, pprHsInfix, pprHsVar,
46 -- * Controlling the style in which output is printed
49 PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
51 getPprStyle, withPprStyle, withPprStyleDoc,
52 pprDeeper, pprDeeperList, pprSetDepth,
53 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
54 ifPprDebug, qualName, qualModule,
55 mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
56 mkUserStyle, Depth(..),
58 -- * Error handling and debugging utilities
59 pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
60 pprTrace, warnPprTrace,
61 trace, pgmError, panic, panicFastInt, assertPanic
64 import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
65 import {-# SOURCE #-} OccName( OccName )
70 import qualified Pretty
71 import Pretty ( Doc, Mode(..) )
72 import Char ( isAlpha )
75 import Data.Word ( Word32 )
76 import System.IO ( Handle, stderr, stdout, hFlush )
77 import Data.Char ( ord )
78 import System.FilePath
82 %************************************************************************
84 \subsection{The @PprStyle@ data type}
86 %************************************************************************
91 = PprUser PrintUnqualified Depth
92 -- Pretty-print in a way that will make sense to the
93 -- ordinary user; must be very close to Haskell
95 -- Assumes printing tidied code: non-system names are
96 -- printed without uniques.
99 -- Print code; either C or assembler
101 | PprDump -- For -ddump-foo; less verbose than PprDebug.
102 -- Does not assume tidied code: non-external names
103 -- are printed with uniques.
105 | PprDebug -- Full debugging output
107 data CodeStyle = CStyle -- The format of labels differs for C and assembler
110 data Depth = AllTheWay
111 | PartWay Int -- 0 => stop
114 -- -----------------------------------------------------------------------------
115 -- Printing original names
117 -- When printing code that contains original names, we need to map the
118 -- original names back to something the user understands. This is the
119 -- purpose of the pair of functions that gets passed around
120 -- when rendering 'SDoc'.
122 -- | given an /original/ name, this function tells you which module
123 -- name it should be qualified with when printing for the user, if
124 -- any. For example, given @Control.Exception.catch@, which is in scope
125 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
126 -- Note that the return value is a ModuleName, not a Module, because
127 -- in source code, names are qualified by ModuleNames.
128 type QueryQualifyName = Module -> OccName -> QualifyName
130 data QualifyName -- given P:M.T
131 = NameUnqual -- refer to it as "T"
132 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
134 -- it is not in scope at all, but M.T is not bound in the current
135 -- scope, so we can refer to it as "M.T"
137 -- it is not in scope at all, and M.T is already bound in the
138 -- current scope, so we must refer to it as "P:M.T"
141 -- | For a given module, we need to know whether to print it with
142 -- a package name to disambiguate it.
143 type QueryQualifyModule = Module -> Bool
145 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
147 alwaysQualifyNames :: QueryQualifyName
148 alwaysQualifyNames m _ = NameQual (moduleName m)
150 neverQualifyNames :: QueryQualifyName
151 neverQualifyNames _ _ = NameUnqual
153 alwaysQualifyModules :: QueryQualifyModule
154 alwaysQualifyModules _ = True
156 neverQualifyModules :: QueryQualifyModule
157 neverQualifyModules _ = False
159 alwaysQualify, neverQualify :: PrintUnqualified
160 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
161 neverQualify = (neverQualifyNames, neverQualifyModules)
163 defaultUserStyle, defaultDumpStyle :: PprStyle
165 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
167 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
168 | otherwise = PprDump
170 -- | Style for printing error messages
171 mkErrStyle :: PrintUnqualified -> PprStyle
172 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
174 defaultErrStyle :: PprStyle
175 -- Default style for error messages
176 -- It's a bit of a hack because it doesn't take into account what's in scope
177 -- Only used for desugarer warnings, and typechecker errors in interface sigs
179 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
180 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
182 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
183 mkUserStyle unqual depth
184 | opt_PprStyle_Debug = PprDebug
185 | otherwise = PprUser unqual depth
188 Orthogonal to the above printing styles are (possibly) some
189 command-line flags that affect printing (often carried with the
190 style). The most likely ones are variations on how much type info is
193 The following test decides whether or not we are actually generating
194 code (either C or assembly), or generating interface files.
196 %************************************************************************
198 \subsection{The @SDoc@ data type}
200 %************************************************************************
203 type SDoc = PprStyle -> Doc
205 withPprStyle :: PprStyle -> SDoc -> SDoc
206 withPprStyle sty d _sty' = d sty
208 withPprStyleDoc :: PprStyle -> SDoc -> Doc
209 withPprStyleDoc sty d = d sty
211 pprDeeper :: SDoc -> SDoc
212 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
213 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
214 pprDeeper d other_sty = d other_sty
216 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
217 -- Truncate a list that list that is longer than the current depth
218 pprDeeperList f ds (PprUser q (PartWay n))
219 | n==0 = Pretty.text "..."
220 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
223 go i (d:ds) | i >= n = [text "...."]
224 | otherwise = d : go (i+1) ds
226 pprDeeperList f ds other_sty
229 pprSetDepth :: Int -> SDoc -> SDoc
230 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
231 pprSetDepth _n d other_sty = d other_sty
233 getPprStyle :: (PprStyle -> SDoc) -> SDoc
234 getPprStyle df sty = df sty sty
238 qualName :: PprStyle -> QueryQualifyName
239 qualName (PprUser (qual_name,_) _) m n = qual_name m n
240 qualName _other m _n = NameQual (moduleName m)
242 qualModule :: PprStyle -> QueryQualifyModule
243 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
244 qualModule _other _m = True
246 codeStyle :: PprStyle -> Bool
247 codeStyle (PprCode _) = True
250 asmStyle :: PprStyle -> Bool
251 asmStyle (PprCode AsmStyle) = True
252 asmStyle _other = False
254 dumpStyle :: PprStyle -> Bool
255 dumpStyle PprDump = True
256 dumpStyle _other = False
258 debugStyle :: PprStyle -> Bool
259 debugStyle PprDebug = True
260 debugStyle _other = False
262 userStyle :: PprStyle -> Bool
263 userStyle (PprUser _ _) = True
264 userStyle _other = False
266 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
267 ifPprDebug d sty@PprDebug = d sty
268 ifPprDebug _ _ = Pretty.empty
273 printSDoc :: SDoc -> PprStyle -> IO ()
275 Pretty.printDoc PageMode stdout (d sty)
278 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
279 -- above is better or worse than the put-big-string approach here
280 printErrs :: Doc -> IO ()
281 printErrs doc = do Pretty.printDoc PageMode stderr doc
284 printDump :: SDoc -> IO ()
285 printDump doc = hPrintDump stdout doc
287 hPrintDump :: Handle -> SDoc -> IO ()
288 hPrintDump h doc = do
289 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
292 better_doc = doc $$ text ""
294 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
295 printForUser handle unqual doc
296 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
298 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
299 printForUserPartWay handle d unqual doc
300 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
302 -- printForC, printForAsm do what they sound like
303 printForC :: Handle -> SDoc -> IO ()
304 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
306 printForAsm :: Handle -> SDoc -> IO ()
307 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
309 pprCode :: CodeStyle -> SDoc -> SDoc
310 pprCode cs d = withPprStyle (PprCode cs) d
312 mkCodeStyle :: CodeStyle -> PprStyle
313 mkCodeStyle = PprCode
315 -- Can't make SDoc an instance of Show because SDoc is just a function type
316 -- However, Doc *is* an instance of Show
317 -- showSDoc just blasts it out as a string
318 showSDoc :: SDoc -> String
319 showSDoc d = show (d defaultUserStyle)
321 showSDocForUser :: PrintUnqualified -> SDoc -> String
322 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
324 showSDocUnqual :: SDoc -> String
325 -- Only used in the gruesome isOperator
326 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
328 showsPrecSDoc :: Int -> SDoc -> ShowS
329 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
331 showSDocDump :: SDoc -> String
332 showSDocDump d = show (d PprDump)
334 showSDocDebug :: SDoc -> String
335 showSDocDebug d = show (d PprDebug)
339 docToSDoc :: Doc -> SDoc
340 docToSDoc d = \_ -> d
344 text :: String -> SDoc
345 ftext :: FastString -> SDoc
346 ptext :: LitString -> SDoc
348 integer :: Integer -> SDoc
349 float :: Float -> SDoc
350 double :: Double -> SDoc
351 rational :: Rational -> SDoc
353 empty _sty = Pretty.empty
354 char c _sty = Pretty.char c
355 text s _sty = Pretty.text s
356 ftext s _sty = Pretty.ftext s
357 ptext s _sty = Pretty.ptext s
358 int n _sty = Pretty.int n
359 integer n _sty = Pretty.integer n
360 float n _sty = Pretty.float n
361 double n _sty = Pretty.double n
362 rational n _sty = Pretty.rational n
364 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
366 parens d sty = Pretty.parens (d sty)
367 braces d sty = Pretty.braces (d sty)
368 brackets d sty = Pretty.brackets (d sty)
369 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
370 angleBrackets d = char '<' <> d <> char '>'
372 cparen :: Bool -> SDoc -> SDoc
374 cparen b d sty = Pretty.cparen b (d sty)
376 -- quotes encloses something in single quotes...
377 -- but it omits them if the thing ends in a single quote
378 -- so that we don't get `foo''. Instead we just have foo'.
379 quotes d sty = case show pp_d of
381 _other -> Pretty.quotes pp_d
385 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
386 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
388 semi _sty = Pretty.semi
389 comma _sty = Pretty.comma
390 colon _sty = Pretty.colon
391 equals _sty = Pretty.equals
392 space _sty = Pretty.space
393 dcolon _sty = Pretty.ptext (sLit "::")
394 arrow _sty = Pretty.ptext (sLit "->")
395 underscore = char '_'
397 lparen _sty = Pretty.lparen
398 rparen _sty = Pretty.rparen
399 lbrack _sty = Pretty.lbrack
400 rbrack _sty = Pretty.rbrack
401 lbrace _sty = Pretty.lbrace
402 rbrace _sty = Pretty.rbrace
404 nest :: Int -> SDoc -> SDoc
405 -- ^ Indent 'SDoc' some specified amount
406 (<>) :: SDoc -> SDoc -> SDoc
407 -- ^ Join two 'SDoc' together horizontally without a gap
408 (<+>) :: SDoc -> SDoc -> SDoc
409 -- ^ Join two 'SDoc' together horizontally with a gap between them
410 ($$) :: SDoc -> SDoc -> SDoc
411 -- ^ Join two 'SDoc' together vertically; if there is
412 -- no vertical overlap it "dovetails" the two onto one line
413 ($+$) :: SDoc -> SDoc -> SDoc
414 -- ^ Join two 'SDoc' together vertically
416 nest n d sty = Pretty.nest n (d sty)
417 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
418 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
419 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
420 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
422 hcat :: [SDoc] -> SDoc
423 -- ^ Concatenate 'SDoc' horizontally
424 hsep :: [SDoc] -> SDoc
425 -- ^ Concatenate 'SDoc' horizontally with a space between each one
426 vcat :: [SDoc] -> SDoc
427 -- ^ Concatenate 'SDoc' vertically with dovetailing
428 sep :: [SDoc] -> SDoc
429 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
430 cat :: [SDoc] -> SDoc
431 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
432 fsep :: [SDoc] -> SDoc
433 -- ^ A paragraph-fill combinator. It's much like sep, only it
434 -- keeps fitting things on one line until it can't fit any more.
435 fcat :: [SDoc] -> SDoc
436 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
439 hcat ds sty = Pretty.hcat [d sty | d <- ds]
440 hsep ds sty = Pretty.hsep [d sty | d <- ds]
441 vcat ds sty = Pretty.vcat [d sty | d <- ds]
442 sep ds sty = Pretty.sep [d sty | d <- ds]
443 cat ds sty = Pretty.cat [d sty | d <- ds]
444 fsep ds sty = Pretty.fsep [d sty | d <- ds]
445 fcat ds sty = Pretty.fcat [d sty | d <- ds]
447 hang :: SDoc -- ^ The header
448 -> Int -- ^ Amount to indent the hung body
449 -> SDoc -- ^ The hung body, indented and placed below the header
451 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
453 punctuate :: SDoc -- ^ The punctuation
454 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
455 -> [SDoc] -- ^ Punctuated list
457 punctuate p (d:ds) = go d ds
460 go d (e:es) = (d <> p) : go e es
464 %************************************************************************
466 \subsection[Outputable-class]{The @Outputable@ class}
468 %************************************************************************
471 -- | Class designating that some type has an 'SDoc' representation
472 class Outputable a where
477 instance Outputable Bool where
478 ppr True = ptext (sLit "True")
479 ppr False = ptext (sLit "False")
481 instance Outputable Int where
484 instance Outputable Word32 where
485 ppr n = integer $ fromIntegral n
487 instance Outputable () where
490 instance (Outputable a) => Outputable [a] where
491 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
493 instance (Outputable a, Outputable b) => Outputable (a, b) where
494 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
496 instance Outputable a => Outputable (Maybe a) where
497 ppr Nothing = ptext (sLit "Nothing")
498 ppr (Just x) = ptext (sLit "Just") <+> ppr x
500 instance (Outputable a, Outputable b) => Outputable (Either a b) where
501 ppr (Left x) = ptext (sLit "Left") <+> ppr x
502 ppr (Right y) = ptext (sLit "Right") <+> ppr y
504 -- ToDo: may not be used
505 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
507 parens (sep [ppr x <> comma,
511 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
512 Outputable (a, b, c, d) where
514 parens (sep [ppr a <> comma,
519 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
520 Outputable (a, b, c, d, e) where
522 parens (sep [ppr a <> comma,
528 instance Outputable FastString where
529 ppr fs = ftext fs -- Prints an unadorned string,
530 -- no double quotes or anything
533 %************************************************************************
535 \subsection{The @OutputableBndr@ class}
537 %************************************************************************
540 -- | 'BindingSite' is used to tell the thing that prints binder what
541 -- language construct is binding the identifier. This can be used
542 -- to decide how much info to print.
543 data BindingSite = LambdaBind | CaseBind | LetBind
545 -- | When we print a binder, we often want to print its type too.
546 -- The @OutputableBndr@ class encapsulates this idea.
547 class Outputable a => OutputableBndr a where
548 pprBndr :: BindingSite -> a -> SDoc
552 %************************************************************************
554 \subsection{Random printing helpers}
556 %************************************************************************
559 -- We have 31-bit Chars and will simply use Show instances of Char and String.
561 -- | Special combinator for showing character literals.
562 pprHsChar :: Char -> SDoc
563 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
564 | otherwise = text (show c)
566 -- | Special combinator for showing string literals.
567 pprHsString :: FastString -> SDoc
568 pprHsString fs = text (show (unpackFS fs))
570 ---------------------
571 -- Put a name in parens if it's an operator
572 pprPrefixVar :: Bool -> SDoc -> SDoc
573 pprPrefixVar is_operator pp_v
574 | is_operator = parens pp_v
577 -- Put a name in backquotes if it's not an operator
578 pprInfixVar :: Bool -> SDoc -> SDoc
579 pprInfixVar is_operator pp_v
581 | otherwise = char '`' <> pp_v <> char '`'
583 ---------------------
584 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
585 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
586 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
587 -- which none of the HsSyn printing functions do
588 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
589 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
591 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
594 isOperator :: SDoc -> Bool
596 = case showSDocUnqual ppr_v of
597 ('(':_) -> False -- (), (,) etc
598 ('[':_) -> False -- []
599 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
600 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
601 ('_':_) -> False -- Not an operator
602 (c:_) -> not (isAlpha c) -- Starts with non-alpha
605 pprFastFilePath :: FastString -> SDoc
606 pprFastFilePath path = text $ normalise $ unpackFS path
609 %************************************************************************
611 \subsection{Other helper functions}
613 %************************************************************************
616 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
617 -> [a] -- ^ The things to be pretty printed
618 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
619 -- comma-separated and finally packed into a paragraph.
620 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
622 -- | Returns the seperated concatenation of the pretty printed things.
623 interppSP :: Outputable a => [a] -> SDoc
624 interppSP xs = sep (map ppr xs)
626 -- | Returns the comma-seperated concatenation of the pretty printed things.
627 interpp'SP :: Outputable a => [a] -> SDoc
628 interpp'SP xs = sep (punctuate comma (map ppr xs))
630 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
632 -- > [x,y,z] ==> `x', `y', `z'
633 pprQuotedList :: Outputable a => [a] -> SDoc
634 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
638 %************************************************************************
640 \subsection{Printing numbers verbally}
642 %************************************************************************
645 -- | Converts an integer to a verbal index:
647 -- > speakNth 1 = text "first"
648 -- > speakNth 5 = text "fifth"
649 -- > speakNth 21 = text "21st"
650 speakNth :: Int -> SDoc
651 speakNth 1 = ptext (sLit "first")
652 speakNth 2 = ptext (sLit "second")
653 speakNth 3 = ptext (sLit "third")
654 speakNth 4 = ptext (sLit "fourth")
655 speakNth 5 = ptext (sLit "fifth")
656 speakNth 6 = ptext (sLit "sixth")
657 speakNth n = hcat [ int n, text suffix ]
659 suffix | n <= 20 = "th" -- 11,12,13 are non-std
660 | last_dig == 1 = "st"
661 | last_dig == 2 = "nd"
662 | last_dig == 3 = "rd"
665 last_dig = n `rem` 10
667 -- | Converts an integer to a verbal multiplicity:
669 -- > speakN 0 = text "none"
670 -- > speakN 5 = text "five"
671 -- > speakN 10 = text "10"
672 speakN :: Int -> SDoc
673 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
674 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
675 speakN 2 = ptext (sLit "two")
676 speakN 3 = ptext (sLit "three")
677 speakN 4 = ptext (sLit "four")
678 speakN 5 = ptext (sLit "five")
679 speakN 6 = ptext (sLit "six")
682 -- | Converts an integer and object description to a statement about the
683 -- multiplicity of those objects:
685 -- > speakNOf 0 (text "melon") = text "no melons"
686 -- > speakNOf 1 (text "melon") = text "one melon"
687 -- > speakNOf 3 (text "melon") = text "three melons"
688 speakNOf :: Int -> SDoc -> SDoc
689 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
690 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
691 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
693 -- | Converts a strictly positive integer into a number of times:
695 -- > speakNTimes 1 = text "once"
696 -- > speakNTimes 2 = text "twice"
697 -- > speakNTimes 4 = text "4 times"
698 speakNTimes :: Int {- >=1 -} -> SDoc
699 speakNTimes t | t == 1 = ptext (sLit "once")
700 | t == 2 = ptext (sLit "twice")
701 | otherwise = speakN t <+> ptext (sLit "times")
703 -- | Determines the pluralisation suffix appropriate for the length of a list:
705 -- > plural [] = char 's'
706 -- > plural ["Hello"] = empty
707 -- > plural ["Hello", "World"] = char 's'
708 plural :: [a] -> SDoc
709 plural [_] = empty -- a bit frightening, but there you are
714 %************************************************************************
716 \subsection{Error handling}
718 %************************************************************************
721 pprPanic :: String -> SDoc -> a
722 -- ^ Throw an exception saying "bug in GHC"
723 pprPgmError :: String -> SDoc -> a
724 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
725 pprTrace :: String -> SDoc -> a -> a
726 -- ^ If debug output is on, show some 'SDoc' on the screen
728 pprPanic = pprAndThen panic
730 pprPgmError = pprAndThen pgmError
733 | opt_NoDebugOutput = x
734 | otherwise = pprAndThen trace str doc x
736 pprPanicFastInt :: String -> SDoc -> FastInt
737 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
738 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
740 doc = text heading <+> pretty_msg
742 pprAndThen :: (String -> a) -> String -> SDoc -> a
743 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
745 doc = sep [text heading, nest 4 pretty_msg]
747 assertPprPanic :: String -> Int -> SDoc -> a
748 -- ^ Panic with an assertation failure, recording the given file and line number.
749 -- Should typically be accessed with the ASSERT family of macros
750 assertPprPanic file line msg
751 = panic (show (doc PprDebug))
753 doc = sep [hsep[text "ASSERT failed! file",
755 text "line", int line],
758 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
759 -- ^ Just warn about an assertion failure, recording the given file and line number.
760 -- Should typically be accessed with the WARN macros
761 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
762 warnPprTrace False _file _line _msg x = x
763 warnPprTrace True file line msg x
764 = trace (show (doc PprDebug)) x
766 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],