compiler/utils/Outputable.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP Project, Glasgow University, 1992-1998
   4 %
   5
   6 Outputable: defines classes for pretty-printing and forcing, both
   7 forms of ``output.''
   8
   9 \begin{code}
  10 module Outputable (
  11         Outputable(..), OutputableBndr(..),     -- Class
  12
  13         BindingSite(..),
  14
  15         PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, QualifyName(..),
  16         getPprStyle, withPprStyle, withPprStyleDoc,
  17         pprDeeper, pprDeeperList, pprSetDepth,
  18         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
  19         ifPprDebug, qualName, qualModule,
  20         mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
  21
  22         SDoc,           -- Abstract
  23         docToSDoc,
  24         interppSP, interpp'SP, pprQuotedList, pprWithCommas,
  25         empty, nest,
  26         text, char, ftext, ptext,
  27         int, integer, float, double, rational,
  28         parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
  29         semi, comma, colon, dcolon, space, equals, dot, arrow,
  30         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
  31         (<>), (<+>), hcat, hsep,
  32         ($$), ($+$), vcat,
  33         sep, cat,
  34         fsep, fcat,
  35         hang, punctuate,
  36         speakNth, speakNTimes, speakN, speakNOf, plural,
  37
  38         printSDoc, printErrs, hPrintDump, printDump,
  39         printForC, printForAsm, printForUser,
  40         pprCode, mkCodeStyle,
  41         showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
  42         showSDocUnqual, showsPrecSDoc,
  43         pprHsChar, pprHsString,
  44
  45         -- error handling
  46         pprPanic, assertPprPanic, pprPanic#, pprPgmError,
  47         pprTrace, warnPprTrace,
  48         trace, pgmError, panic, panic#, assertPanic
  49     ) where
  50
  51 #include "HsVersions.h"
  52
  53
  54 import {-# SOURCE #-}   Module( Module,
  55                                 ModuleName, moduleName )
  56 import {-# SOURCE #-}   OccName( OccName )
  57
  58 import StaticFlags      ( opt_PprStyle_Debug, opt_PprUserLength )
  59 import PackageConfig    ( PackageId, packageIdString )
  60 import FastString
  61 import FastTypes
  62 import GHC.Ptr
  63 import qualified Pretty
  64 import Pretty           ( Doc, Mode(..) )
  65 import Panic
  66
  67 import Data.Word        ( Word32 )
  68 import System.IO        ( Handle, stderr, stdout, hFlush )
  69 import Data.Char        ( ord )
  70 \end{code}
  71
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection{The @PprStyle@ data type}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 \begin{code}
  80
  81 data PprStyle
  82   = PprUser PrintUnqualified Depth
  83                 -- Pretty-print in a way that will make sense to the
  84                 -- ordinary user; must be very close to Haskell
  85                 -- syntax, etc.
  86                 -- Assumes printing tidied code: non-system names are
  87                 -- printed without uniques.
  88
  89   | PprCode CodeStyle
  90                 -- Print code; either C or assembler
  91
  92   | PprDump     -- For -ddump-foo; less verbose than PprDebug.
  93                 -- Does not assume tidied code: non-external names
  94                 -- are printed with uniques.
  95
  96   | PprDebug    -- Full debugging output
  97
  98 data CodeStyle = CStyle         -- The format of labels differs for C and assembler
  99                | AsmStyle
 100
 101 data Depth = AllTheWay
 102            | PartWay Int        -- 0 => stop
 103
 104
 105 -- -----------------------------------------------------------------------------
 106 -- Printing original names
 107
 108 -- When printing code that contains original names, we need to map the
 109 -- original names back to something the user understands.  This is the
 110 -- purpose of the pair of functions that gets passed around
 111 -- when rendering 'SDoc'.
 112
 113 -- | given an /original/ name, this function tells you which module
 114 -- name it should be qualified with when printing for the user, if
 115 -- any.  For example, given @Control.Exception.catch@, which is in scope
 116 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
 117 -- Note that the return value is a ModuleName, not a Module, because
 118 -- in source code, names are qualified by ModuleNames.
 119 type QueryQualifyName = Module -> OccName -> QualifyName
 120
 121 data QualifyName                        -- given P:M.T
 122         = NameUnqual                    -- refer to it as "T"
 123         | NameQual ModuleName           -- refer to it as "X.T" for the supplied X
 124         | NameNotInScope1
 125                 -- it is not in scope at all, but M.T is not bound in the current
 126                 -- scope, so we can refer to it as "M.T"
 127         | NameNotInScope2
 128                 -- it is not in scope at all, and M.T is already bound in the
 129                 -- current scope, so we must refer to it as "P:M.T"
 130
 131
 132 -- | For a given module, we need to know whether to print it with
 133 -- a package name to disambiguate it.
 134 type QueryQualifyModule = Module -> Bool
 135
 136 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
 137
 138 alwaysQualifyNames :: QueryQualifyName
 139 alwaysQualifyNames m _ = NameQual (moduleName m)
 140
 141 neverQualifyNames :: QueryQualifyName
 142 neverQualifyNames _ _ = NameUnqual
 143
 144 alwaysQualifyModules :: QueryQualifyModule
 145 alwaysQualifyModules _ = True
 146
 147 neverQualifyModules :: QueryQualifyModule
 148 neverQualifyModules _ = False
 149
 150 type QueryQualifies = (QueryQualifyName, QueryQualifyModule)
 151
 152 alwaysQualify, neverQualify :: QueryQualifies
 153 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
 154 neverQualify  = (neverQualifyNames,  neverQualifyModules)
 155
 156 defaultUserStyle, defaultDumpStyle :: PprStyle
 157
 158 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
 159
 160 defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
 161                  |  otherwise          = PprDump
 162
 163 -- | Style for printing error messages
 164 mkErrStyle :: PrintUnqualified -> PprStyle
 165 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
 166
 167 defaultErrStyle :: PprStyle
 168 -- Default style for error messages
 169 -- It's a bit of a hack because it doesn't take into account what's in scope
 170 -- Only used for desugarer warnings, and typechecker errors in interface sigs
 171 defaultErrStyle
 172   | opt_PprStyle_Debug   = mkUserStyle alwaysQualify AllTheWay
 173   | otherwise            = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
 174
 175 mkUserStyle :: QueryQualifies -> Depth -> PprStyle
 176 mkUserStyle unqual depth
 177    | opt_PprStyle_Debug = PprDebug
 178    | otherwise          = PprUser unqual depth
 179 \end{code}
 180
 181 Orthogonal to the above printing styles are (possibly) some
 182 command-line flags that affect printing (often carried with the
 183 style).  The most likely ones are variations on how much type info is
 184 shown.
 185
 186 The following test decides whether or not we are actually generating
 187 code (either C or assembly), or generating interface files.
 188
 189 %************************************************************************
 190 %*                                                                      *
 191 \subsection{The @SDoc@ data type}
 192 %*                                                                      *
 193 %************************************************************************
 194
 195 \begin{code}
 196 type SDoc = PprStyle -> Doc
 197
 198 withPprStyle :: PprStyle -> SDoc -> SDoc
 199 withPprStyle sty d _sty' = d sty
 200
 201 withPprStyleDoc :: PprStyle -> SDoc -> Doc
 202 withPprStyleDoc sty d = d sty
 203
 204 pprDeeper :: SDoc -> SDoc
 205 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
 206 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
 207 pprDeeper d other_sty               = d other_sty
 208
 209 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
 210 -- Truncate a list that list that is longer than the current depth
 211 pprDeeperList f ds (PprUser q (PartWay n))
 212   | n==0      = Pretty.text "..."
 213   | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
 214   where
 215     go _ [] = []
 216     go i (d:ds) | i >= n    = [text "...."]
 217                 | otherwise = d : go (i+1) ds
 218
 219 pprDeeperList f ds other_sty
 220   = f ds other_sty
 221
 222 pprSetDepth :: Int -> SDoc -> SDoc
 223 pprSetDepth  n d (PprUser q _) = d (PprUser q (PartWay n))
 224 pprSetDepth _n d other_sty     = d other_sty
 225
 226 getPprStyle :: (PprStyle -> SDoc) -> SDoc
 227 getPprStyle df sty = df sty sty
 228 \end{code}
 229
 230 \begin{code}
 231 qualName :: PprStyle -> QueryQualifyName
 232 qualName (PprUser (qual_name,_) _) m  n = qual_name m n
 233 qualName _other                    m _n = NameQual (moduleName m)
 234
 235 qualModule :: PprStyle -> QueryQualifyModule
 236 qualModule (PprUser (_,qual_mod) _)  m = qual_mod m
 237 qualModule _other                   _m = True
 238
 239 codeStyle :: PprStyle -> Bool
 240 codeStyle (PprCode _)     = True
 241 codeStyle _               = False
 242
 243 asmStyle :: PprStyle -> Bool
 244 asmStyle (PprCode AsmStyle)  = True
 245 asmStyle _other              = False
 246
 247 dumpStyle :: PprStyle -> Bool
 248 dumpStyle PprDump = True
 249 dumpStyle _other  = False
 250
 251 debugStyle :: PprStyle -> Bool
 252 debugStyle PprDebug       = True
 253 debugStyle _other         = False
 254
 255 userStyle ::  PprStyle -> Bool
 256 userStyle (PprUser _ _) = True
 257 userStyle _other        = False
 258
 259 ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
 260 ifPprDebug d sty@PprDebug = d sty
 261 ifPprDebug _ _            = Pretty.empty
 262 \end{code}
 263
 264 \begin{code}
 265 -- Unused [7/02 sof]
 266 printSDoc :: SDoc -> PprStyle -> IO ()
 267 printSDoc d sty = do
 268   Pretty.printDoc PageMode stdout (d sty)
 269   hFlush stdout
 270
 271 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
 272 -- above is better or worse than the put-big-string approach here
 273 printErrs :: Doc -> IO ()
 274 printErrs doc = do Pretty.printDoc PageMode stderr doc
 275                    hFlush stderr
 276
 277 printDump :: SDoc -> IO ()
 278 printDump doc = hPrintDump stdout doc
 279
 280 hPrintDump :: Handle -> SDoc -> IO ()
 281 hPrintDump h doc = do
 282    Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
 283    hFlush h
 284  where
 285    better_doc = doc $$ text ""
 286
 287 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 288 printForUser handle unqual doc
 289   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 290
 291 -- printForC, printForAsm do what they sound like
 292 printForC :: Handle -> SDoc -> IO ()
 293 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
 294
 295 printForAsm :: Handle -> SDoc -> IO ()
 296 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
 297
 298 pprCode :: CodeStyle -> SDoc -> SDoc
 299 pprCode cs d = withPprStyle (PprCode cs) d
 300
 301 mkCodeStyle :: CodeStyle -> PprStyle
 302 mkCodeStyle = PprCode
 303
 304 -- Can't make SDoc an instance of Show because SDoc is just a function type
 305 -- However, Doc *is* an instance of Show
 306 -- showSDoc just blasts it out as a string
 307 showSDoc :: SDoc -> String
 308 showSDoc d = show (d defaultUserStyle)
 309
 310 showSDocForUser :: PrintUnqualified -> SDoc -> String
 311 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
 312
 313 showSDocUnqual :: SDoc -> String
 314 -- Only used in the gruesome HsExpr.isOperator
 315 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 316
 317 showsPrecSDoc :: Int -> SDoc -> ShowS
 318 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 319
 320 showSDocDump :: SDoc -> String
 321 showSDocDump d = show (d PprDump)
 322
 323 showSDocDebug :: SDoc -> String
 324 showSDocDebug d = show (d PprDebug)
 325 \end{code}
 326
 327 \begin{code}
 328 docToSDoc :: Doc -> SDoc
 329 docToSDoc d = \_ -> d
 330
 331 empty    :: SDoc
 332 text     :: String     -> SDoc
 333 char     :: Char       -> SDoc
 334 ftext    :: FastString -> SDoc
 335 ptext    :: Ptr t      -> SDoc
 336 int      :: Int        -> SDoc
 337 integer  :: Integer    -> SDoc
 338 float    :: Float      -> SDoc
 339 double   :: Double     -> SDoc
 340 rational :: Rational   -> SDoc
 341
 342 empty _sty      = Pretty.empty
 343 text s _sty     = Pretty.text s
 344 char c _sty     = Pretty.char c
 345 ftext s _sty    = Pretty.ftext s
 346 ptext s _sty    = Pretty.ptext s
 347 int n _sty      = Pretty.int n
 348 integer n _sty  = Pretty.integer n
 349 float n _sty    = Pretty.float n
 350 double n _sty   = Pretty.double n
 351 rational n _sty = Pretty.rational n
 352
 353 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
 354
 355 parens d sty       = Pretty.parens (d sty)
 356 braces d sty       = Pretty.braces (d sty)
 357 brackets d sty     = Pretty.brackets (d sty)
 358 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 359 angleBrackets d    = char '<' <> d <> char '>'
 360
 361 cparen :: Bool -> SDoc -> SDoc
 362
 363 cparen b d sty       = Pretty.cparen b (d sty)
 364
 365 -- quotes encloses something in single quotes...
 366 -- but it omits them if the thing ends in a single quote
 367 -- so that we don't get `foo''.  Instead we just have foo'.
 368 quotes d sty = case show pp_d of
 369                  ('\'' : _) -> pp_d
 370                  _other     -> Pretty.quotes pp_d
 371              where
 372                pp_d = d sty
 373
 374 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
 375 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
 376
 377 semi _sty   = Pretty.semi
 378 comma _sty  = Pretty.comma
 379 colon _sty  = Pretty.colon
 380 equals _sty = Pretty.equals
 381 space _sty  = Pretty.space
 382 dcolon _sty = Pretty.ptext SLIT("::")
 383 arrow  _sty = Pretty.ptext SLIT("->")
 384 underscore  = char '_'
 385 dot         = char '.'
 386 lparen _sty = Pretty.lparen
 387 rparen _sty = Pretty.rparen
 388 lbrack _sty = Pretty.lbrack
 389 rbrack _sty = Pretty.rbrack
 390 lbrace _sty = Pretty.lbrace
 391 rbrace _sty = Pretty.rbrace
 392
 393 nest :: Int -> SDoc -> SDoc
 394 (<>), (<+>), ($$), ($+$) :: SDoc -> SDoc -> SDoc
 395
 396 nest n d sty    = Pretty.nest n (d sty)
 397 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 398 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 399 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 400 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 401
 402 hcat, hsep, vcat, sep, cat, fsep, fcat :: [SDoc] -> SDoc
 403
 404
 405 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 406 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 407 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 408 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 409 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 410 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 411 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 412
 413 hang :: SDoc -> Int -> SDoc -> SDoc
 414
 415 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 416
 417 punctuate :: SDoc -> [SDoc] -> [SDoc]
 418 punctuate _ []     = []
 419 punctuate p (d:ds) = go d ds
 420                    where
 421                      go d [] = [d]
 422                      go d (e:es) = (d <> p) : go e es
 423 \end{code}
 424
 425
 426 %************************************************************************
 427 %*                                                                      *
 428 \subsection[Outputable-class]{The @Outputable@ class}
 429 %*                                                                      *
 430 %************************************************************************
 431
 432 \begin{code}
 433 class Outputable a where
 434         ppr :: a -> SDoc
 435 \end{code}
 436
 437 \begin{code}
 438 instance Outputable Bool where
 439     ppr True  = ptext SLIT("True")
 440     ppr False = ptext SLIT("False")
 441
 442 instance Outputable Int where
 443    ppr n = int n
 444
 445 instance Outputable () where
 446    ppr _ = text "()"
 447
 448 instance (Outputable a) => Outputable [a] where
 449     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 450
 451 instance (Outputable a, Outputable b) => Outputable (a, b) where
 452     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 453
 454 instance Outputable a => Outputable (Maybe a) where
 455   ppr Nothing = ptext SLIT("Nothing")
 456   ppr (Just x) = ptext SLIT("Just") <+> ppr x
 457
 458 instance (Outputable a, Outputable b) => Outputable (Either a b) where
 459   ppr (Left x)  = ptext SLIT("Left")  <+> ppr x
 460   ppr (Right y) = ptext SLIT("Right") <+> ppr y
 461
 462 -- ToDo: may not be used
 463 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 464     ppr (x,y,z) =
 465       parens (sep [ppr x <> comma,
 466                    ppr y <> comma,
 467                    ppr z ])
 468
 469 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 470          Outputable (a, b, c, d) where
 471     ppr (x,y,z,w) =
 472       parens (sep [ppr x <> comma,
 473                    ppr y <> comma,
 474                    ppr z <> comma,
 475                    ppr w])
 476
 477 instance Outputable FastString where
 478     ppr fs = ftext fs           -- Prints an unadorned string,
 479                                 -- no double quotes or anything
 480
 481 instance Outputable PackageId where
 482    ppr pid = text (packageIdString pid)
 483 \end{code}
 484
 485
 486 %************************************************************************
 487 %*                                                                      *
 488 \subsection{The @OutputableBndr@ class}
 489 %*                                                                      *
 490 %************************************************************************
 491
 492 When we print a binder, we often want to print its type too.
 493 The @OutputableBndr@ class encapsulates this idea.
 494
 495 @BindingSite@ is used to tell the thing that prints binder what
 496 language construct is binding the identifier.  This can be used
 497 to decide how much info to print.
 498
 499 \begin{code}
 500 data BindingSite = LambdaBind | CaseBind | LetBind
 501
 502 class Outputable a => OutputableBndr a where
 503    pprBndr :: BindingSite -> a -> SDoc
 504    pprBndr _b x = ppr x
 505 \end{code}
 506
 507
 508
 509 %************************************************************************
 510 %*                                                                      *
 511 \subsection{Random printing helpers}
 512 %*                                                                      *
 513 %************************************************************************
 514
 515 \begin{code}
 516 -- We have 31-bit Chars and will simply use Show instances
 517 -- of Char and String.
 518
 519 pprHsChar :: Char -> SDoc
 520 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 521             | otherwise      = text (show c)
 522
 523 pprHsString :: FastString -> SDoc
 524 pprHsString fs = text (show (unpackFS fs))
 525 \end{code}
 526
 527
 528 %************************************************************************
 529 %*                                                                      *
 530 \subsection{Other helper functions}
 531 %*                                                                      *
 532 %************************************************************************
 533
 534 \begin{code}
 535 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 536 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 537
 538 interppSP  :: Outputable a => [a] -> SDoc
 539 interppSP  xs = sep (map ppr xs)
 540
 541 interpp'SP :: Outputable a => [a] -> SDoc
 542 interpp'SP xs = sep (punctuate comma (map ppr xs))
 543
 544 pprQuotedList :: Outputable a => [a] -> SDoc
 545 -- [x,y,z]  ==>  `x', `y', `z'
 546 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 547 \end{code}
 548
 549
 550 %************************************************************************
 551 %*                                                                      *
 552 \subsection{Printing numbers verbally}
 553 %*                                                                      *
 554 %************************************************************************
 555
 556 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 557 ``first'' etc.
 558
 559 \begin{code}
 560 speakNth :: Int -> SDoc
 561 speakNth 1 = ptext SLIT("first")
 562 speakNth 2 = ptext SLIT("second")
 563 speakNth 3 = ptext SLIT("third")
 564 speakNth 4 = ptext SLIT("fourth")
 565 speakNth 5 = ptext SLIT("fifth")
 566 speakNth 6 = ptext SLIT("sixth")
 567 speakNth n = hcat [ int n, text suffix ]
 568   where
 569     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 570            | last_dig == 1 = "st"
 571            | last_dig == 2 = "nd"
 572            | last_dig == 3 = "rd"
 573            | otherwise     = "th"
 574
 575     last_dig = n `rem` 10
 576
 577 speakN :: Int -> SDoc
 578 speakN 0 = ptext SLIT("none")   -- E.g.  "he has none"
 579 speakN 1 = ptext SLIT("one")    -- E.g.  "he has one"
 580 speakN 2 = ptext SLIT("two")
 581 speakN 3 = ptext SLIT("three")
 582 speakN 4 = ptext SLIT("four")
 583 speakN 5 = ptext SLIT("five")
 584 speakN 6 = ptext SLIT("six")
 585 speakN n = int n
 586
 587 speakNOf :: Int -> SDoc -> SDoc
 588 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's'       -- E.g. "no arguments"
 589 speakNOf 1 d = ptext SLIT("one") <+> d                  -- E.g. "one argument"
 590 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 591
 592 speakNTimes :: Int {- >=1 -} -> SDoc
 593 speakNTimes t | t == 1     = ptext SLIT("once")
 594               | t == 2     = ptext SLIT("twice")
 595               | otherwise  = speakN t <+> ptext SLIT("times")
 596
 597 plural :: [a] -> SDoc
 598 plural [_] = empty  -- a bit frightening, but there you are
 599 plural _   = char 's'
 600 \end{code}
 601
 602
 603 %************************************************************************
 604 %*                                                                      *
 605 \subsection{Error handling}
 606 %*                                                                      *
 607 %************************************************************************
 608
 609 \begin{code}
 610 pprPanic, pprPgmError :: String -> SDoc -> a
 611 pprTrace :: String -> SDoc -> a -> a
 612 pprPanic    = pprAndThen panic          -- Throw an exn saying "bug in GHC"
 613
 614 pprPgmError = pprAndThen pgmError       -- Throw an exn saying "bug in pgm being compiled"
 615                                         --      (used for unusual pgm errors)
 616 pprTrace    = pprAndThen trace
 617
 618 pprPanic# :: String -> SDoc -> FastInt
 619 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 620                              where
 621                                doc = text heading <+> pretty_msg
 622
 623 pprAndThen :: (String -> a) -> String -> SDoc -> a
 624 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 625     where
 626      doc = sep [text heading, nest 4 pretty_msg]
 627
 628 assertPprPanic :: String -> Int -> SDoc -> a
 629 assertPprPanic file line msg
 630   = panic (show (doc PprDebug))
 631   where
 632     doc = sep [hsep[text "ASSERT failed! file",
 633                            text file,
 634                            text "line", int line],
 635                     msg]
 636
 637 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 638 warnPprTrace False _file _line _msg x = x
 639 warnPprTrace True   file  line  msg x
 640   = trace (show (doc PprDebug)) x
 641   where
 642     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 643                msg]
 644 \end{code}