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