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