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