compiler/utils/Outputable.lhs

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