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, neverQualify,
  16         QualifyName(..),
  17         getPprStyle, withPprStyle, withPprStyleDoc,
  18         pprDeeper, pprDeeperList, pprSetDepth,
  19         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
  20         ifPprDebug, qualName, qualModule,
  21         mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
  22         mkUserStyle,
  23
  24         SDoc,           -- Abstract
  25         docToSDoc,
  26         interppSP, interpp'SP, pprQuotedList, pprWithCommas,
  27         empty, nest,
  28         text, char, ftext, ptext,
  29         int, integer, float, double, rational,
  30         parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
  31         semi, comma, colon, dcolon, space, equals, dot, arrow,
  32         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
  33         (<>), (<+>), hcat, hsep,
  34         ($$), ($+$), vcat,
  35         sep, cat,
  36         fsep, fcat,
  37         hang, punctuate,
  38         speakNth, speakNTimes, speakN, speakNOf, plural,
  39
  40         printSDoc, printErrs, hPrintDump, printDump,
  41         printForC, printForAsm, printForUser, printForUserPartWay,
  42         pprCode, mkCodeStyle,
  43         showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
  44         showSDocUnqual, showsPrecSDoc,
  45         pprHsChar, pprHsString,
  46
  47         -- error handling
  48         pprPanic, assertPprPanic, pprPanic#, pprPgmError,
  49         pprTrace, warnPprTrace,
  50         trace, pgmError, panic, panic#, assertPanic
  51     ) where
  52
  53 #include "HsVersions.h"
  54
  55
  56 import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
  57 import {-# SOURCE #-}   OccName( OccName )
  58
  59 import StaticFlags      ( opt_PprStyle_Debug, opt_PprUserLength )
  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 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
 292 printForUserPartWay handle d unqual doc
 293   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
 294
 295 -- printForC, printForAsm do what they sound like
 296 printForC :: Handle -> SDoc -> IO ()
 297 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
 298
 299 printForAsm :: Handle -> SDoc -> IO ()
 300 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
 301
 302 pprCode :: CodeStyle -> SDoc -> SDoc
 303 pprCode cs d = withPprStyle (PprCode cs) d
 304
 305 mkCodeStyle :: CodeStyle -> PprStyle
 306 mkCodeStyle = PprCode
 307
 308 -- Can't make SDoc an instance of Show because SDoc is just a function type
 309 -- However, Doc *is* an instance of Show
 310 -- showSDoc just blasts it out as a string
 311 showSDoc :: SDoc -> String
 312 showSDoc d = show (d defaultUserStyle)
 313
 314 showSDocForUser :: PrintUnqualified -> SDoc -> String
 315 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
 316
 317 showSDocUnqual :: SDoc -> String
 318 -- Only used in the gruesome HsExpr.isOperator
 319 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 320
 321 showsPrecSDoc :: Int -> SDoc -> ShowS
 322 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 323
 324 showSDocDump :: SDoc -> String
 325 showSDocDump d = show (d PprDump)
 326
 327 showSDocDebug :: SDoc -> String
 328 showSDocDebug d = show (d PprDebug)
 329 \end{code}
 330
 331 \begin{code}
 332 docToSDoc :: Doc -> SDoc
 333 docToSDoc d = \_ -> d
 334
 335 empty    :: SDoc
 336 text     :: String     -> SDoc
 337 char     :: Char       -> SDoc
 338 ftext    :: FastString -> SDoc
 339 ptext    :: Ptr t      -> SDoc
 340 int      :: Int        -> SDoc
 341 integer  :: Integer    -> SDoc
 342 float    :: Float      -> SDoc
 343 double   :: Double     -> SDoc
 344 rational :: Rational   -> SDoc
 345
 346 empty _sty      = Pretty.empty
 347 text s _sty     = Pretty.text s
 348 char c _sty     = Pretty.char c
 349 ftext s _sty    = Pretty.ftext s
 350 ptext s _sty    = Pretty.ptext s
 351 int n _sty      = Pretty.int n
 352 integer n _sty  = Pretty.integer n
 353 float n _sty    = Pretty.float n
 354 double n _sty   = Pretty.double n
 355 rational n _sty = Pretty.rational n
 356
 357 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
 358
 359 parens d sty       = Pretty.parens (d sty)
 360 braces d sty       = Pretty.braces (d sty)
 361 brackets d sty     = Pretty.brackets (d sty)
 362 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 363 angleBrackets d    = char '<' <> d <> char '>'
 364
 365 cparen :: Bool -> SDoc -> SDoc
 366
 367 cparen b d sty       = Pretty.cparen b (d sty)
 368
 369 -- quotes encloses something in single quotes...
 370 -- but it omits them if the thing ends in a single quote
 371 -- so that we don't get `foo''.  Instead we just have foo'.
 372 quotes d sty = case show pp_d of
 373                  ('\'' : _) -> pp_d
 374                  _other     -> Pretty.quotes pp_d
 375              where
 376                pp_d = d sty
 377
 378 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
 379 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
 380
 381 semi _sty   = Pretty.semi
 382 comma _sty  = Pretty.comma
 383 colon _sty  = Pretty.colon
 384 equals _sty = Pretty.equals
 385 space _sty  = Pretty.space
 386 dcolon _sty = Pretty.ptext SLIT("::")
 387 arrow  _sty = Pretty.ptext SLIT("->")
 388 underscore  = char '_'
 389 dot         = char '.'
 390 lparen _sty = Pretty.lparen
 391 rparen _sty = Pretty.rparen
 392 lbrack _sty = Pretty.lbrack
 393 rbrack _sty = Pretty.rbrack
 394 lbrace _sty = Pretty.lbrace
 395 rbrace _sty = Pretty.rbrace
 396
 397 nest :: Int -> SDoc -> SDoc
 398 (<>), (<+>), ($$), ($+$) :: SDoc -> SDoc -> SDoc
 399
 400 nest n d sty    = Pretty.nest n (d sty)
 401 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 402 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 403 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 404 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 405
 406 hcat, hsep, vcat, sep, cat, fsep, fcat :: [SDoc] -> SDoc
 407
 408
 409 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 410 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 411 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 412 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 413 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 414 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 415 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 416
 417 hang :: SDoc -> Int -> SDoc -> SDoc
 418
 419 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 420
 421 punctuate :: SDoc -> [SDoc] -> [SDoc]
 422 punctuate _ []     = []
 423 punctuate p (d:ds) = go d ds
 424                    where
 425                      go d [] = [d]
 426                      go d (e:es) = (d <> p) : go e es
 427 \end{code}
 428
 429
 430 %************************************************************************
 431 %*                                                                      *
 432 \subsection[Outputable-class]{The @Outputable@ class}
 433 %*                                                                      *
 434 %************************************************************************
 435
 436 \begin{code}
 437 class Outputable a where
 438         ppr :: a -> SDoc
 439 \end{code}
 440
 441 \begin{code}
 442 instance Outputable Bool where
 443     ppr True  = ptext SLIT("True")
 444     ppr False = ptext SLIT("False")
 445
 446 instance Outputable Int where
 447    ppr n = int n
 448
 449 instance Outputable () where
 450    ppr _ = text "()"
 451
 452 instance (Outputable a) => Outputable [a] where
 453     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 454
 455 instance (Outputable a, Outputable b) => Outputable (a, b) where
 456     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 457
 458 instance Outputable a => Outputable (Maybe a) where
 459   ppr Nothing = ptext SLIT("Nothing")
 460   ppr (Just x) = ptext SLIT("Just") <+> ppr x
 461
 462 instance (Outputable a, Outputable b) => Outputable (Either a b) where
 463   ppr (Left x)  = ptext SLIT("Left")  <+> ppr x
 464   ppr (Right y) = ptext SLIT("Right") <+> ppr y
 465
 466 -- ToDo: may not be used
 467 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 468     ppr (x,y,z) =
 469       parens (sep [ppr x <> comma,
 470                    ppr y <> comma,
 471                    ppr z ])
 472
 473 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 474          Outputable (a, b, c, d) where
 475     ppr (x,y,z,w) =
 476       parens (sep [ppr x <> comma,
 477                    ppr y <> comma,
 478                    ppr z <> comma,
 479                    ppr w])
 480
 481 instance Outputable FastString where
 482     ppr fs = ftext fs           -- Prints an unadorned string,
 483                                 -- no double quotes or anything
 484 \end{code}
 485
 486
 487 %************************************************************************
 488 %*                                                                      *
 489 \subsection{The @OutputableBndr@ class}
 490 %*                                                                      *
 491 %************************************************************************
 492
 493 When we print a binder, we often want to print its type too.
 494 The @OutputableBndr@ class encapsulates this idea.
 495
 496 @BindingSite@ is used to tell the thing that prints binder what
 497 language construct is binding the identifier.  This can be used
 498 to decide how much info to print.
 499
 500 \begin{code}
 501 data BindingSite = LambdaBind | CaseBind | LetBind
 502
 503 class Outputable a => OutputableBndr a where
 504    pprBndr :: BindingSite -> a -> SDoc
 505    pprBndr _b x = ppr x
 506 \end{code}
 507
 508
 509
 510 %************************************************************************
 511 %*                                                                      *
 512 \subsection{Random printing helpers}
 513 %*                                                                      *
 514 %************************************************************************
 515
 516 \begin{code}
 517 -- We have 31-bit Chars and will simply use Show instances
 518 -- of Char and String.
 519
 520 pprHsChar :: Char -> SDoc
 521 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 522             | otherwise      = text (show c)
 523
 524 pprHsString :: FastString -> SDoc
 525 pprHsString fs = text (show (unpackFS fs))
 526 \end{code}
 527
 528
 529 %************************************************************************
 530 %*                                                                      *
 531 \subsection{Other helper functions}
 532 %*                                                                      *
 533 %************************************************************************
 534
 535 \begin{code}
 536 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 537 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 538
 539 interppSP  :: Outputable a => [a] -> SDoc
 540 interppSP  xs = sep (map ppr xs)
 541
 542 interpp'SP :: Outputable a => [a] -> SDoc
 543 interpp'SP xs = sep (punctuate comma (map ppr xs))
 544
 545 pprQuotedList :: Outputable a => [a] -> SDoc
 546 -- [x,y,z]  ==>  `x', `y', `z'
 547 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 548 \end{code}
 549
 550
 551 %************************************************************************
 552 %*                                                                      *
 553 \subsection{Printing numbers verbally}
 554 %*                                                                      *
 555 %************************************************************************
 556
 557 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 558 ``first'' etc.
 559
 560 \begin{code}
 561 speakNth :: Int -> SDoc
 562 speakNth 1 = ptext SLIT("first")
 563 speakNth 2 = ptext SLIT("second")
 564 speakNth 3 = ptext SLIT("third")
 565 speakNth 4 = ptext SLIT("fourth")
 566 speakNth 5 = ptext SLIT("fifth")
 567 speakNth 6 = ptext SLIT("sixth")
 568 speakNth n = hcat [ int n, text suffix ]
 569   where
 570     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 571            | last_dig == 1 = "st"
 572            | last_dig == 2 = "nd"
 573            | last_dig == 3 = "rd"
 574            | otherwise     = "th"
 575
 576     last_dig = n `rem` 10
 577
 578 speakN :: Int -> SDoc
 579 speakN 0 = ptext SLIT("none")   -- E.g.  "he has none"
 580 speakN 1 = ptext SLIT("one")    -- E.g.  "he has one"
 581 speakN 2 = ptext SLIT("two")
 582 speakN 3 = ptext SLIT("three")
 583 speakN 4 = ptext SLIT("four")
 584 speakN 5 = ptext SLIT("five")
 585 speakN 6 = ptext SLIT("six")
 586 speakN n = int n
 587
 588 speakNOf :: Int -> SDoc -> SDoc
 589 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's'       -- E.g. "no arguments"
 590 speakNOf 1 d = ptext SLIT("one") <+> d                  -- E.g. "one argument"
 591 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 592
 593 speakNTimes :: Int {- >=1 -} -> SDoc
 594 speakNTimes t | t == 1     = ptext SLIT("once")
 595               | t == 2     = ptext SLIT("twice")
 596               | otherwise  = speakN t <+> ptext SLIT("times")
 597
 598 plural :: [a] -> SDoc
 599 plural [_] = empty  -- a bit frightening, but there you are
 600 plural _   = char 's'
 601 \end{code}
 602
 603
 604 %************************************************************************
 605 %*                                                                      *
 606 \subsection{Error handling}
 607 %*                                                                      *
 608 %************************************************************************
 609
 610 \begin{code}
 611 pprPanic, pprPgmError :: String -> SDoc -> a
 612 pprTrace :: String -> SDoc -> a -> a
 613 pprPanic    = pprAndThen panic          -- Throw an exn saying "bug in GHC"
 614
 615 pprPgmError = pprAndThen pgmError       -- Throw an exn saying "bug in pgm being compiled"
 616                                         --      (used for unusual pgm errors)
 617 pprTrace    = pprAndThen trace
 618
 619 pprPanic# :: String -> SDoc -> FastInt
 620 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 621                              where
 622                                doc = text heading <+> pretty_msg
 623
 624 pprAndThen :: (String -> a) -> String -> SDoc -> a
 625 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 626     where
 627      doc = sep [text heading, nest 4 pretty_msg]
 628
 629 assertPprPanic :: String -> Int -> SDoc -> a
 630 assertPprPanic file line msg
 631   = panic (show (doc PprDebug))
 632   where
 633     doc = sep [hsep[text "ASSERT failed! file",
 634                            text file,
 635                            text "line", int line],
 636                     msg]
 637
 638 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 639 warnPprTrace False _file _line _msg x = x
 640 warnPprTrace True   file  line  msg x
 641   = trace (show (doc PprDebug)) x
 642   where
 643     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 644                msg]
 645 \end{code}