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