compiler/utils/Outputable.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1998
   3 %
   4 \section[Outputable]{Classes for pretty-printing}
   5
   6 Defines classes for pretty-printing and forcing, both forms of
   7 ``output.''
   8
   9 \begin{code}
  10
  11 module Outputable (
  12         Outputable(..), OutputableBndr(..),     -- Class
  13
  14         BindingSite(..),
  15
  16         PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
  17         getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
  18         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
  19         ifPprDebug, qualName, qualModule,
  20         mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
  21
  22         SDoc,           -- Abstract
  23         docToSDoc,
  24         interppSP, interpp'SP, pprQuotedList, pprWithCommas,
  25         empty, nest,
  26         text, char, ftext, ptext,
  27         int, integer, float, double, rational,
  28         parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
  29         semi, comma, colon, dcolon, space, equals, dot, arrow,
  30         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
  31         (<>), (<+>), hcat, hsep,
  32         ($$), ($+$), vcat,
  33         sep, cat,
  34         fsep, fcat,
  35         hang, punctuate,
  36         speakNth, speakNTimes, speakN, speakNOf, plural,
  37
  38         printSDoc, printErrs, printDump,
  39         printForC, printForAsm, printForUser,
  40         pprCode, mkCodeStyle,
  41         showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
  42         showSDocUnqual, showsPrecSDoc,
  43         pprHsChar, pprHsString,
  44
  45         -- error handling
  46         pprPanic, assertPprPanic, pprPanic#, pprPgmError,
  47         pprTrace, warnPprTrace,
  48         trace, pgmError, panic, panic#, assertPanic
  49     ) where
  50
  51 #include "HsVersions.h"
  52
  53
  54 import {-# SOURCE #-}   Module( Module, modulePackageId,
  55                                 ModuleName, moduleName )
  56 import {-# SOURCE #-}   OccName( OccName )
  57
  58 import StaticFlags      ( opt_PprStyle_Debug, opt_PprUserLength )
  59 import PackageConfig    ( PackageId, packageIdString )
  60 import FastString
  61 import qualified Pretty
  62 import Pretty           ( Doc, Mode(..) )
  63 import Panic
  64
  65 import DATA_WORD        ( Word32 )
  66
  67 import IO               ( Handle, stderr, stdout, hFlush )
  68 import Char             ( ord )
  69 \end{code}
  70
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection{The @PprStyle@ data type}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 data PprStyle
  80   = PprUser PrintUnqualified Depth
  81                 -- Pretty-print in a way that will make sense to the
  82                 -- ordinary user; must be very close to Haskell
  83                 -- syntax, etc.
  84                 -- Assumes printing tidied code: non-system names are
  85                 -- printed without uniques.
  86
  87   | PprCode CodeStyle
  88                 -- Print code; either C or assembler
  89
  90   | PprDump     -- For -ddump-foo; less verbose than PprDebug.
  91                 -- Does not assume tidied code: non-external names
  92                 -- are printed with uniques.
  93
  94   | PprDebug    -- Full debugging output
  95
  96 data CodeStyle = CStyle         -- The format of labels differs for C and assembler
  97                | AsmStyle
  98
  99 data Depth = AllTheWay
 100            | PartWay Int        -- 0 => stop
 101
 102
 103 -- -----------------------------------------------------------------------------
 104 -- Printing original names
 105
 106 -- When printing code that contains original names, we need to map the
 107 -- original names back to something the user understands.  This is the
 108 -- purpose of the pair of functions that gets passed around
 109 -- when rendering 'SDoc'.
 110
 111 -- | given an /original/ name, this function tells you which module
 112 -- name it should be qualified with when printing for the user, if
 113 -- any.  For example, given @Control.Exception.catch@, which is in scope
 114 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
 115 -- Note that the return value is a ModuleName, not a Module, because
 116 -- in source code, names are qualified by ModuleNames.
 117 type QualifyName = Module -> OccName -> Maybe ModuleName
 118
 119 -- | For a given module, we need to know whether to print it with
 120 -- a package name to disambiguate it, and if so which package name should
 121 -- we use.
 122 type QualifyModule = Module -> Maybe PackageId
 123
 124 type PrintUnqualified = (QualifyName, QualifyModule)
 125
 126 alwaysQualifyNames :: QualifyName
 127 alwaysQualifyNames m n = Just (moduleName m)
 128
 129 neverQualifyNames :: QualifyName
 130 neverQualifyNames m n = Nothing
 131
 132 alwaysQualifyModules :: QualifyModule
 133 alwaysQualifyModules m = Just (modulePackageId m)
 134
 135 neverQualifyModules :: QualifyModule
 136 neverQualifyModules m = Nothing
 137
 138 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
 139 neverQualify  = (neverQualifyNames,  neverQualifyModules)
 140
 141 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
 142
 143 defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
 144                  |  otherwise          = PprDump
 145
 146 -- | Style for printing error messages
 147 mkErrStyle :: PrintUnqualified -> PprStyle
 148 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
 149
 150 defaultErrStyle :: PprStyle
 151 -- Default style for error messages
 152 -- It's a bit of a hack because it doesn't take into account what's in scope
 153 -- Only used for desugarer warnings, and typechecker errors in interface sigs
 154 defaultErrStyle
 155   | opt_PprStyle_Debug   = mkUserStyle alwaysQualify AllTheWay
 156   | otherwise            = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
 157
 158 mkUserStyle unqual depth
 159    | opt_PprStyle_Debug = PprDebug
 160    | otherwise          = PprUser unqual depth
 161 \end{code}
 162
 163 Orthogonal to the above printing styles are (possibly) some
 164 command-line flags that affect printing (often carried with the
 165 style).  The most likely ones are variations on how much type info is
 166 shown.
 167
 168 The following test decides whether or not we are actually generating
 169 code (either C or assembly), or generating interface files.
 170
 171 %************************************************************************
 172 %*                                                                      *
 173 \subsection{The @SDoc@ data type}
 174 %*                                                                      *
 175 %************************************************************************
 176
 177 \begin{code}
 178 type SDoc = PprStyle -> Doc
 179
 180 withPprStyle :: PprStyle -> SDoc -> SDoc
 181 withPprStyle sty d sty' = d sty
 182
 183 withPprStyleDoc :: PprStyle -> SDoc -> Doc
 184 withPprStyleDoc sty d = d sty
 185
 186 pprDeeper :: SDoc -> SDoc
 187 pprDeeper d (PprUser q (PartWay 0)) = Pretty.text "..."
 188 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
 189 pprDeeper d other_sty               = d other_sty
 190
 191 pprSetDepth :: Int -> SDoc -> SDoc
 192 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
 193 pprSetDepth n d other_sty     = d other_sty
 194
 195 getPprStyle :: (PprStyle -> SDoc) -> SDoc
 196 getPprStyle df sty = df sty sty
 197 \end{code}
 198
 199 \begin{code}
 200 qualName :: PprStyle -> QualifyName
 201 qualName (PprUser (qual_name,_) _) m n = qual_name m n
 202 qualName other                     m n = Just (moduleName m)
 203
 204 qualModule :: PprStyle -> QualifyModule
 205 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
 206 qualModule other                    m = Just (modulePackageId m)
 207
 208 codeStyle :: PprStyle -> Bool
 209 codeStyle (PprCode _)     = True
 210 codeStyle _               = False
 211
 212 asmStyle :: PprStyle -> Bool
 213 asmStyle (PprCode AsmStyle)  = True
 214 asmStyle other               = False
 215
 216 dumpStyle :: PprStyle -> Bool
 217 dumpStyle PprDump = True
 218 dumpStyle other   = False
 219
 220 debugStyle :: PprStyle -> Bool
 221 debugStyle PprDebug       = True
 222 debugStyle other          = False
 223
 224 userStyle ::  PprStyle -> Bool
 225 userStyle (PprUser _ _) = True
 226 userStyle other         = False
 227
 228 ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
 229 ifPprDebug d sty@PprDebug = d sty
 230 ifPprDebug d sty          = Pretty.empty
 231 \end{code}
 232
 233 \begin{code}
 234 -- Unused [7/02 sof]
 235 printSDoc :: SDoc -> PprStyle -> IO ()
 236 printSDoc d sty = do
 237   Pretty.printDoc PageMode stdout (d sty)
 238   hFlush stdout
 239
 240 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
 241 -- above is better or worse than the put-big-string approach here
 242 printErrs :: Doc -> IO ()
 243 printErrs doc = do Pretty.printDoc PageMode stderr doc
 244                    hFlush stderr
 245
 246 printDump :: SDoc -> IO ()
 247 printDump doc = do
 248    Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
 249    hFlush stdout
 250  where
 251    better_doc = doc $$ text ""
 252
 253 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 254 printForUser handle unqual doc
 255   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 256
 257 -- printForC, printForAsm do what they sound like
 258 printForC :: Handle -> SDoc -> IO ()
 259 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
 260
 261 printForAsm :: Handle -> SDoc -> IO ()
 262 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
 263
 264 pprCode :: CodeStyle -> SDoc -> SDoc
 265 pprCode cs d = withPprStyle (PprCode cs) d
 266
 267 mkCodeStyle :: CodeStyle -> PprStyle
 268 mkCodeStyle = PprCode
 269
 270 -- Can't make SDoc an instance of Show because SDoc is just a function type
 271 -- However, Doc *is* an instance of Show
 272 -- showSDoc just blasts it out as a string
 273 showSDoc :: SDoc -> String
 274 showSDoc d = show (d defaultUserStyle)
 275
 276 showSDocForUser :: PrintUnqualified -> SDoc -> String
 277 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
 278
 279 showSDocUnqual :: SDoc -> String
 280 -- Only used in the gruesome HsExpr.isOperator
 281 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 282
 283 showsPrecSDoc :: Int -> SDoc -> ShowS
 284 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 285
 286 showSDocDump :: SDoc -> String
 287 showSDocDump d = show (d PprDump)
 288
 289 showSDocDebug :: SDoc -> String
 290 showSDocDebug d = show (d PprDebug)
 291 \end{code}
 292
 293 \begin{code}
 294 docToSDoc :: Doc -> SDoc
 295 docToSDoc d = \_ -> d
 296
 297 empty sty      = Pretty.empty
 298 text s sty     = Pretty.text s
 299 char c sty     = Pretty.char c
 300 ftext s sty    = Pretty.ftext s
 301 ptext s sty    = Pretty.ptext s
 302 int n sty      = Pretty.int n
 303 integer n sty  = Pretty.integer n
 304 float n sty    = Pretty.float n
 305 double n sty   = Pretty.double n
 306 rational n sty = Pretty.rational n
 307
 308 parens d sty       = Pretty.parens (d sty)
 309 braces d sty       = Pretty.braces (d sty)
 310 brackets d sty     = Pretty.brackets (d sty)
 311 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 312 angleBrackets d    = char '<' <> d <> char '>'
 313
 314 -- quotes encloses something in single quotes...
 315 -- but it omits them if the thing ends in a single quote
 316 -- so that we don't get `foo''.  Instead we just have foo'.
 317 quotes d sty = case show pp_d of
 318                  ('\'' : _) -> pp_d
 319                  other      -> Pretty.quotes pp_d
 320              where
 321                pp_d = d sty
 322
 323 semi sty   = Pretty.semi
 324 comma sty  = Pretty.comma
 325 colon sty  = Pretty.colon
 326 equals sty = Pretty.equals
 327 space sty  = Pretty.space
 328 lparen sty = Pretty.lparen
 329 rparen sty = Pretty.rparen
 330 lbrack sty = Pretty.lbrack
 331 rbrack sty = Pretty.rbrack
 332 lbrace sty = Pretty.lbrace
 333 rbrace sty = Pretty.rbrace
 334 dcolon sty = Pretty.ptext SLIT("::")
 335 arrow  sty = Pretty.ptext SLIT("->")
 336 underscore = char '_'
 337 dot        = char '.'
 338
 339 nest n d sty    = Pretty.nest n (d sty)
 340 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 341 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 342 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 343 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 344
 345 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 346 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 347 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 348 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 349 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 350 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 351 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 352
 353 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 354
 355 punctuate :: SDoc -> [SDoc] -> [SDoc]
 356 punctuate p []     = []
 357 punctuate p (d:ds) = go d ds
 358                    where
 359                      go d [] = [d]
 360                      go d (e:es) = (d <> p) : go e es
 361 \end{code}
 362
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection[Outputable-class]{The @Outputable@ class}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 \begin{code}
 371 class Outputable a where
 372         ppr :: a -> SDoc
 373 \end{code}
 374
 375 \begin{code}
 376 instance Outputable Bool where
 377     ppr True  = ptext SLIT("True")
 378     ppr False = ptext SLIT("False")
 379
 380 instance Outputable Int where
 381    ppr n = int n
 382
 383 instance Outputable () where
 384    ppr _ = text "()"
 385
 386 instance (Outputable a) => Outputable [a] where
 387     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 388
 389 instance (Outputable a, Outputable b) => Outputable (a, b) where
 390     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 391
 392 instance Outputable a => Outputable (Maybe a) where
 393   ppr Nothing = ptext SLIT("Nothing")
 394   ppr (Just x) = ptext SLIT("Just") <+> ppr x
 395
 396 -- ToDo: may not be used
 397 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 398     ppr (x,y,z) =
 399       parens (sep [ppr x <> comma,
 400                    ppr y <> comma,
 401                    ppr z ])
 402
 403 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 404          Outputable (a, b, c, d) where
 405     ppr (x,y,z,w) =
 406       parens (sep [ppr x <> comma,
 407                    ppr y <> comma,
 408                    ppr z <> comma,
 409                    ppr w])
 410
 411 instance Outputable FastString where
 412     ppr fs = ftext fs           -- Prints an unadorned string,
 413                                 -- no double quotes or anything
 414
 415 instance Outputable PackageId where
 416    ppr pid = text (packageIdString pid)
 417 \end{code}
 418
 419
 420 %************************************************************************
 421 %*                                                                      *
 422 \subsection{The @OutputableBndr@ class}
 423 %*                                                                      *
 424 %************************************************************************
 425
 426 When we print a binder, we often want to print its type too.
 427 The @OutputableBndr@ class encapsulates this idea.
 428
 429 @BindingSite@ is used to tell the thing that prints binder what
 430 language construct is binding the identifier.  This can be used
 431 to decide how much info to print.
 432
 433 \begin{code}
 434 data BindingSite = LambdaBind | CaseBind | LetBind
 435
 436 class Outputable a => OutputableBndr a where
 437    pprBndr :: BindingSite -> a -> SDoc
 438    pprBndr b x = ppr x
 439 \end{code}
 440
 441
 442
 443 %************************************************************************
 444 %*                                                                      *
 445 \subsection{Random printing helpers}
 446 %*                                                                      *
 447 %************************************************************************
 448
 449 \begin{code}
 450 -- We have 31-bit Chars and will simply use Show instances
 451 -- of Char and String.
 452
 453 pprHsChar :: Char -> SDoc
 454 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 455             | otherwise      = text (show c)
 456
 457 pprHsString :: FastString -> SDoc
 458 pprHsString fs = text (show (unpackFS fs))
 459 \end{code}
 460
 461
 462 %************************************************************************
 463 %*                                                                      *
 464 \subsection{Other helper functions}
 465 %*                                                                      *
 466 %************************************************************************
 467
 468 \begin{code}
 469 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 470 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 471
 472 interppSP  :: Outputable a => [a] -> SDoc
 473 interppSP  xs = sep (map ppr xs)
 474
 475 interpp'SP :: Outputable a => [a] -> SDoc
 476 interpp'SP xs = sep (punctuate comma (map ppr xs))
 477
 478 pprQuotedList :: Outputable a => [a] -> SDoc
 479 -- [x,y,z]  ==>  `x', `y', `z'
 480 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 481 \end{code}
 482
 483
 484 %************************************************************************
 485 %*                                                                      *
 486 \subsection{Printing numbers verbally}
 487 %*                                                                      *
 488 %************************************************************************
 489
 490 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 491 ``first'' etc.
 492
 493 \begin{code}
 494 speakNth :: Int -> SDoc
 495 speakNth 1 = ptext SLIT("first")
 496 speakNth 2 = ptext SLIT("second")
 497 speakNth 3 = ptext SLIT("third")
 498 speakNth 4 = ptext SLIT("fourth")
 499 speakNth 5 = ptext SLIT("fifth")
 500 speakNth 6 = ptext SLIT("sixth")
 501 speakNth n = hcat [ int n, text suffix ]
 502   where
 503     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 504            | last_dig == 1 = "st"
 505            | last_dig == 2 = "nd"
 506            | last_dig == 3 = "rd"
 507            | otherwise     = "th"
 508
 509     last_dig = n `rem` 10
 510
 511 speakN :: Int -> SDoc
 512 speakN 0 = ptext SLIT("none")   -- E.g.  "he has none"
 513 speakN 1 = ptext SLIT("one")    -- E.g.  "he has one"
 514 speakN 2 = ptext SLIT("two")
 515 speakN 3 = ptext SLIT("three")
 516 speakN 4 = ptext SLIT("four")
 517 speakN 5 = ptext SLIT("five")
 518 speakN 6 = ptext SLIT("six")
 519 speakN n = int n
 520
 521 speakNOf :: Int -> SDoc -> SDoc
 522 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's'       -- E.g. "no arguments"
 523 speakNOf 1 d = ptext SLIT("one") <+> d                  -- E.g. "one argument"
 524 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 525
 526 speakNTimes :: Int {- >=1 -} -> SDoc
 527 speakNTimes t | t == 1     = ptext SLIT("once")
 528               | t == 2     = ptext SLIT("twice")
 529               | otherwise  = speakN t <+> ptext SLIT("times")
 530
 531 plural [x] = empty
 532 plural xs  = char 's'
 533 \end{code}
 534
 535
 536 %************************************************************************
 537 %*                                                                      *
 538 \subsection{Error handling}
 539 %*                                                                      *
 540 %************************************************************************
 541
 542 \begin{code}
 543 pprPanic, pprPgmError :: String -> SDoc -> a
 544 pprTrace :: String -> SDoc -> a -> a
 545 pprPanic    = pprAndThen panic          -- Throw an exn saying "bug in GHC"
 546
 547 pprPgmError = pprAndThen pgmError       -- Throw an exn saying "bug in pgm being compiled"
 548                                         --      (used for unusual pgm errors)
 549 pprTrace    = pprAndThen trace
 550
 551 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 552                              where
 553                                doc = text heading <+> pretty_msg
 554
 555 pprAndThen :: (String -> a) -> String -> SDoc -> a
 556 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 557     where
 558      doc = sep [text heading, nest 4 pretty_msg]
 559
 560 assertPprPanic :: String -> Int -> SDoc -> a
 561 assertPprPanic file line msg
 562   = panic (show (doc PprDebug))
 563   where
 564     doc = sep [hsep[text "ASSERT failed! file",
 565                            text file,
 566                            text "line", int line],
 567                     msg]
 568
 569 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 570 warnPprTrace False file line msg x = x
 571 warnPprTrace True  file line msg x
 572   = trace (show (doc PprDebug)) x
 573   where
 574     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 575                msg]
 576 \end{code}