compiler/utils/Outputable.lhs

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