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
  46         pprInfixVar, pprPrefixVar,
  47         pprHsChar, pprHsString, pprHsInfix, pprHsVar,
  48
  49         -- error handling
  50         pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
  51         pprTrace, warnPprTrace,
  52         trace, pgmError, panic, panicFastInt, assertPanic
  53     ) where
  54
  55 import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
  56 import {-# SOURCE #-}   OccName( OccName )
  57
  58 import StaticFlags
  59 import FastString
  60 import FastTypes
  61 import qualified Pretty
  62 import Pretty           ( Doc, Mode(..) )
  63 import Char             ( isAlpha )
  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 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 of Char and String.
 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
 536 ---------------------
 537 -- Put a name in parens if it's an operator
 538 pprPrefixVar :: Bool -> SDoc -> SDoc
 539 pprPrefixVar is_operator pp_v
 540   | is_operator = parens pp_v
 541   | otherwise   = pp_v
 542
 543 -- Put a name in backquotes if it's not an operator
 544 pprInfixVar :: Bool -> SDoc -> SDoc
 545 pprInfixVar is_operator pp_v
 546   | is_operator = pp_v
 547   | otherwise   = char '`' <> pp_v <> char '`'
 548
 549 ---------------------
 550 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
 551 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
 552 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
 553 --         which none of the HsSyn printing functions do
 554 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
 555 pprHsVar   v = pprPrefixVar (isOperator pp_v) pp_v
 556              where pp_v = ppr v
 557 pprHsInfix v = pprInfixVar  (isOperator pp_v) pp_v
 558              where pp_v = ppr v
 559
 560 isOperator :: SDoc -> Bool
 561 isOperator ppr_v
 562   = case showSDocUnqual ppr_v of
 563         ('(':_)   -> False              -- (), (,) etc
 564         ('[':_)   -> False              -- []
 565         ('$':c:_) -> not (isAlpha c)    -- Don't treat $d as an operator
 566         (':':c:_) -> not (isAlpha c)    -- Don't treat :T as an operator
 567         ('_':_)   -> False              -- Not an operator
 568         (c:_)     -> not (isAlpha c)    -- Starts with non-alpha
 569         _         -> False
 570 \end{code}
 571
 572
 573 %************************************************************************
 574 %*                                                                      *
 575 \subsection{Other helper functions}
 576 %*                                                                      *
 577 %************************************************************************
 578
 579 \begin{code}
 580 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 581 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 582
 583 interppSP  :: Outputable a => [a] -> SDoc
 584 interppSP  xs = sep (map ppr xs)
 585
 586 interpp'SP :: Outputable a => [a] -> SDoc
 587 interpp'SP xs = sep (punctuate comma (map ppr xs))
 588
 589 pprQuotedList :: Outputable a => [a] -> SDoc
 590 -- [x,y,z]  ==>  `x', `y', `z'
 591 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 592 \end{code}
 593
 594
 595 %************************************************************************
 596 %*                                                                      *
 597 \subsection{Printing numbers verbally}
 598 %*                                                                      *
 599 %************************************************************************
 600
 601 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 602 ``first'' etc.
 603
 604 \begin{code}
 605 speakNth :: Int -> SDoc
 606 speakNth 1 = ptext (sLit "first")
 607 speakNth 2 = ptext (sLit "second")
 608 speakNth 3 = ptext (sLit "third")
 609 speakNth 4 = ptext (sLit "fourth")
 610 speakNth 5 = ptext (sLit "fifth")
 611 speakNth 6 = ptext (sLit "sixth")
 612 speakNth n = hcat [ int n, text suffix ]
 613   where
 614     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 615            | last_dig == 1 = "st"
 616            | last_dig == 2 = "nd"
 617            | last_dig == 3 = "rd"
 618            | otherwise     = "th"
 619
 620     last_dig = n `rem` 10
 621
 622 speakN :: Int -> SDoc
 623 speakN 0 = ptext (sLit "none")  -- E.g.  "he has none"
 624 speakN 1 = ptext (sLit "one")   -- E.g.  "he has one"
 625 speakN 2 = ptext (sLit "two")
 626 speakN 3 = ptext (sLit "three")
 627 speakN 4 = ptext (sLit "four")
 628 speakN 5 = ptext (sLit "five")
 629 speakN 6 = ptext (sLit "six")
 630 speakN n = int n
 631
 632 speakNOf :: Int -> SDoc -> SDoc
 633 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'      -- E.g. "no arguments"
 634 speakNOf 1 d = ptext (sLit "one") <+> d                 -- E.g. "one argument"
 635 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 636
 637 speakNTimes :: Int {- >=1 -} -> SDoc
 638 speakNTimes t | t == 1     = ptext (sLit "once")
 639               | t == 2     = ptext (sLit "twice")
 640               | otherwise  = speakN t <+> ptext (sLit "times")
 641
 642 plural :: [a] -> SDoc
 643 plural [_] = empty  -- a bit frightening, but there you are
 644 plural _   = char 's'
 645 \end{code}
 646
 647
 648 %************************************************************************
 649 %*                                                                      *
 650 \subsection{Error handling}
 651 %*                                                                      *
 652 %************************************************************************
 653
 654 \begin{code}
 655 pprPanic, pprPgmError :: String -> SDoc -> a
 656 pprTrace :: String -> SDoc -> a -> a
 657 pprPanic    = pprAndThen panic          -- Throw an exn saying "bug in GHC"
 658
 659 pprPgmError = pprAndThen pgmError       -- Throw an exn saying "bug in pgm being compiled"
 660                                         --      (used for unusual pgm errors)
 661 pprTrace str doc x
 662    | opt_NoDebugOutput = x
 663    | otherwise         = pprAndThen trace str doc x
 664
 665 pprPanicFastInt :: String -> SDoc -> FastInt
 666 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
 667                              where
 668                                doc = text heading <+> pretty_msg
 669
 670 pprAndThen :: (String -> a) -> String -> SDoc -> a
 671 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 672     where
 673      doc = sep [text heading, nest 4 pretty_msg]
 674
 675 assertPprPanic :: String -> Int -> SDoc -> a
 676 assertPprPanic file line msg
 677   = panic (show (doc PprDebug))
 678   where
 679     doc = sep [hsep[text "ASSERT failed! file",
 680                            text file,
 681                            text "line", int line],
 682                     msg]
 683
 684 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 685 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 686 warnPprTrace False _file _line _msg x = x
 687 warnPprTrace True   file  line  msg x
 688   = trace (show (doc PprDebug)) x
 689   where
 690     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 691                msg]
 692 \end{code}