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