compiler/utils/Outputable.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP Project, Glasgow University, 1992-1998
   4 %
   5
   6 \begin{code}
   7 -- | This module defines classes and functions for pretty-printing. It also
   8 -- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
   9 --
  10 -- The interface to this module is very similar to the standard Hughes-PJ pretty printing
  11 -- module, except that it exports a number of additional functions that are rarely used,
  12 -- and works over the 'SDoc' type.
  13 module Outputable (
  14         -- * Type classes
  15         Outputable(..), OutputableBndr(..),
  16
  17         -- * Pretty printing combinators
  18         SDoc,
  19         docToSDoc,
  20         interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
  21         empty, nest,
  22         char,
  23         text, ftext, ptext,
  24         int, integer, float, double, rational,
  25         parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
  26         semi, comma, colon, dcolon, space, equals, dot, arrow, darrow,
  27         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
  28         blankLine,
  29         (<>), (<+>), hcat, hsep,
  30         ($$), ($+$), vcat,
  31         sep, cat,
  32         fsep, fcat,
  33         hang, punctuate, ppWhen, ppUnless,
  34         speakNth, speakNTimes, speakN, speakNOf, plural,
  35
  36         -- * Converting 'SDoc' into strings and outputing it
  37         printSDoc, printErrs, printOutput, hPrintDump, printDump,
  38         printForC, printForAsm, printForUser, printForUserPartWay,
  39         pprCode, mkCodeStyle,
  40         showSDoc, showSDocOneLine,
  41         showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
  42         showPpr,
  43         showSDocUnqual, showsPrecSDoc,
  44
  45         pprInfixVar, pprPrefixVar,
  46         pprHsChar, pprHsString, pprHsInfix, pprHsVar,
  47         pprFastFilePath,
  48
  49         -- * Controlling the style in which output is printed
  50         BindingSite(..),
  51
  52         PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
  53         QualifyName(..),
  54         getPprStyle, withPprStyle, withPprStyleDoc,
  55         pprDeeper, pprDeeperList, pprSetDepth,
  56         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
  57         ifPprDebug, qualName, qualModule,
  58         mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
  59         mkUserStyle, cmdlineParserStyle, Depth(..),
  60
  61         -- * Error handling and debugging utilities
  62         pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
  63         pprTrace, warnPprTrace,
  64         trace, pgmError, panic, panicFastInt, assertPanic
  65     ) where
  66
  67 import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
  68 import {-# SOURCE #-}   OccName( OccName )
  69
  70 import StaticFlags
  71 import FastString
  72 import FastTypes
  73 import qualified Pretty
  74 import Pretty           ( Doc, Mode(..) )
  75 import Panic
  76
  77 import Data.Char
  78 import Data.Map (Map)
  79 import qualified Data.Map as M
  80 import Data.Word
  81 import System.IO        ( Handle, stderr, stdout, hFlush )
  82 import System.FilePath
  83 \end{code}
  84
  85
  86 %************************************************************************
  87 %*                                                                      *
  88 \subsection{The @PprStyle@ data type}
  89 %*                                                                      *
  90 %************************************************************************
  91
  92 \begin{code}
  93
  94 data PprStyle
  95   = PprUser PrintUnqualified Depth
  96                 -- Pretty-print in a way that will make sense to the
  97                 -- ordinary user; must be very close to Haskell
  98                 -- syntax, etc.
  99                 -- Assumes printing tidied code: non-system names are
 100                 -- printed without uniques.
 101
 102   | PprCode CodeStyle
 103                 -- Print code; either C or assembler
 104
 105   | PprDump     -- For -ddump-foo; less verbose than PprDebug.
 106                 -- Does not assume tidied code: non-external names
 107                 -- are printed with uniques.
 108
 109   | PprDebug    -- Full debugging output
 110
 111 data CodeStyle = CStyle         -- The format of labels differs for C and assembler
 112                | AsmStyle
 113
 114 data Depth = AllTheWay
 115            | PartWay Int        -- 0 => stop
 116
 117
 118 -- -----------------------------------------------------------------------------
 119 -- Printing original names
 120
 121 -- When printing code that contains original names, we need to map the
 122 -- original names back to something the user understands.  This is the
 123 -- purpose of the pair of functions that gets passed around
 124 -- when rendering 'SDoc'.
 125
 126 -- | given an /original/ name, this function tells you which module
 127 -- name it should be qualified with when printing for the user, if
 128 -- any.  For example, given @Control.Exception.catch@, which is in scope
 129 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
 130 -- Note that the return value is a ModuleName, not a Module, because
 131 -- in source code, names are qualified by ModuleNames.
 132 type QueryQualifyName = Module -> OccName -> QualifyName
 133
 134 -- See Note [Printing original names] in HscTypes
 135 data QualifyName                        -- given P:M.T
 136         = NameUnqual                    -- refer to it as "T"
 137         | NameQual ModuleName           -- refer to it as "X.T" for the supplied X
 138         | NameNotInScope1
 139                 -- it is not in scope at all, but M.T is not bound in the current
 140                 -- scope, so we can refer to it as "M.T"
 141         | NameNotInScope2
 142                 -- it is not in scope at all, and M.T is already bound in the
 143                 -- current scope, so we must refer to it as "P:M.T"
 144
 145
 146 -- | For a given module, we need to know whether to print it with
 147 -- a package name to disambiguate it.
 148 type QueryQualifyModule = Module -> Bool
 149
 150 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
 151
 152 alwaysQualifyNames :: QueryQualifyName
 153 alwaysQualifyNames m _ = NameQual (moduleName m)
 154
 155 neverQualifyNames :: QueryQualifyName
 156 neverQualifyNames _ _ = NameUnqual
 157
 158 alwaysQualifyModules :: QueryQualifyModule
 159 alwaysQualifyModules _ = True
 160
 161 neverQualifyModules :: QueryQualifyModule
 162 neverQualifyModules _ = False
 163
 164 alwaysQualify, neverQualify :: PrintUnqualified
 165 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
 166 neverQualify  = (neverQualifyNames,  neverQualifyModules)
 167
 168 defaultUserStyle, defaultDumpStyle :: PprStyle
 169
 170 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
 171
 172 defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
 173                  |  otherwise          = PprDump
 174
 175 -- | Style for printing error messages
 176 mkErrStyle :: PrintUnqualified -> PprStyle
 177 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
 178
 179 defaultErrStyle :: PprStyle
 180 -- Default style for error messages
 181 -- It's a bit of a hack because it doesn't take into account what's in scope
 182 -- Only used for desugarer warnings, and typechecker errors in interface sigs
 183 defaultErrStyle
 184   | opt_PprStyle_Debug   = mkUserStyle alwaysQualify AllTheWay
 185   | otherwise            = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
 186
 187 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
 188 mkUserStyle unqual depth
 189    | opt_PprStyle_Debug = PprDebug
 190    | otherwise          = PprUser unqual depth
 191
 192 cmdlineParserStyle :: PprStyle
 193 cmdlineParserStyle = PprUser alwaysQualify AllTheWay
 194 \end{code}
 195
 196 Orthogonal to the above printing styles are (possibly) some
 197 command-line flags that affect printing (often carried with the
 198 style).  The most likely ones are variations on how much type info is
 199 shown.
 200
 201 The following test decides whether or not we are actually generating
 202 code (either C or assembly), or generating interface files.
 203
 204 %************************************************************************
 205 %*                                                                      *
 206 \subsection{The @SDoc@ data type}
 207 %*                                                                      *
 208 %************************************************************************
 209
 210 \begin{code}
 211 type SDoc = PprStyle -> Doc
 212
 213 withPprStyle :: PprStyle -> SDoc -> SDoc
 214 withPprStyle sty d _sty' = d sty
 215
 216 withPprStyleDoc :: PprStyle -> SDoc -> Doc
 217 withPprStyleDoc sty d = d sty
 218
 219 pprDeeper :: SDoc -> SDoc
 220 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
 221 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
 222 pprDeeper d other_sty               = d other_sty
 223
 224 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
 225 -- Truncate a list that list that is longer than the current depth
 226 pprDeeperList f ds (PprUser q (PartWay n))
 227   | n==0      = Pretty.text "..."
 228   | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
 229   where
 230     go _ [] = []
 231     go i (d:ds) | i >= n    = [text "...."]
 232                 | otherwise = d : go (i+1) ds
 233
 234 pprDeeperList f ds other_sty
 235   = f ds other_sty
 236
 237 pprSetDepth :: Depth -> SDoc -> SDoc
 238 pprSetDepth depth  doc (PprUser q _) = doc (PprUser q depth)
 239 pprSetDepth _depth doc other_sty     = doc other_sty
 240
 241 getPprStyle :: (PprStyle -> SDoc) -> SDoc
 242 getPprStyle df sty = df sty sty
 243 \end{code}
 244
 245 \begin{code}
 246 qualName :: PprStyle -> QueryQualifyName
 247 qualName (PprUser (qual_name,_) _) m  n = qual_name m n
 248 qualName _other                    m _n = NameQual (moduleName m)
 249
 250 qualModule :: PprStyle -> QueryQualifyModule
 251 qualModule (PprUser (_,qual_mod) _)  m = qual_mod m
 252 qualModule _other                   _m = True
 253
 254 codeStyle :: PprStyle -> Bool
 255 codeStyle (PprCode _)     = True
 256 codeStyle _               = False
 257
 258 asmStyle :: PprStyle -> Bool
 259 asmStyle (PprCode AsmStyle)  = True
 260 asmStyle _other              = False
 261
 262 dumpStyle :: PprStyle -> Bool
 263 dumpStyle PprDump = True
 264 dumpStyle _other  = False
 265
 266 debugStyle :: PprStyle -> Bool
 267 debugStyle PprDebug       = True
 268 debugStyle _other         = False
 269
 270 userStyle ::  PprStyle -> Bool
 271 userStyle (PprUser _ _) = True
 272 userStyle _other        = False
 273
 274 ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
 275 ifPprDebug d sty@PprDebug = d sty
 276 ifPprDebug _ _            = Pretty.empty
 277 \end{code}
 278
 279 \begin{code}
 280 -- Unused [7/02 sof]
 281 printSDoc :: SDoc -> PprStyle -> IO ()
 282 printSDoc d sty = do
 283   Pretty.printDoc PageMode stdout (d sty)
 284   hFlush stdout
 285
 286 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
 287 -- above is better or worse than the put-big-string approach here
 288 printErrs :: Doc -> IO ()
 289 printErrs doc = do Pretty.printDoc PageMode stderr doc
 290                    hFlush stderr
 291
 292 printOutput :: Doc -> IO ()
 293 printOutput doc = Pretty.printDoc PageMode stdout doc
 294
 295 printDump :: SDoc -> IO ()
 296 printDump doc = hPrintDump stdout doc
 297
 298 hPrintDump :: Handle -> SDoc -> IO ()
 299 hPrintDump h doc = do
 300    Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
 301    hFlush h
 302  where
 303    better_doc = doc $$ blankLine
 304
 305 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 306 printForUser handle unqual doc
 307   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 308
 309 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
 310 printForUserPartWay handle d unqual doc
 311   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
 312
 313 -- printForC, printForAsm do what they sound like
 314 printForC :: Handle -> SDoc -> IO ()
 315 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
 316
 317 printForAsm :: Handle -> SDoc -> IO ()
 318 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
 319
 320 pprCode :: CodeStyle -> SDoc -> SDoc
 321 pprCode cs d = withPprStyle (PprCode cs) d
 322
 323 mkCodeStyle :: CodeStyle -> PprStyle
 324 mkCodeStyle = PprCode
 325
 326 -- Can't make SDoc an instance of Show because SDoc is just a function type
 327 -- However, Doc *is* an instance of Show
 328 -- showSDoc just blasts it out as a string
 329 showSDoc :: SDoc -> String
 330 showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
 331
 332 -- This shows an SDoc, but on one line only. It's cheaper than a full
 333 -- showSDoc, designed for when we're getting results like "Foo.bar"
 334 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
 335 showSDocOneLine :: SDoc -> String
 336 showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
 337
 338 showSDocForUser :: PrintUnqualified -> SDoc -> String
 339 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
 340
 341 showSDocUnqual :: SDoc -> String
 342 -- Only used in the gruesome isOperator
 343 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 344
 345 showsPrecSDoc :: Int -> SDoc -> ShowS
 346 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 347
 348 showSDocDump :: SDoc -> String
 349 showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
 350
 351 showSDocDumpOneLine :: SDoc -> String
 352 showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
 353
 354 showSDocDebug :: SDoc -> String
 355 showSDocDebug d = show (d PprDebug)
 356
 357 showPpr :: Outputable a => a -> String
 358 showPpr = showSDoc . ppr
 359 \end{code}
 360
 361 \begin{code}
 362 docToSDoc :: Doc -> SDoc
 363 docToSDoc d = \_ -> d
 364
 365 empty    :: SDoc
 366 char     :: Char       -> SDoc
 367 text     :: String     -> SDoc
 368 ftext    :: FastString -> SDoc
 369 ptext    :: LitString  -> SDoc
 370 int      :: Int        -> SDoc
 371 integer  :: Integer    -> SDoc
 372 float    :: Float      -> SDoc
 373 double   :: Double     -> SDoc
 374 rational :: Rational   -> SDoc
 375
 376 empty _sty      = Pretty.empty
 377 char c _sty     = Pretty.char c
 378 text s _sty     = Pretty.text s
 379 ftext s _sty    = Pretty.ftext s
 380 ptext s _sty    = Pretty.ptext s
 381 int n _sty      = Pretty.int n
 382 integer n _sty  = Pretty.integer n
 383 float n _sty    = Pretty.float n
 384 double n _sty   = Pretty.double n
 385 rational n _sty = Pretty.rational n
 386
 387 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
 388
 389 parens d sty       = Pretty.parens (d sty)
 390 braces d sty       = Pretty.braces (d sty)
 391 brackets d sty     = Pretty.brackets (d sty)
 392 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 393 angleBrackets d    = char '<' <> d <> char '>'
 394
 395 cparen :: Bool -> SDoc -> SDoc
 396
 397 cparen b d sty       = Pretty.cparen b (d sty)
 398
 399 -- quotes encloses something in single quotes...
 400 -- but it omits them if the thing ends in a single quote
 401 -- so that we don't get `foo''.  Instead we just have foo'.
 402 quotes d sty = case show pp_d of
 403                  ('\'' : _) -> pp_d
 404                  _other     -> Pretty.quotes pp_d
 405              where
 406                pp_d = d sty
 407
 408 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
 409 darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
 410
 411 blankLine _sty = Pretty.ptext (sLit "")
 412 dcolon _sty    = Pretty.ptext (sLit "::")
 413 arrow  _sty    = Pretty.ptext (sLit "->")
 414 darrow _sty    = Pretty.ptext (sLit "=>")
 415 semi _sty      = Pretty.semi
 416 comma _sty     = Pretty.comma
 417 colon _sty     = Pretty.colon
 418 equals _sty    = Pretty.equals
 419 space _sty     = Pretty.space
 420 underscore     = char '_'
 421 dot            = char '.'
 422 lparen _sty    = Pretty.lparen
 423 rparen _sty    = Pretty.rparen
 424 lbrack _sty    = Pretty.lbrack
 425 rbrack _sty    = Pretty.rbrack
 426 lbrace _sty    = Pretty.lbrace
 427 rbrace _sty    = Pretty.rbrace
 428
 429 nest :: Int -> SDoc -> SDoc
 430 -- ^ Indent 'SDoc' some specified amount
 431 (<>) :: SDoc -> SDoc -> SDoc
 432 -- ^ Join two 'SDoc' together horizontally without a gap
 433 (<+>) :: SDoc -> SDoc -> SDoc
 434 -- ^ Join two 'SDoc' together horizontally with a gap between them
 435 ($$) :: SDoc -> SDoc -> SDoc
 436 -- ^ Join two 'SDoc' together vertically; if there is
 437 -- no vertical overlap it "dovetails" the two onto one line
 438 ($+$) :: SDoc -> SDoc -> SDoc
 439 -- ^ Join two 'SDoc' together vertically
 440
 441 nest n d sty    = Pretty.nest n (d sty)
 442 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 443 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 444 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 445 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 446
 447 hcat :: [SDoc] -> SDoc
 448 -- ^ Concatenate 'SDoc' horizontally
 449 hsep :: [SDoc] -> SDoc
 450 -- ^ Concatenate 'SDoc' horizontally with a space between each one
 451 vcat :: [SDoc] -> SDoc
 452 -- ^ Concatenate 'SDoc' vertically with dovetailing
 453 sep :: [SDoc] -> SDoc
 454 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
 455 cat :: [SDoc] -> SDoc
 456 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
 457 fsep :: [SDoc] -> SDoc
 458 -- ^ A paragraph-fill combinator. It's much like sep, only it
 459 -- keeps fitting things on one line until it can't fit any more.
 460 fcat :: [SDoc] -> SDoc
 461 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
 462
 463
 464 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 465 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 466 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 467 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 468 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 469 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 470 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 471
 472 hang :: SDoc  -- ^ The header
 473       -> Int  -- ^ Amount to indent the hung body
 474       -> SDoc -- ^ The hung body, indented and placed below the header
 475       -> SDoc
 476 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 477
 478 punctuate :: SDoc   -- ^ The punctuation
 479           -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
 480           -> [SDoc] -- ^ Punctuated list
 481 punctuate _ []     = []
 482 punctuate p (d:ds) = go d ds
 483                    where
 484                      go d [] = [d]
 485                      go d (e:es) = (d <> p) : go e es
 486
 487 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
 488 ppWhen True  doc = doc
 489 ppWhen False _   = empty
 490
 491 ppUnless True  _   = empty
 492 ppUnless False doc = doc
 493 \end{code}
 494
 495
 496 %************************************************************************
 497 %*                                                                      *
 498 \subsection[Outputable-class]{The @Outputable@ class}
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 \begin{code}
 503 -- | Class designating that some type has an 'SDoc' representation
 504 class Outputable a where
 505         ppr :: a -> SDoc
 506 \end{code}
 507
 508 \begin{code}
 509 instance Outputable Bool where
 510     ppr True  = ptext (sLit "True")
 511     ppr False = ptext (sLit "False")
 512
 513 instance Outputable Int where
 514    ppr n = int n
 515
 516 instance Outputable Word16 where
 517    ppr n = integer $ fromIntegral n
 518
 519 instance Outputable Word32 where
 520    ppr n = integer $ fromIntegral n
 521
 522 instance Outputable Word where
 523    ppr n = integer $ fromIntegral n
 524
 525 instance Outputable () where
 526    ppr _ = text "()"
 527
 528 instance (Outputable a) => Outputable [a] where
 529     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 530
 531 instance (Outputable a, Outputable b) => Outputable (a, b) where
 532     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 533
 534 instance Outputable a => Outputable (Maybe a) where
 535   ppr Nothing = ptext (sLit "Nothing")
 536   ppr (Just x) = ptext (sLit "Just") <+> ppr x
 537
 538 instance (Outputable a, Outputable b) => Outputable (Either a b) where
 539   ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
 540   ppr (Right y) = ptext (sLit "Right") <+> ppr y
 541
 542 -- ToDo: may not be used
 543 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 544     ppr (x,y,z) =
 545       parens (sep [ppr x <> comma,
 546                    ppr y <> comma,
 547                    ppr z ])
 548
 549 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 550          Outputable (a, b, c, d) where
 551     ppr (a,b,c,d) =
 552       parens (sep [ppr a <> comma,
 553                    ppr b <> comma,
 554                    ppr c <> comma,
 555                    ppr d])
 556
 557 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
 558          Outputable (a, b, c, d, e) where
 559     ppr (a,b,c,d,e) =
 560       parens (sep [ppr a <> comma,
 561                    ppr b <> comma,
 562                    ppr c <> comma,
 563                    ppr d <> comma,
 564                    ppr e])
 565
 566 instance Outputable FastString where
 567     ppr fs = ftext fs           -- Prints an unadorned string,
 568                                 -- no double quotes or anything
 569
 570 instance (Outputable key, Outputable elt) => Outputable (Map key elt) where
 571     ppr m = ppr (M.toList m)
 572 \end{code}
 573
 574 %************************************************************************
 575 %*                                                                      *
 576 \subsection{The @OutputableBndr@ class}
 577 %*                                                                      *
 578 %************************************************************************
 579
 580 \begin{code}
 581 -- | 'BindingSite' is used to tell the thing that prints binder what
 582 -- language construct is binding the identifier.  This can be used
 583 -- to decide how much info to print.
 584 data BindingSite = LambdaBind | CaseBind | LetBind
 585
 586 -- | When we print a binder, we often want to print its type too.
 587 -- The @OutputableBndr@ class encapsulates this idea.
 588 class Outputable a => OutputableBndr a where
 589    pprBndr :: BindingSite -> a -> SDoc
 590    pprBndr _b x = ppr x
 591 \end{code}
 592
 593 %************************************************************************
 594 %*                                                                      *
 595 \subsection{Random printing helpers}
 596 %*                                                                      *
 597 %************************************************************************
 598
 599 \begin{code}
 600 -- We have 31-bit Chars and will simply use Show instances of Char and String.
 601
 602 -- | Special combinator for showing character literals.
 603 pprHsChar :: Char -> SDoc
 604 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 605             | otherwise      = text (show c)
 606
 607 -- | Special combinator for showing string literals.
 608 pprHsString :: FastString -> SDoc
 609 pprHsString fs = text (show (unpackFS fs))
 610
 611 ---------------------
 612 -- Put a name in parens if it's an operator
 613 pprPrefixVar :: Bool -> SDoc -> SDoc
 614 pprPrefixVar is_operator pp_v
 615   | is_operator = parens pp_v
 616   | otherwise   = pp_v
 617
 618 -- Put a name in backquotes if it's not an operator
 619 pprInfixVar :: Bool -> SDoc -> SDoc
 620 pprInfixVar is_operator pp_v
 621   | is_operator = pp_v
 622   | otherwise   = char '`' <> pp_v <> char '`'
 623
 624 ---------------------
 625 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
 626 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
 627 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
 628 --         which none of the HsSyn printing functions do
 629 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
 630 pprHsVar   v = pprPrefixVar (isOperator pp_v) pp_v
 631              where pp_v = ppr v
 632 pprHsInfix v = pprInfixVar  (isOperator pp_v) pp_v
 633              where pp_v = ppr v
 634
 635 isOperator :: SDoc -> Bool
 636 isOperator ppr_v
 637   = case showSDocUnqual ppr_v of
 638         ('(':_)   -> False              -- (), (,) etc
 639         ('[':_)   -> False              -- []
 640         ('$':c:_) -> not (isAlpha c)    -- Don't treat $d as an operator
 641         (':':c:_) -> not (isAlpha c)    -- Don't treat :T as an operator
 642         ('_':_)   -> False              -- Not an operator
 643         (c:_)     -> not (isAlpha c)    -- Starts with non-alpha
 644         _         -> False
 645
 646 pprFastFilePath :: FastString -> SDoc
 647 pprFastFilePath path = text $ normalise $ unpackFS path
 648 \end{code}
 649
 650 %************************************************************************
 651 %*                                                                      *
 652 \subsection{Other helper functions}
 653 %*                                                                      *
 654 %************************************************************************
 655
 656 \begin{code}
 657 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
 658               -> [a]         -- ^ The things to be pretty printed
 659               -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,
 660                              -- comma-separated and finally packed into a paragraph.
 661 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 662
 663 -- | Returns the seperated concatenation of the pretty printed things.
 664 interppSP  :: Outputable a => [a] -> SDoc
 665 interppSP  xs = sep (map ppr xs)
 666
 667 -- | Returns the comma-seperated concatenation of the pretty printed things.
 668 interpp'SP :: Outputable a => [a] -> SDoc
 669 interpp'SP xs = sep (punctuate comma (map ppr xs))
 670
 671 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
 672 --
 673 -- > [x,y,z]  ==>  `x', `y', `z'
 674 pprQuotedList :: Outputable a => [a] -> SDoc
 675 pprQuotedList = quotedList . map ppr
 676
 677 quotedList :: [SDoc] -> SDoc
 678 quotedList xs = hsep (punctuate comma (map quotes xs))
 679
 680 quotedListWithOr :: [SDoc] -> SDoc
 681 -- [x,y,z]  ==>  `x', `y' or `z'
 682 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
 683 quotedListWithOr xs = quotedList xs
 684 \end{code}
 685
 686
 687 %************************************************************************
 688 %*                                                                      *
 689 \subsection{Printing numbers verbally}
 690 %*                                                                      *
 691 %************************************************************************
 692
 693 \begin{code}
 694 -- | Converts an integer to a verbal index:
 695 --
 696 -- > speakNth 1 = text "first"
 697 -- > speakNth 5 = text "fifth"
 698 -- > speakNth 21 = text "21st"
 699 speakNth :: Int -> SDoc
 700 speakNth 1 = ptext (sLit "first")
 701 speakNth 2 = ptext (sLit "second")
 702 speakNth 3 = ptext (sLit "third")
 703 speakNth 4 = ptext (sLit "fourth")
 704 speakNth 5 = ptext (sLit "fifth")
 705 speakNth 6 = ptext (sLit "sixth")
 706 speakNth n = hcat [ int n, text suffix ]
 707   where
 708     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 709            | last_dig == 1 = "st"
 710            | last_dig == 2 = "nd"
 711            | last_dig == 3 = "rd"
 712            | otherwise     = "th"
 713
 714     last_dig = n `rem` 10
 715
 716 -- | Converts an integer to a verbal multiplicity:
 717 --
 718 -- > speakN 0 = text "none"
 719 -- > speakN 5 = text "five"
 720 -- > speakN 10 = text "10"
 721 speakN :: Int -> SDoc
 722 speakN 0 = ptext (sLit "none")  -- E.g.  "he has none"
 723 speakN 1 = ptext (sLit "one")   -- E.g.  "he has one"
 724 speakN 2 = ptext (sLit "two")
 725 speakN 3 = ptext (sLit "three")
 726 speakN 4 = ptext (sLit "four")
 727 speakN 5 = ptext (sLit "five")
 728 speakN 6 = ptext (sLit "six")
 729 speakN n = int n
 730
 731 -- | Converts an integer and object description to a statement about the
 732 -- multiplicity of those objects:
 733 --
 734 -- > speakNOf 0 (text "melon") = text "no melons"
 735 -- > speakNOf 1 (text "melon") = text "one melon"
 736 -- > speakNOf 3 (text "melon") = text "three melons"
 737 speakNOf :: Int -> SDoc -> SDoc
 738 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
 739 speakNOf 1 d = ptext (sLit "one") <+> d                 -- E.g. "one argument"
 740 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 741
 742 -- | Converts a strictly positive integer into a number of times:
 743 --
 744 -- > speakNTimes 1 = text "once"
 745 -- > speakNTimes 2 = text "twice"
 746 -- > speakNTimes 4 = text "4 times"
 747 speakNTimes :: Int {- >=1 -} -> SDoc
 748 speakNTimes t | t == 1     = ptext (sLit "once")
 749               | t == 2     = ptext (sLit "twice")
 750               | otherwise  = speakN t <+> ptext (sLit "times")
 751
 752 -- | Determines the pluralisation suffix appropriate for the length of a list:
 753 --
 754 -- > plural [] = char 's'
 755 -- > plural ["Hello"] = empty
 756 -- > plural ["Hello", "World"] = char 's'
 757 plural :: [a] -> SDoc
 758 plural [_] = empty  -- a bit frightening, but there you are
 759 plural _   = char 's'
 760 \end{code}
 761
 762
 763 %************************************************************************
 764 %*                                                                      *
 765 \subsection{Error handling}
 766 %*                                                                      *
 767 %************************************************************************
 768
 769 \begin{code}
 770 pprPanic :: String -> SDoc -> a
 771 -- ^ Throw an exception saying "bug in GHC"
 772 pprPgmError :: String -> SDoc -> a
 773 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
 774 pprTrace :: String -> SDoc -> a -> a
 775 -- ^ If debug output is on, show some 'SDoc' on the screen
 776
 777 pprPanic    = pprAndThen panic
 778
 779 pprPgmError = pprAndThen pgmError
 780
 781 pprTrace str doc x
 782    | opt_NoDebugOutput = x
 783    | otherwise         = pprAndThen trace str doc x
 784
 785 pprPanicFastInt :: String -> SDoc -> FastInt
 786 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
 787 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
 788                              where
 789                                doc = text heading <+> pretty_msg
 790
 791 pprAndThen :: (String -> a) -> String -> SDoc -> a
 792 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 793     where
 794      doc = sep [text heading, nest 4 pretty_msg]
 795
 796 assertPprPanic :: String -> Int -> SDoc -> a
 797 -- ^ Panic with an assertation failure, recording the given file and line number.
 798 -- Should typically be accessed with the ASSERT family of macros
 799 assertPprPanic file line msg
 800   = panic (show (doc PprDebug))
 801   where
 802     doc = sep [hsep[text "ASSERT failed! file",
 803                            text file,
 804                            text "line", int line],
 805                     msg]
 806
 807 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 808 -- ^ Just warn about an assertion failure, recording the given file and line number.
 809 -- Should typically be accessed with the WARN macros
 810 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 811 warnPprTrace False _file _line _msg x = x
 812 warnPprTrace True   file  line  msg x
 813   = trace (show (doc defaultDumpStyle)) x
 814   where
 815     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 816                msg]
 817 \end{code}