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