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, 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, cparen, 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 import System.IO        ( Handle, stderr, stdout, hFlush )
  67 import Data.Char        ( ord )
  68 \end{code}
  69
  70
  71 %************************************************************************
  72 %*                                                                      *
  73 \subsection{The @PprStyle@ data type}
  74 %*                                                                      *
  75 %************************************************************************
  76
  77 \begin{code}
  78
  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 cparen b d sty       = Pretty.cparen b (d sty)
 315
 316 -- quotes encloses something in single quotes...
 317 -- but it omits them if the thing ends in a single quote
 318 -- so that we don't get `foo''.  Instead we just have foo'.
 319 quotes d sty = case show pp_d of
 320                  ('\'' : _) -> pp_d
 321                  other      -> Pretty.quotes pp_d
 322              where
 323                pp_d = d sty
 324
 325 semi sty   = Pretty.semi
 326 comma sty  = Pretty.comma
 327 colon sty  = Pretty.colon
 328 equals sty = Pretty.equals
 329 space sty  = Pretty.space
 330 lparen sty = Pretty.lparen
 331 rparen sty = Pretty.rparen
 332 lbrack sty = Pretty.lbrack
 333 rbrack sty = Pretty.rbrack
 334 lbrace sty = Pretty.lbrace
 335 rbrace sty = Pretty.rbrace
 336 dcolon sty = Pretty.ptext SLIT("::")
 337 arrow  sty = Pretty.ptext SLIT("->")
 338 underscore = char '_'
 339 dot        = char '.'
 340
 341 nest n d sty    = Pretty.nest n (d sty)
 342 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 343 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 344 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 345 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 346
 347 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 348 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 349 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 350 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 351 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 352 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 353 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 354
 355 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 356
 357 punctuate :: SDoc -> [SDoc] -> [SDoc]
 358 punctuate p []     = []
 359 punctuate p (d:ds) = go d ds
 360                    where
 361                      go d [] = [d]
 362                      go d (e:es) = (d <> p) : go e es
 363 \end{code}
 364
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 \subsection[Outputable-class]{The @Outputable@ class}
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 \begin{code}
 373 class Outputable a where
 374         ppr :: a -> SDoc
 375 \end{code}
 376
 377 \begin{code}
 378 instance Outputable Bool where
 379     ppr True  = ptext SLIT("True")
 380     ppr False = ptext SLIT("False")
 381
 382 instance Outputable Int where
 383    ppr n = int n
 384
 385 instance Outputable () where
 386    ppr _ = text "()"
 387
 388 instance (Outputable a) => Outputable [a] where
 389     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 390
 391 instance (Outputable a, Outputable b) => Outputable (a, b) where
 392     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 393
 394 instance Outputable a => Outputable (Maybe a) where
 395   ppr Nothing = ptext SLIT("Nothing")
 396   ppr (Just x) = ptext SLIT("Just") <+> ppr x
 397
 398 -- ToDo: may not be used
 399 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 400     ppr (x,y,z) =
 401       parens (sep [ppr x <> comma,
 402                    ppr y <> comma,
 403                    ppr z ])
 404
 405 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 406          Outputable (a, b, c, d) where
 407     ppr (x,y,z,w) =
 408       parens (sep [ppr x <> comma,
 409                    ppr y <> comma,
 410                    ppr z <> comma,
 411                    ppr w])
 412
 413 instance Outputable FastString where
 414     ppr fs = ftext fs           -- Prints an unadorned string,
 415                                 -- no double quotes or anything
 416
 417 instance Outputable PackageId where
 418    ppr pid = text (packageIdString pid)
 419 \end{code}
 420
 421
 422 %************************************************************************
 423 %*                                                                      *
 424 \subsection{The @OutputableBndr@ class}
 425 %*                                                                      *
 426 %************************************************************************
 427
 428 When we print a binder, we often want to print its type too.
 429 The @OutputableBndr@ class encapsulates this idea.
 430
 431 @BindingSite@ is used to tell the thing that prints binder what
 432 language construct is binding the identifier.  This can be used
 433 to decide how much info to print.
 434
 435 \begin{code}
 436 data BindingSite = LambdaBind | CaseBind | LetBind
 437
 438 class Outputable a => OutputableBndr a where
 439    pprBndr :: BindingSite -> a -> SDoc
 440    pprBndr b x = ppr x
 441 \end{code}
 442
 443
 444
 445 %************************************************************************
 446 %*                                                                      *
 447 \subsection{Random printing helpers}
 448 %*                                                                      *
 449 %************************************************************************
 450
 451 \begin{code}
 452 -- We have 31-bit Chars and will simply use Show instances
 453 -- of Char and String.
 454
 455 pprHsChar :: Char -> SDoc
 456 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 457             | otherwise      = text (show c)
 458
 459 pprHsString :: FastString -> SDoc
 460 pprHsString fs = text (show (unpackFS fs))
 461 \end{code}
 462
 463
 464 %************************************************************************
 465 %*                                                                      *
 466 \subsection{Other helper functions}
 467 %*                                                                      *
 468 %************************************************************************
 469
 470 \begin{code}
 471 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 472 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 473
 474 interppSP  :: Outputable a => [a] -> SDoc
 475 interppSP  xs = sep (map ppr xs)
 476
 477 interpp'SP :: Outputable a => [a] -> SDoc
 478 interpp'SP xs = sep (punctuate comma (map ppr xs))
 479
 480 pprQuotedList :: Outputable a => [a] -> SDoc
 481 -- [x,y,z]  ==>  `x', `y', `z'
 482 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 483 \end{code}
 484
 485
 486 %************************************************************************
 487 %*                                                                      *
 488 \subsection{Printing numbers verbally}
 489 %*                                                                      *
 490 %************************************************************************
 491
 492 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 493 ``first'' etc.
 494
 495 \begin{code}
 496 speakNth :: Int -> SDoc
 497 speakNth 1 = ptext SLIT("first")
 498 speakNth 2 = ptext SLIT("second")
 499 speakNth 3 = ptext SLIT("third")
 500 speakNth 4 = ptext SLIT("fourth")
 501 speakNth 5 = ptext SLIT("fifth")
 502 speakNth 6 = ptext SLIT("sixth")
 503 speakNth n = hcat [ int n, text suffix ]
 504   where
 505     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 506            | last_dig == 1 = "st"
 507            | last_dig == 2 = "nd"
 508            | last_dig == 3 = "rd"
 509            | otherwise     = "th"
 510
 511     last_dig = n `rem` 10
 512
 513 speakN :: Int -> SDoc
 514 speakN 0 = ptext SLIT("none")   -- E.g.  "he has none"
 515 speakN 1 = ptext SLIT("one")    -- E.g.  "he has one"
 516 speakN 2 = ptext SLIT("two")
 517 speakN 3 = ptext SLIT("three")
 518 speakN 4 = ptext SLIT("four")
 519 speakN 5 = ptext SLIT("five")
 520 speakN 6 = ptext SLIT("six")
 521 speakN n = int n
 522
 523 speakNOf :: Int -> SDoc -> SDoc
 524 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's'       -- E.g. "no arguments"
 525 speakNOf 1 d = ptext SLIT("one") <+> d                  -- E.g. "one argument"
 526 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 527
 528 speakNTimes :: Int {- >=1 -} -> SDoc
 529 speakNTimes t | t == 1     = ptext SLIT("once")
 530               | t == 2     = ptext SLIT("twice")
 531               | otherwise  = speakN t <+> ptext SLIT("times")
 532
 533 plural [x] = empty
 534 plural xs  = char 's'
 535 \end{code}
 536
 537
 538 %************************************************************************
 539 %*                                                                      *
 540 \subsection{Error handling}
 541 %*                                                                      *
 542 %************************************************************************
 543
 544 \begin{code}
 545 pprPanic, pprPgmError :: String -> SDoc -> a
 546 pprTrace :: String -> SDoc -> a -> a
 547 pprPanic    = pprAndThen panic          -- Throw an exn saying "bug in GHC"
 548
 549 pprPgmError = pprAndThen pgmError       -- Throw an exn saying "bug in pgm being compiled"
 550                                         --      (used for unusual pgm errors)
 551 pprTrace    = pprAndThen trace
 552
 553 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 554                              where
 555                                doc = text heading <+> pretty_msg
 556
 557 pprAndThen :: (String -> a) -> String -> SDoc -> a
 558 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 559     where
 560      doc = sep [text heading, nest 4 pretty_msg]
 561
 562 assertPprPanic :: String -> Int -> SDoc -> a
 563 assertPprPanic file line msg
 564   = panic (show (doc PprDebug))
 565   where
 566     doc = sep [hsep[text "ASSERT failed! file",
 567                            text file,
 568                            text "line", int line],
 569                     msg]
 570
 571 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 572 warnPprTrace False file line msg x = x
 573 warnPprTrace True  file line msg x
 574   = trace (show (doc PprDebug)) x
 575   where
 576     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 577                msg]
 578 \end{code}