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, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
63 pprTrace, warnPprTrace,
64 trace, pgmError, panic, sorry, panicFastInt, assertPanic
67 import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
68 import {-# SOURCE #-} OccName( OccName )
73 import qualified Pretty
74 import Pretty ( Doc, Mode(..) )
78 import qualified Data.Map as M
79 import qualified Data.IntMap as IM
81 import System.IO ( Handle, stderr, stdout, hFlush )
82 import System.FilePath
85 #if __GLASGOW_HASKELL__ >= 701
86 import GHC.Show ( showMultiLineString )
88 showMultiLineString :: String -> [String]
90 showMultiLineString s = [ showList s "" ]
96 %************************************************************************
98 \subsection{The @PprStyle@ data type}
100 %************************************************************************
105 = PprUser PrintUnqualified Depth
106 -- Pretty-print in a way that will make sense to the
107 -- ordinary user; must be very close to Haskell
109 -- Assumes printing tidied code: non-system names are
110 -- printed without uniques.
113 -- Print code; either C or assembler
115 | PprDump -- For -ddump-foo; less verbose than PprDebug.
116 -- Does not assume tidied code: non-external names
117 -- are printed with uniques.
119 | PprDebug -- Full debugging output
121 data CodeStyle = CStyle -- The format of labels differs for C and assembler
124 data Depth = AllTheWay
125 | PartWay Int -- 0 => stop
128 -- -----------------------------------------------------------------------------
129 -- Printing original names
131 -- When printing code that contains original names, we need to map the
132 -- original names back to something the user understands. This is the
133 -- purpose of the pair of functions that gets passed around
134 -- when rendering 'SDoc'.
136 -- | given an /original/ name, this function tells you which module
137 -- name it should be qualified with when printing for the user, if
138 -- any. For example, given @Control.Exception.catch@, which is in scope
139 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
140 -- Note that the return value is a ModuleName, not a Module, because
141 -- in source code, names are qualified by ModuleNames.
142 type QueryQualifyName = Module -> OccName -> QualifyName
144 -- See Note [Printing original names] in HscTypes
145 data QualifyName -- given P:M.T
146 = NameUnqual -- refer to it as "T"
147 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
149 -- it is not in scope at all, but M.T is not bound in the current
150 -- scope, so we can refer to it as "M.T"
152 -- it is not in scope at all, and M.T is already bound in the
153 -- current scope, so we must refer to it as "P:M.T"
156 -- | For a given module, we need to know whether to print it with
157 -- a package name to disambiguate it.
158 type QueryQualifyModule = Module -> Bool
160 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
162 alwaysQualifyNames :: QueryQualifyName
163 alwaysQualifyNames m _ = NameQual (moduleName m)
165 neverQualifyNames :: QueryQualifyName
166 neverQualifyNames _ _ = NameUnqual
168 alwaysQualifyModules :: QueryQualifyModule
169 alwaysQualifyModules _ = True
171 neverQualifyModules :: QueryQualifyModule
172 neverQualifyModules _ = False
174 alwaysQualify, neverQualify :: PrintUnqualified
175 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
176 neverQualify = (neverQualifyNames, neverQualifyModules)
178 defaultUserStyle, defaultDumpStyle :: PprStyle
180 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
182 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
183 | otherwise = PprDump
185 -- | Style for printing error messages
186 mkErrStyle :: PrintUnqualified -> PprStyle
187 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
189 defaultErrStyle :: PprStyle
190 -- Default style for error messages
191 -- It's a bit of a hack because it doesn't take into account what's in scope
192 -- Only used for desugarer warnings, and typechecker errors in interface sigs
194 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
195 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
197 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
198 mkUserStyle unqual depth
199 | opt_PprStyle_Debug = PprDebug
200 | otherwise = PprUser unqual depth
202 cmdlineParserStyle :: PprStyle
203 cmdlineParserStyle = PprUser alwaysQualify AllTheWay
206 Orthogonal to the above printing styles are (possibly) some
207 command-line flags that affect printing (often carried with the
208 style). The most likely ones are variations on how much type info is
211 The following test decides whether or not we are actually generating
212 code (either C or assembly), or generating interface files.
214 %************************************************************************
216 \subsection{The @SDoc@ data type}
218 %************************************************************************
221 type SDoc = PprStyle -> Doc
223 withPprStyle :: PprStyle -> SDoc -> SDoc
224 withPprStyle sty d _sty' = d sty
226 withPprStyleDoc :: PprStyle -> SDoc -> Doc
227 withPprStyleDoc sty d = d sty
229 pprDeeper :: SDoc -> SDoc
230 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
231 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
232 pprDeeper d other_sty = d other_sty
234 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
235 -- Truncate a list that list that is longer than the current depth
236 pprDeeperList f ds (PprUser q (PartWay n))
237 | n==0 = Pretty.text "..."
238 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
241 go i (d:ds) | i >= n = [text "...."]
242 | otherwise = d : go (i+1) ds
244 pprDeeperList f ds other_sty
247 pprSetDepth :: Depth -> SDoc -> SDoc
248 pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
249 pprSetDepth _depth doc other_sty = doc other_sty
251 getPprStyle :: (PprStyle -> SDoc) -> SDoc
252 getPprStyle df sty = df sty sty
256 qualName :: PprStyle -> QueryQualifyName
257 qualName (PprUser (qual_name,_) _) m n = qual_name m n
258 qualName _other m _n = NameQual (moduleName m)
260 qualModule :: PprStyle -> QueryQualifyModule
261 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
262 qualModule _other _m = True
264 codeStyle :: PprStyle -> Bool
265 codeStyle (PprCode _) = True
268 asmStyle :: PprStyle -> Bool
269 asmStyle (PprCode AsmStyle) = True
270 asmStyle _other = False
272 dumpStyle :: PprStyle -> Bool
273 dumpStyle PprDump = True
274 dumpStyle _other = False
276 debugStyle :: PprStyle -> Bool
277 debugStyle PprDebug = True
278 debugStyle _other = False
280 userStyle :: PprStyle -> Bool
281 userStyle (PprUser _ _) = True
282 userStyle _other = False
284 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
285 ifPprDebug d sty@PprDebug = d sty
286 ifPprDebug _ _ = Pretty.empty
291 printSDoc :: SDoc -> PprStyle -> IO ()
293 Pretty.printDoc PageMode stdout (d sty)
296 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
297 -- above is better or worse than the put-big-string approach here
298 printErrs :: Doc -> IO ()
299 printErrs doc = do Pretty.printDoc PageMode stderr doc
302 printOutput :: Doc -> IO ()
303 printOutput doc = Pretty.printDoc PageMode stdout doc
305 printDump :: SDoc -> IO ()
306 printDump doc = hPrintDump stdout doc
308 hPrintDump :: Handle -> SDoc -> IO ()
309 hPrintDump h doc = do
310 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
313 better_doc = doc $$ blankLine
315 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
316 printForUser handle unqual doc
317 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
319 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
320 printForUserPartWay handle d unqual doc
321 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
323 -- printForC, printForAsm do what they sound like
324 printForC :: Handle -> SDoc -> IO ()
325 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
327 printForAsm :: Handle -> SDoc -> IO ()
328 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
330 pprCode :: CodeStyle -> SDoc -> SDoc
331 pprCode cs d = withPprStyle (PprCode cs) d
333 mkCodeStyle :: CodeStyle -> PprStyle
334 mkCodeStyle = PprCode
336 -- Can't make SDoc an instance of Show because SDoc is just a function type
337 -- However, Doc *is* an instance of Show
338 -- showSDoc just blasts it out as a string
339 showSDoc :: SDoc -> String
340 showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
342 -- This shows an SDoc, but on one line only. It's cheaper than a full
343 -- showSDoc, designed for when we're getting results like "Foo.bar"
344 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
345 showSDocOneLine :: SDoc -> String
346 showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
348 showSDocForUser :: PrintUnqualified -> SDoc -> String
349 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
351 showSDocUnqual :: SDoc -> String
352 -- Only used in the gruesome isOperator
353 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
355 showsPrecSDoc :: Int -> SDoc -> ShowS
356 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
358 showSDocDump :: SDoc -> String
359 showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
361 showSDocDumpOneLine :: SDoc -> String
362 showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
364 showSDocDebug :: SDoc -> String
365 showSDocDebug d = show (d PprDebug)
367 showPpr :: Outputable a => a -> String
368 showPpr = showSDoc . ppr
372 docToSDoc :: Doc -> SDoc
373 docToSDoc d = \_ -> d
377 text :: String -> SDoc
378 ftext :: FastString -> SDoc
379 ptext :: LitString -> SDoc
381 integer :: Integer -> SDoc
382 float :: Float -> SDoc
383 double :: Double -> SDoc
384 rational :: Rational -> SDoc
386 empty _sty = Pretty.empty
387 char c _sty = Pretty.char c
388 text s _sty = Pretty.text s
389 ftext s _sty = Pretty.ftext s
390 ptext s _sty = Pretty.ptext s
391 int n _sty = Pretty.int n
392 integer n _sty = Pretty.integer n
393 float n _sty = Pretty.float n
394 double n _sty = Pretty.double n
395 rational n _sty = Pretty.rational n
397 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
399 parens d sty = Pretty.parens (d sty)
400 braces d sty = Pretty.braces (d sty)
401 brackets d sty = Pretty.brackets (d sty)
402 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
403 angleBrackets d = char '<' <> d <> char '>'
405 cparen :: Bool -> SDoc -> SDoc
407 cparen b d sty = Pretty.cparen b (d sty)
409 -- quotes encloses something in single quotes...
410 -- but it omits them if the thing ends in a single quote
411 -- so that we don't get `foo''. Instead we just have foo'.
412 quotes d sty = case show pp_d of
414 _other -> Pretty.quotes pp_d
418 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
419 darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
421 blankLine _sty = Pretty.ptext (sLit "")
422 dcolon _sty = Pretty.ptext (sLit "::")
423 arrow _sty = Pretty.ptext (sLit "->")
424 darrow _sty = Pretty.ptext (sLit "=>")
425 semi _sty = Pretty.semi
426 comma _sty = Pretty.comma
427 colon _sty = Pretty.colon
428 equals _sty = Pretty.equals
429 space _sty = Pretty.space
430 underscore = char '_'
432 lparen _sty = Pretty.lparen
433 rparen _sty = Pretty.rparen
434 lbrack _sty = Pretty.lbrack
435 rbrack _sty = Pretty.rbrack
436 lbrace _sty = Pretty.lbrace
437 rbrace _sty = Pretty.rbrace
439 nest :: Int -> SDoc -> SDoc
440 -- ^ Indent 'SDoc' some specified amount
441 (<>) :: SDoc -> SDoc -> SDoc
442 -- ^ Join two 'SDoc' together horizontally without a gap
443 (<+>) :: SDoc -> SDoc -> SDoc
444 -- ^ Join two 'SDoc' together horizontally with a gap between them
445 ($$) :: SDoc -> SDoc -> SDoc
446 -- ^ Join two 'SDoc' together vertically; if there is
447 -- no vertical overlap it "dovetails" the two onto one line
448 ($+$) :: SDoc -> SDoc -> SDoc
449 -- ^ Join two 'SDoc' together vertically
451 nest n d sty = Pretty.nest n (d sty)
452 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
453 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
454 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
455 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
457 hcat :: [SDoc] -> SDoc
458 -- ^ Concatenate 'SDoc' horizontally
459 hsep :: [SDoc] -> SDoc
460 -- ^ Concatenate 'SDoc' horizontally with a space between each one
461 vcat :: [SDoc] -> SDoc
462 -- ^ Concatenate 'SDoc' vertically with dovetailing
463 sep :: [SDoc] -> SDoc
464 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
465 cat :: [SDoc] -> SDoc
466 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
467 fsep :: [SDoc] -> SDoc
468 -- ^ A paragraph-fill combinator. It's much like sep, only it
469 -- keeps fitting things on one line until it can't fit any more.
470 fcat :: [SDoc] -> SDoc
471 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
474 hcat ds sty = Pretty.hcat [d sty | d <- ds]
475 hsep ds sty = Pretty.hsep [d sty | d <- ds]
476 vcat ds sty = Pretty.vcat [d sty | d <- ds]
477 sep ds sty = Pretty.sep [d sty | d <- ds]
478 cat ds sty = Pretty.cat [d sty | d <- ds]
479 fsep ds sty = Pretty.fsep [d sty | d <- ds]
480 fcat ds sty = Pretty.fcat [d sty | d <- ds]
482 hang :: SDoc -- ^ The header
483 -> Int -- ^ Amount to indent the hung body
484 -> SDoc -- ^ The hung body, indented and placed below the header
486 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
488 punctuate :: SDoc -- ^ The punctuation
489 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
490 -> [SDoc] -- ^ Punctuated list
492 punctuate p (d:ds) = go d ds
495 go d (e:es) = (d <> p) : go e es
497 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
498 ppWhen True doc = doc
499 ppWhen False _ = empty
501 ppUnless True _ = empty
502 ppUnless False doc = doc
506 %************************************************************************
508 \subsection[Outputable-class]{The @Outputable@ class}
510 %************************************************************************
513 -- | Class designating that some type has an 'SDoc' representation
514 class Outputable a where
519 instance Outputable Bool where
520 ppr True = ptext (sLit "True")
521 ppr False = ptext (sLit "False")
523 instance Outputable Int where
526 instance Outputable Word16 where
527 ppr n = integer $ fromIntegral n
529 instance Outputable Word32 where
530 ppr n = integer $ fromIntegral n
532 instance Outputable Word where
533 ppr n = integer $ fromIntegral n
535 instance Outputable () where
538 instance (Outputable a) => Outputable [a] where
539 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
541 instance (Outputable a, Outputable b) => Outputable (a, b) where
542 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
544 instance Outputable a => Outputable (Maybe a) where
545 ppr Nothing = ptext (sLit "Nothing")
546 ppr (Just x) = ptext (sLit "Just") <+> ppr x
548 instance (Outputable a, Outputable b) => Outputable (Either a b) where
549 ppr (Left x) = ptext (sLit "Left") <+> ppr x
550 ppr (Right y) = ptext (sLit "Right") <+> ppr y
552 -- ToDo: may not be used
553 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
555 parens (sep [ppr x <> comma,
559 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
560 Outputable (a, b, c, d) where
562 parens (sep [ppr a <> comma,
567 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
568 Outputable (a, b, c, d, e) where
570 parens (sep [ppr a <> comma,
576 instance Outputable FastString where
577 ppr fs = ftext fs -- Prints an unadorned string,
578 -- no double quotes or anything
580 instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
581 ppr m = ppr (M.toList m)
582 instance (Outputable elt) => Outputable (IM.IntMap elt) where
583 ppr m = ppr (IM.toList m)
586 %************************************************************************
588 \subsection{The @OutputableBndr@ class}
590 %************************************************************************
593 -- | 'BindingSite' is used to tell the thing that prints binder what
594 -- language construct is binding the identifier. This can be used
595 -- to decide how much info to print.
596 data BindingSite = LambdaBind | CaseBind | LetBind
598 -- | When we print a binder, we often want to print its type too.
599 -- The @OutputableBndr@ class encapsulates this idea.
600 class Outputable a => OutputableBndr a where
601 pprBndr :: BindingSite -> a -> SDoc
605 %************************************************************************
607 \subsection{Random printing helpers}
609 %************************************************************************
612 -- We have 31-bit Chars and will simply use Show instances of Char and String.
614 -- | Special combinator for showing character literals.
615 pprHsChar :: Char -> SDoc
616 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
617 | otherwise = text (show c)
619 -- | Special combinator for showing string literals.
620 pprHsString :: FastString -> SDoc
621 pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
623 ---------------------
624 -- Put a name in parens if it's an operator
625 pprPrefixVar :: Bool -> SDoc -> SDoc
626 pprPrefixVar is_operator pp_v
627 | is_operator = parens pp_v
630 -- Put a name in backquotes if it's not an operator
631 pprInfixVar :: Bool -> SDoc -> SDoc
632 pprInfixVar is_operator pp_v
634 | otherwise = char '`' <> pp_v <> char '`'
636 ---------------------
637 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
638 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
639 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
640 -- which none of the HsSyn printing functions do
641 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
642 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
644 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
647 isOperator :: SDoc -> Bool
649 = case showSDocUnqual ppr_v of
650 ('(':_) -> False -- (), (,) etc
651 ('[':_) -> False -- []
652 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
653 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
654 ('_':_) -> False -- Not an operator
655 (c:_) -> not (isAlpha c) -- Starts with non-alpha
658 pprFastFilePath :: FastString -> SDoc
659 pprFastFilePath path = text $ normalise $ unpackFS path
662 %************************************************************************
664 \subsection{Other helper functions}
666 %************************************************************************
669 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
670 -> [a] -- ^ The things to be pretty printed
671 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
672 -- comma-separated and finally packed into a paragraph.
673 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
675 -- | Returns the seperated concatenation of the pretty printed things.
676 interppSP :: Outputable a => [a] -> SDoc
677 interppSP xs = sep (map ppr xs)
679 -- | Returns the comma-seperated concatenation of the pretty printed things.
680 interpp'SP :: Outputable a => [a] -> SDoc
681 interpp'SP xs = sep (punctuate comma (map ppr xs))
683 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
685 -- > [x,y,z] ==> `x', `y', `z'
686 pprQuotedList :: Outputable a => [a] -> SDoc
687 pprQuotedList = quotedList . map ppr
689 quotedList :: [SDoc] -> SDoc
690 quotedList xs = hsep (punctuate comma (map quotes xs))
692 quotedListWithOr :: [SDoc] -> SDoc
693 -- [x,y,z] ==> `x', `y' or `z'
694 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
695 quotedListWithOr xs = quotedList xs
699 %************************************************************************
701 \subsection{Printing numbers verbally}
703 %************************************************************************
706 -- | Converts an integer to a verbal index:
708 -- > speakNth 1 = text "first"
709 -- > speakNth 5 = text "fifth"
710 -- > speakNth 21 = text "21st"
711 speakNth :: Int -> SDoc
712 speakNth 1 = ptext (sLit "first")
713 speakNth 2 = ptext (sLit "second")
714 speakNth 3 = ptext (sLit "third")
715 speakNth 4 = ptext (sLit "fourth")
716 speakNth 5 = ptext (sLit "fifth")
717 speakNth 6 = ptext (sLit "sixth")
718 speakNth n = hcat [ int n, text suffix ]
720 suffix | n <= 20 = "th" -- 11,12,13 are non-std
721 | last_dig == 1 = "st"
722 | last_dig == 2 = "nd"
723 | last_dig == 3 = "rd"
726 last_dig = n `rem` 10
728 -- | Converts an integer to a verbal multiplicity:
730 -- > speakN 0 = text "none"
731 -- > speakN 5 = text "five"
732 -- > speakN 10 = text "10"
733 speakN :: Int -> SDoc
734 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
735 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
736 speakN 2 = ptext (sLit "two")
737 speakN 3 = ptext (sLit "three")
738 speakN 4 = ptext (sLit "four")
739 speakN 5 = ptext (sLit "five")
740 speakN 6 = ptext (sLit "six")
743 -- | Converts an integer and object description to a statement about the
744 -- multiplicity of those objects:
746 -- > speakNOf 0 (text "melon") = text "no melons"
747 -- > speakNOf 1 (text "melon") = text "one melon"
748 -- > speakNOf 3 (text "melon") = text "three melons"
749 speakNOf :: Int -> SDoc -> SDoc
750 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
751 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
752 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
754 -- | Converts a strictly positive integer into a number of times:
756 -- > speakNTimes 1 = text "once"
757 -- > speakNTimes 2 = text "twice"
758 -- > speakNTimes 4 = text "4 times"
759 speakNTimes :: Int {- >=1 -} -> SDoc
760 speakNTimes t | t == 1 = ptext (sLit "once")
761 | t == 2 = ptext (sLit "twice")
762 | otherwise = speakN t <+> ptext (sLit "times")
764 -- | Determines the pluralisation suffix appropriate for the length of a list:
766 -- > plural [] = char 's'
767 -- > plural ["Hello"] = empty
768 -- > plural ["Hello", "World"] = char 's'
769 plural :: [a] -> SDoc
770 plural [_] = empty -- a bit frightening, but there you are
775 %************************************************************************
777 \subsection{Error handling}
779 %************************************************************************
783 pprPanic :: String -> SDoc -> a
784 -- ^ Throw an exception saying "bug in GHC"
785 pprPanic = pprAndThen panic
787 pprSorry :: String -> SDoc -> a
788 -- ^ Throw an exceptio saying "this isn't finished yet"
789 pprSorry = pprAndThen sorry
792 pprPgmError :: String -> SDoc -> a
793 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
794 pprPgmError = pprAndThen pgmError
797 pprTrace :: String -> SDoc -> a -> a
798 -- ^ If debug output is on, show some 'SDoc' on the screen
800 | opt_NoDebugOutput = x
801 | otherwise = pprAndThen trace str doc x
804 pprPanicFastInt :: String -> SDoc -> FastInt
805 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
806 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
808 doc = text heading <+> pretty_msg
811 pprAndThen :: (String -> a) -> String -> SDoc -> a
812 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
814 doc = sep [text heading, nest 4 pretty_msg]
816 assertPprPanic :: String -> Int -> SDoc -> a
817 -- ^ Panic with an assertation failure, recording the given file and line number.
818 -- Should typically be accessed with the ASSERT family of macros
819 assertPprPanic file line msg
820 = panic (show (doc PprDebug))
822 doc = sep [hsep[text "ASSERT failed! file",
824 text "line", int line],
827 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
828 -- ^ Just warn about an assertion failure, recording the given file and line number.
829 -- Should typically be accessed with the WARN macros
830 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
831 warnPprTrace False _file _line _msg x = x
832 warnPprTrace True file line msg x
833 = trace (show (doc defaultDumpStyle)) x
835 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],