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