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,
  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 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 semi _sty      = Pretty.semi
 413 comma _sty     = Pretty.comma
 414 colon _sty     = Pretty.colon
 415 equals _sty    = Pretty.equals
 416 space _sty     = Pretty.space
 417 underscore     = char '_'
 418 dot            = char '.'
 419 lparen _sty    = Pretty.lparen
 420 rparen _sty    = Pretty.rparen
 421 lbrack _sty    = Pretty.lbrack
 422 rbrack _sty    = Pretty.rbrack
 423 lbrace _sty    = Pretty.lbrace
 424 rbrace _sty    = Pretty.rbrace
 425
 426 nest :: Int -> SDoc -> SDoc
 427 -- ^ Indent 'SDoc' some specified amount
 428 (<>) :: SDoc -> SDoc -> SDoc
 429 -- ^ Join two 'SDoc' together horizontally without a gap
 430 (<+>) :: SDoc -> SDoc -> SDoc
 431 -- ^ Join two 'SDoc' together horizontally with a gap between them
 432 ($$) :: SDoc -> SDoc -> SDoc
 433 -- ^ Join two 'SDoc' together vertically; if there is
 434 -- no vertical overlap it "dovetails" the two onto one line
 435 ($+$) :: SDoc -> SDoc -> SDoc
 436 -- ^ Join two 'SDoc' together vertically
 437
 438 nest n d sty    = Pretty.nest n (d sty)
 439 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 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
 444 hcat :: [SDoc] -> SDoc
 445 -- ^ Concatenate 'SDoc' horizontally
 446 hsep :: [SDoc] -> SDoc
 447 -- ^ Concatenate 'SDoc' horizontally with a space between each one
 448 vcat :: [SDoc] -> SDoc
 449 -- ^ Concatenate 'SDoc' vertically with dovetailing
 450 sep :: [SDoc] -> SDoc
 451 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
 452 cat :: [SDoc] -> SDoc
 453 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
 454 fsep :: [SDoc] -> SDoc
 455 -- ^ A paragraph-fill combinator. It's much like sep, only it
 456 -- keeps fitting things on one line until it can't fit any more.
 457 fcat :: [SDoc] -> SDoc
 458 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
 459
 460
 461 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 462 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 463 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 464 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 465 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 466 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 467 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 468
 469 hang :: SDoc  -- ^ The header
 470       -> Int  -- ^ Amount to indent the hung body
 471       -> SDoc -- ^ The hung body, indented and placed below the header
 472       -> SDoc
 473 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 474
 475 punctuate :: SDoc   -- ^ The punctuation
 476           -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
 477           -> [SDoc] -- ^ Punctuated list
 478 punctuate _ []     = []
 479 punctuate p (d:ds) = go d ds
 480                    where
 481                      go d [] = [d]
 482                      go d (e:es) = (d <> p) : go e es
 483
 484 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
 485 ppWhen True  doc = doc
 486 ppWhen False _   = empty
 487
 488 ppUnless True  _   = empty
 489 ppUnless False doc = doc
 490 \end{code}
 491
 492
 493 %************************************************************************
 494 %*                                                                      *
 495 \subsection[Outputable-class]{The @Outputable@ class}
 496 %*                                                                      *
 497 %************************************************************************
 498
 499 \begin{code}
 500 -- | Class designating that some type has an 'SDoc' representation
 501 class Outputable a where
 502         ppr :: a -> SDoc
 503 \end{code}
 504
 505 \begin{code}
 506 instance Outputable Bool where
 507     ppr True  = ptext (sLit "True")
 508     ppr False = ptext (sLit "False")
 509
 510 instance Outputable Int where
 511    ppr n = int n
 512
 513 instance Outputable Word16 where
 514    ppr n = integer $ fromIntegral n
 515
 516 instance Outputable Word32 where
 517    ppr n = integer $ fromIntegral n
 518
 519 instance Outputable Word where
 520    ppr n = integer $ fromIntegral n
 521
 522 instance Outputable () where
 523    ppr _ = text "()"
 524
 525 instance (Outputable a) => Outputable [a] where
 526     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 527
 528 instance (Outputable a, Outputable b) => Outputable (a, b) where
 529     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 530
 531 instance Outputable a => Outputable (Maybe a) where
 532   ppr Nothing = ptext (sLit "Nothing")
 533   ppr (Just x) = ptext (sLit "Just") <+> ppr x
 534
 535 instance (Outputable a, Outputable b) => Outputable (Either a b) where
 536   ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
 537   ppr (Right y) = ptext (sLit "Right") <+> ppr y
 538
 539 -- ToDo: may not be used
 540 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 541     ppr (x,y,z) =
 542       parens (sep [ppr x <> comma,
 543                    ppr y <> comma,
 544                    ppr z ])
 545
 546 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 547          Outputable (a, b, c, d) where
 548     ppr (a,b,c,d) =
 549       parens (sep [ppr a <> comma,
 550                    ppr b <> comma,
 551                    ppr c <> comma,
 552                    ppr d])
 553
 554 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
 555          Outputable (a, b, c, d, e) where
 556     ppr (a,b,c,d,e) =
 557       parens (sep [ppr a <> comma,
 558                    ppr b <> comma,
 559                    ppr c <> comma,
 560                    ppr d <> comma,
 561                    ppr e])
 562
 563 instance Outputable FastString where
 564     ppr fs = ftext fs           -- Prints an unadorned string,
 565                                 -- no double quotes or anything
 566 \end{code}
 567
 568 %************************************************************************
 569 %*                                                                      *
 570 \subsection{The @OutputableBndr@ class}
 571 %*                                                                      *
 572 %************************************************************************
 573
 574 \begin{code}
 575 -- | 'BindingSite' is used to tell the thing that prints binder what
 576 -- language construct is binding the identifier.  This can be used
 577 -- to decide how much info to print.
 578 data BindingSite = LambdaBind | CaseBind | LetBind
 579
 580 -- | When we print a binder, we often want to print its type too.
 581 -- The @OutputableBndr@ class encapsulates this idea.
 582 class Outputable a => OutputableBndr a where
 583    pprBndr :: BindingSite -> a -> SDoc
 584    pprBndr _b x = ppr x
 585 \end{code}
 586
 587 %************************************************************************
 588 %*                                                                      *
 589 \subsection{Random printing helpers}
 590 %*                                                                      *
 591 %************************************************************************
 592
 593 \begin{code}
 594 -- We have 31-bit Chars and will simply use Show instances of Char and String.
 595
 596 -- | Special combinator for showing character literals.
 597 pprHsChar :: Char -> SDoc
 598 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 599             | otherwise      = text (show c)
 600
 601 -- | Special combinator for showing string literals.
 602 pprHsString :: FastString -> SDoc
 603 pprHsString fs = text (show (unpackFS fs))
 604
 605 ---------------------
 606 -- Put a name in parens if it's an operator
 607 pprPrefixVar :: Bool -> SDoc -> SDoc
 608 pprPrefixVar is_operator pp_v
 609   | is_operator = parens pp_v
 610   | otherwise   = pp_v
 611
 612 -- Put a name in backquotes if it's not an operator
 613 pprInfixVar :: Bool -> SDoc -> SDoc
 614 pprInfixVar is_operator pp_v
 615   | is_operator = pp_v
 616   | otherwise   = char '`' <> pp_v <> char '`'
 617
 618 ---------------------
 619 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
 620 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
 621 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
 622 --         which none of the HsSyn printing functions do
 623 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
 624 pprHsVar   v = pprPrefixVar (isOperator pp_v) pp_v
 625              where pp_v = ppr v
 626 pprHsInfix v = pprInfixVar  (isOperator pp_v) pp_v
 627              where pp_v = ppr v
 628
 629 isOperator :: SDoc -> Bool
 630 isOperator ppr_v
 631   = case showSDocUnqual ppr_v of
 632         ('(':_)   -> False              -- (), (,) etc
 633         ('[':_)   -> False              -- []
 634         ('$':c:_) -> not (isAlpha c)    -- Don't treat $d as an operator
 635         (':':c:_) -> not (isAlpha c)    -- Don't treat :T as an operator
 636         ('_':_)   -> False              -- Not an operator
 637         (c:_)     -> not (isAlpha c)    -- Starts with non-alpha
 638         _         -> False
 639
 640 pprFastFilePath :: FastString -> SDoc
 641 pprFastFilePath path = text $ normalise $ unpackFS path
 642 \end{code}
 643
 644 %************************************************************************
 645 %*                                                                      *
 646 \subsection{Other helper functions}
 647 %*                                                                      *
 648 %************************************************************************
 649
 650 \begin{code}
 651 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
 652               -> [a]         -- ^ The things to be pretty printed
 653               -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,
 654                              -- comma-separated and finally packed into a paragraph.
 655 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 656
 657 -- | Returns the seperated concatenation of the pretty printed things.
 658 interppSP  :: Outputable a => [a] -> SDoc
 659 interppSP  xs = sep (map ppr xs)
 660
 661 -- | Returns the comma-seperated concatenation of the pretty printed things.
 662 interpp'SP :: Outputable a => [a] -> SDoc
 663 interpp'SP xs = sep (punctuate comma (map ppr xs))
 664
 665 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
 666 --
 667 -- > [x,y,z]  ==>  `x', `y', `z'
 668 pprQuotedList :: Outputable a => [a] -> SDoc
 669 pprQuotedList = quotedList . map ppr
 670
 671 quotedList :: [SDoc] -> SDoc
 672 quotedList xs = hsep (punctuate comma (map quotes xs))
 673
 674 quotedListWithOr :: [SDoc] -> SDoc
 675 -- [x,y,z]  ==>  `x', `y' or `z'
 676 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
 677 quotedListWithOr xs = quotedList xs
 678 \end{code}
 679
 680
 681 %************************************************************************
 682 %*                                                                      *
 683 \subsection{Printing numbers verbally}
 684 %*                                                                      *
 685 %************************************************************************
 686
 687 \begin{code}
 688 -- | Converts an integer to a verbal index:
 689 --
 690 -- > speakNth 1 = text "first"
 691 -- > speakNth 5 = text "fifth"
 692 -- > speakNth 21 = text "21st"
 693 speakNth :: Int -> SDoc
 694 speakNth 1 = ptext (sLit "first")
 695 speakNth 2 = ptext (sLit "second")
 696 speakNth 3 = ptext (sLit "third")
 697 speakNth 4 = ptext (sLit "fourth")
 698 speakNth 5 = ptext (sLit "fifth")
 699 speakNth 6 = ptext (sLit "sixth")
 700 speakNth n = hcat [ int n, text suffix ]
 701   where
 702     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 703            | last_dig == 1 = "st"
 704            | last_dig == 2 = "nd"
 705            | last_dig == 3 = "rd"
 706            | otherwise     = "th"
 707
 708     last_dig = n `rem` 10
 709
 710 -- | Converts an integer to a verbal multiplicity:
 711 --
 712 -- > speakN 0 = text "none"
 713 -- > speakN 5 = text "five"
 714 -- > speakN 10 = text "10"
 715 speakN :: Int -> SDoc
 716 speakN 0 = ptext (sLit "none")  -- E.g.  "he has none"
 717 speakN 1 = ptext (sLit "one")   -- E.g.  "he has one"
 718 speakN 2 = ptext (sLit "two")
 719 speakN 3 = ptext (sLit "three")
 720 speakN 4 = ptext (sLit "four")
 721 speakN 5 = ptext (sLit "five")
 722 speakN 6 = ptext (sLit "six")
 723 speakN n = int n
 724
 725 -- | Converts an integer and object description to a statement about the
 726 -- multiplicity of those objects:
 727 --
 728 -- > speakNOf 0 (text "melon") = text "no melons"
 729 -- > speakNOf 1 (text "melon") = text "one melon"
 730 -- > speakNOf 3 (text "melon") = text "three melons"
 731 speakNOf :: Int -> SDoc -> SDoc
 732 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
 733 speakNOf 1 d = ptext (sLit "one") <+> d                 -- E.g. "one argument"
 734 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 735
 736 -- | Converts a strictly positive integer into a number of times:
 737 --
 738 -- > speakNTimes 1 = text "once"
 739 -- > speakNTimes 2 = text "twice"
 740 -- > speakNTimes 4 = text "4 times"
 741 speakNTimes :: Int {- >=1 -} -> SDoc
 742 speakNTimes t | t == 1     = ptext (sLit "once")
 743               | t == 2     = ptext (sLit "twice")
 744               | otherwise  = speakN t <+> ptext (sLit "times")
 745
 746 -- | Determines the pluralisation suffix appropriate for the length of a list:
 747 --
 748 -- > plural [] = char 's'
 749 -- > plural ["Hello"] = empty
 750 -- > plural ["Hello", "World"] = char 's'
 751 plural :: [a] -> SDoc
 752 plural [_] = empty  -- a bit frightening, but there you are
 753 plural _   = char 's'
 754 \end{code}
 755
 756
 757 %************************************************************************
 758 %*                                                                      *
 759 \subsection{Error handling}
 760 %*                                                                      *
 761 %************************************************************************
 762
 763 \begin{code}
 764 pprPanic :: String -> SDoc -> a
 765 -- ^ Throw an exception saying "bug in GHC"
 766 pprPgmError :: String -> SDoc -> a
 767 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
 768 pprTrace :: String -> SDoc -> a -> a
 769 -- ^ If debug output is on, show some 'SDoc' on the screen
 770
 771 pprPanic    = pprAndThen panic
 772
 773 pprPgmError = pprAndThen pgmError
 774
 775 pprTrace str doc x
 776    | opt_NoDebugOutput = x
 777    | otherwise         = pprAndThen trace str doc x
 778
 779 pprPanicFastInt :: String -> SDoc -> FastInt
 780 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
 781 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
 782                              where
 783                                doc = text heading <+> pretty_msg
 784
 785 pprAndThen :: (String -> a) -> String -> SDoc -> a
 786 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 787     where
 788      doc = sep [text heading, nest 4 pretty_msg]
 789
 790 assertPprPanic :: String -> Int -> SDoc -> a
 791 -- ^ Panic with an assertation failure, recording the given file and line number.
 792 -- Should typically be accessed with the ASSERT family of macros
 793 assertPprPanic file line msg
 794   = panic (show (doc PprDebug))
 795   where
 796     doc = sep [hsep[text "ASSERT failed! file",
 797                            text file,
 798                            text "line", int line],
 799                     msg]
 800
 801 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 802 -- ^ Just warn about an assertion failure, recording the given file and line number.
 803 -- Should typically be accessed with the WARN macros
 804 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 805 warnPprTrace False _file _line _msg x = x
 806 warnPprTrace True   file  line  msg x
 807   = trace (show (doc defaultDumpStyle)) x
 808   where
 809     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 810                msg]
 811 \end{code}