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