ghc/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,
  18         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
  19         ifPprDebug, unqualStyle,
  20         mkErrStyle, defaultErrStyle,
  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,
  37
  38         printSDoc, printErrs, printDump,
  39         printForC, printForAsm, printForUser,
  40         pprCode, mkCodeStyle,
  41         showSDoc, showSDocForUser, showSDocDebug,
  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 CmdLineOpts      ( 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 getPprStyle :: (PprStyle -> SDoc) -> SDoc
 160 getPprStyle df sty = df sty sty
 161 \end{code}
 162
 163 \begin{code}
 164 unqualStyle :: PprStyle -> PrintUnqualified
 165 unqualStyle (PprUser    unqual _) m n = unqual m n
 166 unqualStyle other                 m n = False
 167
 168 codeStyle :: PprStyle -> Bool
 169 codeStyle (PprCode _)     = True
 170 codeStyle _               = False
 171
 172 asmStyle :: PprStyle -> Bool
 173 asmStyle (PprCode AsmStyle)  = True
 174 asmStyle other               = False
 175
 176 dumpStyle :: PprStyle -> Bool
 177 dumpStyle PprDump = True
 178 dumpStyle other   = False
 179
 180 debugStyle :: PprStyle -> Bool
 181 debugStyle PprDebug       = True
 182 debugStyle other          = False
 183
 184 userStyle ::  PprStyle -> Bool
 185 userStyle (PprUser _ _) = True
 186 userStyle other         = False
 187
 188 ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
 189 ifPprDebug d sty@PprDebug = d sty
 190 ifPprDebug d sty          = Pretty.empty
 191 \end{code}
 192
 193 \begin{code}
 194 -- Unused [7/02 sof]
 195 printSDoc :: SDoc -> PprStyle -> IO ()
 196 printSDoc d sty = do
 197   Pretty.printDoc PageMode stdout (d sty)
 198   hFlush stdout
 199
 200 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
 201 -- above is better or worse than the put-big-string approach here
 202 printErrs :: Doc -> IO ()
 203 printErrs doc = do Pretty.printDoc PageMode stderr doc
 204                    hFlush stderr
 205
 206 printDump :: SDoc -> IO ()
 207 printDump doc = do
 208    Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
 209    hFlush stdout
 210  where
 211    better_doc = doc $$ text ""
 212     -- We used to always print in debug style, but I want
 213     -- to try the effect of a more user-ish style (unless you
 214     -- say -dppr-debug)
 215
 216 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 217 printForUser handle unqual doc
 218   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 219
 220 -- printForC, printForAsm do what they sound like
 221 printForC :: Handle -> SDoc -> IO ()
 222 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
 223
 224 printForAsm :: Handle -> SDoc -> IO ()
 225 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
 226
 227 pprCode :: CodeStyle -> SDoc -> SDoc
 228 pprCode cs d = withPprStyle (PprCode cs) d
 229
 230 mkCodeStyle :: CodeStyle -> PprStyle
 231 mkCodeStyle = PprCode
 232
 233 -- Can't make SDoc an instance of Show because SDoc is just a function type
 234 -- However, Doc *is* an instance of Show
 235 -- showSDoc just blasts it out as a string
 236 showSDoc :: SDoc -> String
 237 showSDoc d = show (d defaultUserStyle)
 238
 239 showSDocForUser :: PrintUnqualified -> SDoc -> String
 240 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
 241
 242 showSDocUnqual :: SDoc -> String
 243 -- Only used in the gruesome HsExpr.isOperator
 244 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 245
 246 showsPrecSDoc :: Int -> SDoc -> ShowS
 247 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 248
 249 showSDocDebug :: SDoc -> String
 250 showSDocDebug d = show (d PprDebug)
 251 \end{code}
 252
 253 \begin{code}
 254 docToSDoc :: Doc -> SDoc
 255 docToSDoc d = \_ -> d
 256
 257 empty sty      = Pretty.empty
 258 text s sty     = Pretty.text s
 259 char c sty     = Pretty.char c
 260 ftext s sty    = Pretty.ftext s
 261 ptext s sty    = Pretty.ptext s
 262 int n sty      = Pretty.int n
 263 integer n sty  = Pretty.integer n
 264 float n sty    = Pretty.float n
 265 double n sty   = Pretty.double n
 266 rational n sty = Pretty.rational n
 267
 268 parens d sty       = Pretty.parens (d sty)
 269 braces d sty       = Pretty.braces (d sty)
 270 brackets d sty     = Pretty.brackets (d sty)
 271 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 272 angleBrackets d    = char '<' <> d <> char '>'
 273
 274 -- quotes encloses something in single quotes...
 275 -- but it omits them if the thing ends in a single quote
 276 -- so that we don't get `foo''.  Instead we just have foo'.
 277 quotes d sty = case show pp_d of
 278                  ('\'' : _) -> pp_d
 279                  other      -> Pretty.quotes pp_d
 280              where
 281                pp_d = d sty
 282
 283 semi sty   = Pretty.semi
 284 comma sty  = Pretty.comma
 285 colon sty  = Pretty.colon
 286 equals sty = Pretty.equals
 287 space sty  = Pretty.space
 288 lparen sty = Pretty.lparen
 289 rparen sty = Pretty.rparen
 290 lbrack sty = Pretty.lbrack
 291 rbrack sty = Pretty.rbrack
 292 lbrace sty = Pretty.lbrace
 293 rbrace sty = Pretty.rbrace
 294 dcolon sty = Pretty.ptext SLIT("::")
 295 arrow  sty = Pretty.ptext SLIT("->")
 296 underscore = char '_'
 297 dot        = char '.'
 298
 299 nest n d sty    = Pretty.nest n (d sty)
 300 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 301 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 302 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 303 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 304
 305 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 306 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 307 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 308 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 309 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 310 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 311 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 312
 313 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 314
 315 punctuate :: SDoc -> [SDoc] -> [SDoc]
 316 punctuate p []     = []
 317 punctuate p (d:ds) = go d ds
 318                    where
 319                      go d [] = [d]
 320                      go d (e:es) = (d <> p) : go e es
 321 \end{code}
 322
 323
 324 %************************************************************************
 325 %*                                                                      *
 326 \subsection[Outputable-class]{The @Outputable@ class}
 327 %*                                                                      *
 328 %************************************************************************
 329
 330 \begin{code}
 331 class Outputable a where
 332         ppr :: a -> SDoc
 333 \end{code}
 334
 335 \begin{code}
 336 instance Outputable Bool where
 337     ppr True  = ptext SLIT("True")
 338     ppr False = ptext SLIT("False")
 339
 340 instance Outputable Int where
 341    ppr n = int n
 342
 343 instance Outputable () where
 344    ppr _ = text "()"
 345
 346 instance (Outputable a) => Outputable [a] where
 347     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 348
 349 instance (Outputable a, Outputable b) => Outputable (a, b) where
 350     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 351
 352 instance Outputable a => Outputable (Maybe a) where
 353   ppr Nothing = ptext SLIT("Nothing")
 354   ppr (Just x) = ptext SLIT("Just") <+> ppr x
 355
 356 -- ToDo: may not be used
 357 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 358     ppr (x,y,z) =
 359       parens (sep [ppr x <> comma,
 360                    ppr y <> comma,
 361                    ppr z ])
 362
 363 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 364          Outputable (a, b, c, d) where
 365     ppr (x,y,z,w) =
 366       parens (sep [ppr x <> comma,
 367                    ppr y <> comma,
 368                    ppr z <> comma,
 369                    ppr w])
 370
 371 instance Outputable FastString where
 372     ppr fs = text (unpackFS fs)         -- Prints an unadorned string,
 373                                         -- no double quotes or anything
 374
 375 instance Outputable PackageId where
 376    ppr pid = text (packageIdString pid)
 377 \end{code}
 378
 379
 380 %************************************************************************
 381 %*                                                                      *
 382 \subsection{The @OutputableBndr@ class}
 383 %*                                                                      *
 384 %************************************************************************
 385
 386 When we print a binder, we often want to print its type too.
 387 The @OutputableBndr@ class encapsulates this idea.
 388
 389 @BindingSite@ is used to tell the thing that prints binder what
 390 language construct is binding the identifier.  This can be used
 391 to decide how much info to print.
 392
 393 \begin{code}
 394 data BindingSite = LambdaBind | CaseBind | LetBind
 395
 396 class Outputable a => OutputableBndr a where
 397    pprBndr :: BindingSite -> a -> SDoc
 398    pprBndr b x = ppr x
 399 \end{code}
 400
 401
 402
 403 %************************************************************************
 404 %*                                                                      *
 405 \subsection{Random printing helpers}
 406 %*                                                                      *
 407 %************************************************************************
 408
 409 \begin{code}
 410 -- We have 31-bit Chars and will simply use Show instances
 411 -- of Char and String.
 412
 413 pprHsChar :: Char -> SDoc
 414 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 415             | otherwise      = text (show c)
 416
 417 pprHsString :: FastString -> SDoc
 418 pprHsString fs = text (show (unpackFS fs))
 419
 420 instance Show FastString  where
 421     showsPrec p fs = showsPrecSDoc p (ppr fs)
 422 \end{code}
 423
 424
 425 %************************************************************************
 426 %*                                                                      *
 427 \subsection{Other helper functions}
 428 %*                                                                      *
 429 %************************************************************************
 430
 431 \begin{code}
 432 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 433 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 434
 435 interppSP  :: Outputable a => [a] -> SDoc
 436 interppSP  xs = sep (map ppr xs)
 437
 438 interpp'SP :: Outputable a => [a] -> SDoc
 439 interpp'SP xs = sep (punctuate comma (map ppr xs))
 440
 441 pprQuotedList :: Outputable a => [a] -> SDoc
 442 -- [x,y,z]  ==>  `x', `y', `z'
 443 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 444 \end{code}
 445
 446
 447 %************************************************************************
 448 %*                                                                      *
 449 \subsection{Printing numbers verbally}
 450 %*                                                                      *
 451 %************************************************************************
 452
 453 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 454 ``first'' etc.
 455
 456 \begin{code}
 457 speakNth :: Int -> SDoc
 458
 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 \end{code}
 475
 476 \begin{code}
 477 speakNTimes :: Int {- >=1 -} -> SDoc
 478 speakNTimes t | t == 1     = ptext SLIT("once")
 479               | t == 2     = ptext SLIT("twice")
 480               | otherwise  = int t <+> ptext SLIT("times")
 481 \end{code}
 482
 483
 484 %************************************************************************
 485 %*                                                                      *
 486 \subsection{Error handling}
 487 %*                                                                      *
 488 %************************************************************************
 489
 490 \begin{code}
 491 pprPanic, pprPgmError :: String -> SDoc -> a
 492 pprTrace :: String -> SDoc -> a -> a
 493 pprPanic    = pprAndThen panic          -- Throw an exn saying "bug in GHC"
 494
 495 pprPgmError = pprAndThen pgmError       -- Throw an exn saying "bug in pgm being compiled"
 496                                         --      (used for unusual pgm errors)
 497 pprTrace    = pprAndThen trace
 498
 499 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 500                              where
 501                                doc = text heading <+> pretty_msg
 502
 503 pprAndThen :: (String -> a) -> String -> SDoc -> a
 504 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 505     where
 506      doc = sep [text heading, nest 4 pretty_msg]
 507
 508 assertPprPanic :: String -> Int -> SDoc -> a
 509 assertPprPanic file line msg
 510   = panic (show (doc PprDebug))
 511   where
 512     doc = sep [hsep[text "ASSERT failed! file",
 513                            text file,
 514                            text "line", int line],
 515                     msg]
 516
 517 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 518 warnPprTrace False file line msg x = x
 519 warnPprTrace True  file line msg x
 520   = trace (show (doc PprDebug)) x
 521   where
 522     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 523                msg]
 524 \end{code}