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 -- ToDo: may not be used
 413 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 414     ppr (x,y,z) =
 415       parens (sep [ppr x <> comma,
 416                    ppr y <> comma,
 417                    ppr z ])
 418
 419 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 420          Outputable (a, b, c, d) where
 421     ppr (x,y,z,w) =
 422       parens (sep [ppr x <> comma,
 423                    ppr y <> comma,
 424                    ppr z <> comma,
 425                    ppr w])
 426
 427 instance Outputable FastString where
 428     ppr fs = ftext fs           -- Prints an unadorned string,
 429                                 -- no double quotes or anything
 430
 431 instance Outputable PackageId where
 432    ppr pid = text (packageIdString pid)
 433 \end{code}
 434
 435
 436 %************************************************************************
 437 %*                                                                      *
 438 \subsection{The @OutputableBndr@ class}
 439 %*                                                                      *
 440 %************************************************************************
 441
 442 When we print a binder, we often want to print its type too.
 443 The @OutputableBndr@ class encapsulates this idea.
 444
 445 @BindingSite@ is used to tell the thing that prints binder what
 446 language construct is binding the identifier.  This can be used
 447 to decide how much info to print.
 448
 449 \begin{code}
 450 data BindingSite = LambdaBind | CaseBind | LetBind
 451
 452 class Outputable a => OutputableBndr a where
 453    pprBndr :: BindingSite -> a -> SDoc
 454    pprBndr b x = ppr x
 455 \end{code}
 456
 457
 458
 459 %************************************************************************
 460 %*                                                                      *
 461 \subsection{Random printing helpers}
 462 %*                                                                      *
 463 %************************************************************************
 464
 465 \begin{code}
 466 -- We have 31-bit Chars and will simply use Show instances
 467 -- of Char and String.
 468
 469 pprHsChar :: Char -> SDoc
 470 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 471             | otherwise      = text (show c)
 472
 473 pprHsString :: FastString -> SDoc
 474 pprHsString fs = text (show (unpackFS fs))
 475 \end{code}
 476
 477
 478 %************************************************************************
 479 %*                                                                      *
 480 \subsection{Other helper functions}
 481 %*                                                                      *
 482 %************************************************************************
 483
 484 \begin{code}
 485 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 486 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 487
 488 interppSP  :: Outputable a => [a] -> SDoc
 489 interppSP  xs = sep (map ppr xs)
 490
 491 interpp'SP :: Outputable a => [a] -> SDoc
 492 interpp'SP xs = sep (punctuate comma (map ppr xs))
 493
 494 pprQuotedList :: Outputable a => [a] -> SDoc
 495 -- [x,y,z]  ==>  `x', `y', `z'
 496 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 497 \end{code}
 498
 499
 500 %************************************************************************
 501 %*                                                                      *
 502 \subsection{Printing numbers verbally}
 503 %*                                                                      *
 504 %************************************************************************
 505
 506 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 507 ``first'' etc.
 508
 509 \begin{code}
 510 speakNth :: Int -> SDoc
 511 speakNth 1 = ptext SLIT("first")
 512 speakNth 2 = ptext SLIT("second")
 513 speakNth 3 = ptext SLIT("third")
 514 speakNth 4 = ptext SLIT("fourth")
 515 speakNth 5 = ptext SLIT("fifth")
 516 speakNth 6 = ptext SLIT("sixth")
 517 speakNth n = hcat [ int n, text suffix ]
 518   where
 519     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 520            | last_dig == 1 = "st"
 521            | last_dig == 2 = "nd"
 522            | last_dig == 3 = "rd"
 523            | otherwise     = "th"
 524
 525     last_dig = n `rem` 10
 526
 527 speakN :: Int -> SDoc
 528 speakN 0 = ptext SLIT("none")   -- E.g.  "he has none"
 529 speakN 1 = ptext SLIT("one")    -- E.g.  "he has one"
 530 speakN 2 = ptext SLIT("two")
 531 speakN 3 = ptext SLIT("three")
 532 speakN 4 = ptext SLIT("four")
 533 speakN 5 = ptext SLIT("five")
 534 speakN 6 = ptext SLIT("six")
 535 speakN n = int n
 536
 537 speakNOf :: Int -> SDoc -> SDoc
 538 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's'       -- E.g. "no arguments"
 539 speakNOf 1 d = ptext SLIT("one") <+> d                  -- E.g. "one argument"
 540 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 541
 542 speakNTimes :: Int {- >=1 -} -> SDoc
 543 speakNTimes t | t == 1     = ptext SLIT("once")
 544               | t == 2     = ptext SLIT("twice")
 545               | otherwise  = speakN t <+> ptext SLIT("times")
 546
 547 plural [x] = empty
 548 plural xs  = char 's'
 549 \end{code}
 550
 551
 552 %************************************************************************
 553 %*                                                                      *
 554 \subsection{Error handling}
 555 %*                                                                      *
 556 %************************************************************************
 557
 558 \begin{code}
 559 pprPanic, pprPgmError :: String -> SDoc -> a
 560 pprTrace :: String -> SDoc -> a -> a
 561 pprPanic    = pprAndThen panic          -- Throw an exn saying "bug in GHC"
 562
 563 pprPgmError = pprAndThen pgmError       -- Throw an exn saying "bug in pgm being compiled"
 564                                         --      (used for unusual pgm errors)
 565 pprTrace    = pprAndThen trace
 566
 567 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 568                              where
 569                                doc = text heading <+> pretty_msg
 570
 571 pprAndThen :: (String -> a) -> String -> SDoc -> a
 572 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 573     where
 574      doc = sep [text heading, nest 4 pretty_msg]
 575
 576 assertPprPanic :: String -> Int -> SDoc -> a
 577 assertPprPanic file line msg
 578   = panic (show (doc PprDebug))
 579   where
 580     doc = sep [hsep[text "ASSERT failed! file",
 581                            text file,
 582                            text "line", int line],
 583                     msg]
 584
 585 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 586 warnPprTrace False file line msg x = x
 587 warnPprTrace True  file line msg x
 588   = trace (show (doc PprDebug)) x
 589   where
 590     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 591                msg]
 592 \end{code}