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