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, 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 = do
 262    Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
 263    hFlush stdout
 264  where
 265    better_doc = doc $$ text ""
 266
 267 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 268 printForUser handle unqual doc
 269   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 270
 271 -- printForC, printForAsm do what they sound like
 272 printForC :: Handle -> SDoc -> IO ()
 273 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
 274
 275 printForAsm :: Handle -> SDoc -> IO ()
 276 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
 277
 278 pprCode :: CodeStyle -> SDoc -> SDoc
 279 pprCode cs d = withPprStyle (PprCode cs) d
 280
 281 mkCodeStyle :: CodeStyle -> PprStyle
 282 mkCodeStyle = PprCode
 283
 284 -- Can't make SDoc an instance of Show because SDoc is just a function type
 285 -- However, Doc *is* an instance of Show
 286 -- showSDoc just blasts it out as a string
 287 showSDoc :: SDoc -> String
 288 showSDoc d = show (d defaultUserStyle)
 289
 290 showSDocForUser :: PrintUnqualified -> SDoc -> String
 291 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
 292
 293 showSDocUnqual :: SDoc -> String
 294 -- Only used in the gruesome HsExpr.isOperator
 295 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 296
 297 showsPrecSDoc :: Int -> SDoc -> ShowS
 298 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 299
 300 showSDocDump :: SDoc -> String
 301 showSDocDump d = show (d PprDump)
 302
 303 showSDocDebug :: SDoc -> String
 304 showSDocDebug d = show (d PprDebug)
 305 \end{code}
 306
 307 \begin{code}
 308 docToSDoc :: Doc -> SDoc
 309 docToSDoc d = \_ -> d
 310
 311 empty sty      = Pretty.empty
 312 text s sty     = Pretty.text s
 313 char c sty     = Pretty.char c
 314 ftext s sty    = Pretty.ftext s
 315 ptext s sty    = Pretty.ptext s
 316 int n sty      = Pretty.int n
 317 integer n sty  = Pretty.integer n
 318 float n sty    = Pretty.float n
 319 double n sty   = Pretty.double n
 320 rational n sty = Pretty.rational n
 321
 322 parens d sty       = Pretty.parens (d sty)
 323 braces d sty       = Pretty.braces (d sty)
 324 brackets d sty     = Pretty.brackets (d sty)
 325 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 326 angleBrackets d    = char '<' <> d <> char '>'
 327
 328 cparen b d sty       = Pretty.cparen b (d sty)
 329
 330 -- quotes encloses something in single quotes...
 331 -- but it omits them if the thing ends in a single quote
 332 -- so that we don't get `foo''.  Instead we just have foo'.
 333 quotes d sty = case show pp_d of
 334                  ('\'' : _) -> pp_d
 335                  other      -> Pretty.quotes pp_d
 336              where
 337                pp_d = d sty
 338
 339 semi sty   = Pretty.semi
 340 comma sty  = Pretty.comma
 341 colon sty  = Pretty.colon
 342 equals sty = Pretty.equals
 343 space sty  = Pretty.space
 344 lparen sty = Pretty.lparen
 345 rparen sty = Pretty.rparen
 346 lbrack sty = Pretty.lbrack
 347 rbrack sty = Pretty.rbrack
 348 lbrace sty = Pretty.lbrace
 349 rbrace sty = Pretty.rbrace
 350 dcolon sty = Pretty.ptext SLIT("::")
 351 arrow  sty = Pretty.ptext SLIT("->")
 352 underscore = char '_'
 353 dot        = char '.'
 354
 355 nest n d sty    = Pretty.nest n (d sty)
 356 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 357 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 358 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 359 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 360
 361 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 362 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 363 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 364 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 365 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 366 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 367 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 368
 369 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 370
 371 punctuate :: SDoc -> [SDoc] -> [SDoc]
 372 punctuate p []     = []
 373 punctuate p (d:ds) = go d ds
 374                    where
 375                      go d [] = [d]
 376                      go d (e:es) = (d <> p) : go e es
 377 \end{code}
 378
 379
 380 %************************************************************************
 381 %*                                                                      *
 382 \subsection[Outputable-class]{The @Outputable@ class}
 383 %*                                                                      *
 384 %************************************************************************
 385
 386 \begin{code}
 387 class Outputable a where
 388         ppr :: a -> SDoc
 389 \end{code}
 390
 391 \begin{code}
 392 instance Outputable Bool where
 393     ppr True  = ptext SLIT("True")
 394     ppr False = ptext SLIT("False")
 395
 396 instance Outputable Int where
 397    ppr n = int n
 398
 399 instance Outputable () where
 400    ppr _ = text "()"
 401
 402 instance (Outputable a) => Outputable [a] where
 403     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 404
 405 instance (Outputable a, Outputable b) => Outputable (a, b) where
 406     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 407
 408 instance Outputable a => Outputable (Maybe a) where
 409   ppr Nothing = ptext SLIT("Nothing")
 410   ppr (Just x) = ptext SLIT("Just") <+> ppr x
 411
 412 instance (Outputable a, Outputable b) => Outputable (Either a b) where
 413   ppr (Left x)  = ptext SLIT("Left")  <+> ppr x
 414   ppr (Right y) = ptext SLIT("Right") <+> ppr y
 415
 416 -- ToDo: may not be used
 417 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 418     ppr (x,y,z) =
 419       parens (sep [ppr x <> comma,
 420                    ppr y <> comma,
 421                    ppr z ])
 422
 423 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 424          Outputable (a, b, c, d) where
 425     ppr (x,y,z,w) =
 426       parens (sep [ppr x <> comma,
 427                    ppr y <> comma,
 428                    ppr z <> comma,
 429                    ppr w])
 430
 431 instance Outputable FastString where
 432     ppr fs = ftext fs           -- Prints an unadorned string,
 433                                 -- no double quotes or anything
 434
 435 instance Outputable PackageId where
 436    ppr pid = text (packageIdString pid)
 437 \end{code}
 438
 439
 440 %************************************************************************
 441 %*                                                                      *
 442 \subsection{The @OutputableBndr@ class}
 443 %*                                                                      *
 444 %************************************************************************
 445
 446 When we print a binder, we often want to print its type too.
 447 The @OutputableBndr@ class encapsulates this idea.
 448
 449 @BindingSite@ is used to tell the thing that prints binder what
 450 language construct is binding the identifier.  This can be used
 451 to decide how much info to print.
 452
 453 \begin{code}
 454 data BindingSite = LambdaBind | CaseBind | LetBind
 455
 456 class Outputable a => OutputableBndr a where
 457    pprBndr :: BindingSite -> a -> SDoc
 458    pprBndr b x = ppr x
 459 \end{code}
 460
 461
 462
 463 %************************************************************************
 464 %*                                                                      *
 465 \subsection{Random printing helpers}
 466 %*                                                                      *
 467 %************************************************************************
 468
 469 \begin{code}
 470 -- We have 31-bit Chars and will simply use Show instances
 471 -- of Char and String.
 472
 473 pprHsChar :: Char -> SDoc
 474 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 475             | otherwise      = text (show c)
 476
 477 pprHsString :: FastString -> SDoc
 478 pprHsString fs = text (show (unpackFS fs))
 479 \end{code}
 480
 481
 482 %************************************************************************
 483 %*                                                                      *
 484 \subsection{Other helper functions}
 485 %*                                                                      *
 486 %************************************************************************
 487
 488 \begin{code}
 489 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 490 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 491
 492 interppSP  :: Outputable a => [a] -> SDoc
 493 interppSP  xs = sep (map ppr xs)
 494
 495 interpp'SP :: Outputable a => [a] -> SDoc
 496 interpp'SP xs = sep (punctuate comma (map ppr xs))
 497
 498 pprQuotedList :: Outputable a => [a] -> SDoc
 499 -- [x,y,z]  ==>  `x', `y', `z'
 500 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 501 \end{code}
 502
 503
 504 %************************************************************************
 505 %*                                                                      *
 506 \subsection{Printing numbers verbally}
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 511 ``first'' etc.
 512
 513 \begin{code}
 514 speakNth :: Int -> SDoc
 515 speakNth 1 = ptext SLIT("first")
 516 speakNth 2 = ptext SLIT("second")
 517 speakNth 3 = ptext SLIT("third")
 518 speakNth 4 = ptext SLIT("fourth")
 519 speakNth 5 = ptext SLIT("fifth")
 520 speakNth 6 = ptext SLIT("sixth")
 521 speakNth n = hcat [ int n, text suffix ]
 522   where
 523     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 524            | last_dig == 1 = "st"
 525            | last_dig == 2 = "nd"
 526            | last_dig == 3 = "rd"
 527            | otherwise     = "th"
 528
 529     last_dig = n `rem` 10
 530
 531 speakN :: Int -> SDoc
 532 speakN 0 = ptext SLIT("none")   -- E.g.  "he has none"
 533 speakN 1 = ptext SLIT("one")    -- E.g.  "he has one"
 534 speakN 2 = ptext SLIT("two")
 535 speakN 3 = ptext SLIT("three")
 536 speakN 4 = ptext SLIT("four")
 537 speakN 5 = ptext SLIT("five")
 538 speakN 6 = ptext SLIT("six")
 539 speakN n = int n
 540
 541 speakNOf :: Int -> SDoc -> SDoc
 542 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's'       -- E.g. "no arguments"
 543 speakNOf 1 d = ptext SLIT("one") <+> d                  -- E.g. "one argument"
 544 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 545
 546 speakNTimes :: Int {- >=1 -} -> SDoc
 547 speakNTimes t | t == 1     = ptext SLIT("once")
 548               | t == 2     = ptext SLIT("twice")
 549               | otherwise  = speakN t <+> ptext SLIT("times")
 550
 551 plural [x] = empty
 552 plural xs  = char 's'
 553 \end{code}
 554
 555
 556 %************************************************************************
 557 %*                                                                      *
 558 \subsection{Error handling}
 559 %*                                                                      *
 560 %************************************************************************
 561
 562 \begin{code}
 563 pprPanic, pprPgmError :: String -> SDoc -> a
 564 pprTrace :: String -> SDoc -> a -> a
 565 pprPanic    = pprAndThen panic          -- Throw an exn saying "bug in GHC"
 566
 567 pprPgmError = pprAndThen pgmError       -- Throw an exn saying "bug in pgm being compiled"
 568                                         --      (used for unusual pgm errors)
 569 pprTrace    = pprAndThen trace
 570
 571 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 572                              where
 573                                doc = text heading <+> pretty_msg
 574
 575 pprAndThen :: (String -> a) -> String -> SDoc -> a
 576 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 577     where
 578      doc = sep [text heading, nest 4 pretty_msg]
 579
 580 assertPprPanic :: String -> Int -> SDoc -> a
 581 assertPprPanic file line msg
 582   = panic (show (doc PprDebug))
 583   where
 584     doc = sep [hsep[text "ASSERT failed! file",
 585                            text file,
 586                            text "line", int line],
 587                     msg]
 588
 589 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 590 warnPprTrace False file line msg x = x
 591 warnPprTrace True  file line msg x
 592   = trace (show (doc PprDebug)) x
 593   where
 594     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 595                msg]
 596 \end{code}