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