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 (a,b,c,d) =
 476       parens (sep [ppr a <> comma,
 477                    ppr b <> comma,
 478                    ppr c <> comma,
 479                    ppr d])
 480
 481 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
 482          Outputable (a, b, c, d, e) where
 483     ppr (a,b,c,d,e) =
 484       parens (sep [ppr a <> comma,
 485                    ppr b <> comma,
 486                    ppr c <> comma,
 487                    ppr d <> comma,
 488                    ppr e])
 489
 490 instance Outputable FastString where
 491     ppr fs = ftext fs           -- Prints an unadorned string,
 492                                 -- no double quotes or anything
 493 \end{code}
 494
 495
 496 %************************************************************************
 497 %*                                                                      *
 498 \subsection{The @OutputableBndr@ class}
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 When we print a binder, we often want to print its type too.
 503 The @OutputableBndr@ class encapsulates this idea.
 504
 505 @BindingSite@ is used to tell the thing that prints binder what
 506 language construct is binding the identifier.  This can be used
 507 to decide how much info to print.
 508
 509 \begin{code}
 510 data BindingSite = LambdaBind | CaseBind | LetBind
 511
 512 class Outputable a => OutputableBndr a where
 513    pprBndr :: BindingSite -> a -> SDoc
 514    pprBndr _b x = ppr x
 515 \end{code}
 516
 517
 518
 519 %************************************************************************
 520 %*                                                                      *
 521 \subsection{Random printing helpers}
 522 %*                                                                      *
 523 %************************************************************************
 524
 525 \begin{code}
 526 -- We have 31-bit Chars and will simply use Show instances
 527 -- of Char and String.
 528
 529 pprHsChar :: Char -> SDoc
 530 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 531             | otherwise      = text (show c)
 532
 533 pprHsString :: FastString -> SDoc
 534 pprHsString fs = text (show (unpackFS fs))
 535 \end{code}
 536
 537
 538 %************************************************************************
 539 %*                                                                      *
 540 \subsection{Other helper functions}
 541 %*                                                                      *
 542 %************************************************************************
 543
 544 \begin{code}
 545 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 546 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 547
 548 interppSP  :: Outputable a => [a] -> SDoc
 549 interppSP  xs = sep (map ppr xs)
 550
 551 interpp'SP :: Outputable a => [a] -> SDoc
 552 interpp'SP xs = sep (punctuate comma (map ppr xs))
 553
 554 pprQuotedList :: Outputable a => [a] -> SDoc
 555 -- [x,y,z]  ==>  `x', `y', `z'
 556 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 557 \end{code}
 558
 559
 560 %************************************************************************
 561 %*                                                                      *
 562 \subsection{Printing numbers verbally}
 563 %*                                                                      *
 564 %************************************************************************
 565
 566 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 567 ``first'' etc.
 568
 569 \begin{code}
 570 speakNth :: Int -> SDoc
 571 speakNth 1 = ptext SLIT("first")
 572 speakNth 2 = ptext SLIT("second")
 573 speakNth 3 = ptext SLIT("third")
 574 speakNth 4 = ptext SLIT("fourth")
 575 speakNth 5 = ptext SLIT("fifth")
 576 speakNth 6 = ptext SLIT("sixth")
 577 speakNth n = hcat [ int n, text suffix ]
 578   where
 579     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 580            | last_dig == 1 = "st"
 581            | last_dig == 2 = "nd"
 582            | last_dig == 3 = "rd"
 583            | otherwise     = "th"
 584
 585     last_dig = n `rem` 10
 586
 587 speakN :: Int -> SDoc
 588 speakN 0 = ptext SLIT("none")   -- E.g.  "he has none"
 589 speakN 1 = ptext SLIT("one")    -- E.g.  "he has one"
 590 speakN 2 = ptext SLIT("two")
 591 speakN 3 = ptext SLIT("three")
 592 speakN 4 = ptext SLIT("four")
 593 speakN 5 = ptext SLIT("five")
 594 speakN 6 = ptext SLIT("six")
 595 speakN n = int n
 596
 597 speakNOf :: Int -> SDoc -> SDoc
 598 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's'       -- E.g. "no arguments"
 599 speakNOf 1 d = ptext SLIT("one") <+> d                  -- E.g. "one argument"
 600 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 601
 602 speakNTimes :: Int {- >=1 -} -> SDoc
 603 speakNTimes t | t == 1     = ptext SLIT("once")
 604               | t == 2     = ptext SLIT("twice")
 605               | otherwise  = speakN t <+> ptext SLIT("times")
 606
 607 plural :: [a] -> SDoc
 608 plural [_] = empty  -- a bit frightening, but there you are
 609 plural _   = char 's'
 610 \end{code}
 611
 612
 613 %************************************************************************
 614 %*                                                                      *
 615 \subsection{Error handling}
 616 %*                                                                      *
 617 %************************************************************************
 618
 619 \begin{code}
 620 pprPanic, pprPgmError :: String -> SDoc -> a
 621 pprTrace :: String -> SDoc -> a -> a
 622 pprPanic    = pprAndThen panic          -- Throw an exn saying "bug in GHC"
 623
 624 pprPgmError = pprAndThen pgmError       -- Throw an exn saying "bug in pgm being compiled"
 625                                         --      (used for unusual pgm errors)
 626 pprTrace    = pprAndThen trace
 627
 628 pprPanic# :: String -> SDoc -> FastInt
 629 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 630                              where
 631                                doc = text heading <+> pretty_msg
 632
 633 pprAndThen :: (String -> a) -> String -> SDoc -> a
 634 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 635     where
 636      doc = sep [text heading, nest 4 pretty_msg]
 637
 638 assertPprPanic :: String -> Int -> SDoc -> a
 639 assertPprPanic file line msg
 640   = panic (show (doc PprDebug))
 641   where
 642     doc = sep [hsep[text "ASSERT failed! file",
 643                            text file,
 644                            text "line", int line],
 645                     msg]
 646
 647 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 648 warnPprTrace False _file _line _msg x = x
 649 warnPprTrace True   file  line  msg x
 650   = trace (show (doc PprDebug)) x
 651   where
 652     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 653                msg]
 654 \end{code}