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