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