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 {-# OPTIONS -fno-prune-tydecls #-}
  11 -- Hopefully temporary; 3.02 complained about not being able
  12 -- to see the consructors for ForeignObj
  13
  14 module Outputable (
  15         Outputable(..),                 -- Class
  16
  17         PprStyle, CodeStyle(..),
  18         getPprStyle, withPprStyle, pprDeeper,
  19         codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
  20         ifPprDebug, ifNotPprForUser,
  21
  22         SDoc,           -- Abstract
  23         interppSP, interpp'SP, pprQuotedList, pprWithCommas,
  24         empty, nest,
  25         text, char, ptext,
  26         int, integer, float, double, rational,
  27         parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
  28         semi, comma, colon, dcolon, space, equals, dot,
  29         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
  30         (<>), (<+>), hcat, hsep,
  31         ($$), ($+$), vcat,
  32         sep, cat,
  33         fsep, fcat,
  34         hang, punctuate,
  35         speakNth, speakNTimes,
  36
  37         printSDoc, printErrs, printDump,
  38         printForC, printForAsm, printForIface, printForUser,
  39         pprCode, pprCols,
  40         showSDoc, showSDocDebug, showSDocIface, showsPrecSDoc,
  41         pprHsChar, pprHsString,
  42
  43
  44         -- error handling
  45         pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
  46         trace, panic, panic#, assertPanic
  47     ) where
  48
  49 #include "HsVersions.h"
  50
  51
  52 import IO               ( Handle, hPutChar, hPutStr, stderr, stdout )
  53 import CmdLineOpts      ( opt_PprStyle_Debug, opt_PprUserLength )
  54 import FastString
  55 import qualified Pretty
  56 import Pretty           ( Doc, Mode(..), TextDetails(..), fullRender )
  57 import Panic
  58 import ST               ( runST )
  59 import Foreign
  60 import Char             ( chr, ord, isDigit )
  61 \end{code}
  62
  63
  64 %************************************************************************
  65 %*                                                                      *
  66 \subsection{The @PprStyle@ data type}
  67 %*                                                                      *
  68 %************************************************************************
  69
  70 \begin{code}
  71 data PprStyle
  72   = PprUser Depth               -- Pretty-print in a way that will
  73                                 -- make sense to the ordinary user;
  74                                 -- must be very close to Haskell
  75                                 -- syntax, etc.
  76
  77   | PprDebug                    -- Standard debugging output
  78
  79   | PprInterface                -- Interface generation
  80
  81   | PprCode CodeStyle           -- Print code; either C or assembler
  82
  83
  84 data CodeStyle = CStyle         -- The format of labels differs for C and assembler
  85                | AsmStyle
  86
  87 data Depth = AllTheWay
  88            | PartWay Int        -- 0 => stop
  89 \end{code}
  90
  91 Orthogonal to the above printing styles are (possibly) some
  92 command-line flags that affect printing (often carried with the
  93 style).  The most likely ones are variations on how much type info is
  94 shown.
  95
  96 The following test decides whether or not we are actually generating
  97 code (either C or assembly), or generating interface files.
  98
  99 %************************************************************************
 100 %*                                                                      *
 101 \subsection{The @SDoc@ data type}
 102 %*                                                                      *
 103 %************************************************************************
 104
 105 \begin{code}
 106 type SDoc = PprStyle -> Doc
 107
 108 withPprStyle :: PprStyle -> SDoc -> SDoc
 109 withPprStyle sty d sty' = d sty
 110
 111 pprDeeper :: SDoc -> SDoc
 112 pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
 113 pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
 114 pprDeeper d other_sty             = d other_sty
 115
 116 getPprStyle :: (PprStyle -> SDoc) -> SDoc
 117 getPprStyle df sty = df sty sty
 118 \end{code}
 119
 120 \begin{code}
 121 codeStyle :: PprStyle -> Bool
 122 codeStyle (PprCode _)     = True
 123 codeStyle _               = False
 124
 125 asmStyle :: PprStyle -> Bool
 126 asmStyle (PprCode AsmStyle)  = True
 127 asmStyle other               = False
 128
 129 ifaceStyle :: PprStyle -> Bool
 130 ifaceStyle PprInterface   = True
 131 ifaceStyle other          = False
 132
 133 debugStyle :: PprStyle -> Bool
 134 debugStyle PprDebug       = True
 135 debugStyle other          = False
 136
 137 userStyle ::  PprStyle -> Bool
 138 userStyle (PprUser _) = True
 139 userStyle other       = False
 140 \end{code}
 141
 142 \begin{code}
 143 ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style
 144 ifNotPprForUser d sty@(PprUser _) = Pretty.empty
 145 ifNotPprForUser d sty             = d sty
 146
 147 ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
 148 ifPprDebug d sty@PprDebug = d sty
 149 ifPprDebug d sty          = Pretty.empty
 150 \end{code}
 151
 152 \begin{code}
 153 printSDoc :: SDoc -> PprStyle -> IO ()
 154 printSDoc d sty = printDoc PageMode stdout (d sty)
 155
 156 -- I'm not sure whether the direct-IO approach of printDoc
 157 -- above is better or worse than the put-big-string approach here
 158 printErrs :: SDoc -> IO ()
 159 printErrs doc = printDoc PageMode stderr (final_doc user_style)
 160               where
 161                 final_doc = doc         -- $$ text ""
 162                 user_style = mkUserStyle (PartWay opt_PprUserLength)
 163
 164 printDump :: SDoc -> IO ()
 165 printDump doc = printForUser stdout (doc $$ text "")
 166                 -- We used to always print in debug style, but I want
 167                 -- to try the effect of a more user-ish style (unless you
 168                 -- say -dppr-debug
 169
 170 printForUser :: Handle -> SDoc -> IO ()
 171 printForUser handle doc = printDoc PageMode handle (doc (mkUserStyle AllTheWay))
 172
 173 -- printForC, printForAsm do what they sound like
 174 printForC :: Handle -> SDoc -> IO ()
 175 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
 176
 177 printForAsm :: Handle -> SDoc -> IO ()
 178 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
 179
 180 -- printForIface prints all on one line for interface files.
 181 -- It's called repeatedly for successive lines
 182 printForIface :: Handle -> SDoc -> IO ()
 183 printForIface handle doc = printDoc LeftMode handle (doc PprInterface)
 184
 185 pprCode :: CodeStyle -> SDoc -> SDoc
 186 pprCode cs d = withPprStyle (PprCode cs) d
 187
 188 -- Can't make SDoc an instance of Show because SDoc is just a function type
 189 -- However, Doc *is* an instance of Show
 190 -- showSDoc just blasts it out as a string
 191 showSDoc :: SDoc -> String
 192 showSDoc d = show (d (mkUserStyle AllTheWay))
 193
 194 showSDocIface :: SDoc -> String
 195 showSDocIface doc = showDocWith OneLineMode (doc PprInterface)
 196
 197 showSDocDebug :: SDoc -> String
 198 showSDocDebug d = show (d PprDebug)
 199
 200 showsPrecSDoc :: Int -> SDoc -> ShowS
 201 showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
 202
 203 mkUserStyle depth |  opt_PprStyle_Debug = PprDebug
 204                   |  otherwise          = PprUser depth
 205 \end{code}
 206
 207 \begin{code}
 208 empty sty      = Pretty.empty
 209 text s sty     = Pretty.text s
 210 char c sty     = Pretty.char c
 211 ptext s sty    = Pretty.ptext s
 212 int n sty      = Pretty.int n
 213 integer n sty  = Pretty.integer n
 214 float n sty    = Pretty.float n
 215 double n sty   = Pretty.double n
 216 rational n sty = Pretty.rational n
 217
 218 parens d sty       = Pretty.parens (d sty)
 219 braces d sty       = Pretty.braces (d sty)
 220 brackets d sty     = Pretty.brackets (d sty)
 221 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 222 angleBrackets d    = char '<' <> d <> char '>'
 223
 224 -- quotes encloses something in single quotes...
 225 -- but it omits them if the thing ends in a single quote
 226 -- so that we don't get `foo''.  Instead we just have foo'.
 227 quotes d sty = case show pp_d of
 228                  ('\'' : _) -> pp_d
 229                  other      -> Pretty.quotes pp_d
 230              where
 231                pp_d = d sty
 232
 233 semi sty   = Pretty.semi
 234 comma sty  = Pretty.comma
 235 colon sty  = Pretty.colon
 236 equals sty = Pretty.equals
 237 space sty  = Pretty.space
 238 lparen sty = Pretty.lparen
 239 rparen sty = Pretty.rparen
 240 lbrack sty = Pretty.lbrack
 241 rbrack sty = Pretty.rbrack
 242 lbrace sty = Pretty.lbrace
 243 rbrace sty = Pretty.rbrace
 244 dcolon sty = Pretty.ptext SLIT("::")
 245 underscore = char '_'
 246 dot        = char '.'
 247
 248 nest n d sty    = Pretty.nest n (d sty)
 249 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 250 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 251 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 252 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 253
 254 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 255 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 256 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 257 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 258 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 259 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 260 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 261
 262 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 263
 264 punctuate :: SDoc -> [SDoc] -> [SDoc]
 265 punctuate p []     = []
 266 punctuate p (d:ds) = go d ds
 267                    where
 268                      go d [] = [d]
 269                      go d (e:es) = (d <> p) : go e es
 270 \end{code}
 271
 272
 273 %************************************************************************
 274 %*                                                                      *
 275 \subsection[Outputable-class]{The @Outputable@ class}
 276 %*                                                                      *
 277 %************************************************************************
 278
 279 \begin{code}
 280 class Outputable a where
 281         ppr :: a -> SDoc
 282 \end{code}
 283
 284 \begin{code}
 285 instance Outputable Bool where
 286     ppr True  = ptext SLIT("True")
 287     ppr False = ptext SLIT("False")
 288
 289 instance Outputable Int where
 290    ppr n = int n
 291
 292 instance (Outputable a) => Outputable [a] where
 293     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 294
 295 instance (Outputable a, Outputable b) => Outputable (a, b) where
 296     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 297
 298 instance Outputable a => Outputable (Maybe a) where
 299   ppr Nothing = text "Nothing"
 300   ppr (Just x) = text "Just" <+> ppr x
 301
 302 -- ToDo: may not be used
 303 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 304     ppr (x,y,z) =
 305       parens (sep [ppr x <> comma,
 306                    ppr y <> comma,
 307                    ppr z ])
 308
 309 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 310          Outputable (a, b, c, d) where
 311     ppr (x,y,z,w) =
 312       parens (sep [ppr x <> comma,
 313                    ppr y <> comma,
 314                    ppr z <> comma,
 315                    ppr w])
 316
 317 instance Outputable FastString where
 318     ppr fs = text (unpackFS fs)         -- Prints an unadorned string,
 319                                         -- no double quotes or anything
 320
 321 #if __GLASGOW_HASKELL__ < 410
 322 -- Assume we have only 8-bit Chars.
 323
 324 pprHsChar :: Int -> SDoc
 325 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
 326
 327 pprHsString :: FAST_STRING -> SDoc
 328 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs)))
 329
 330 showCharLit :: Int -> String -> String
 331 showCharLit c rest
 332     | c == ord '\"' = "\\\"" ++ rest
 333     | c == ord '\'' = "\\\'" ++ rest
 334     | c == ord '\\' = "\\\\" ++ rest
 335     | c >= 0x20 && c <= 0x7E = chr c : rest
 336     | c == ord '\a' = "\\a" ++ rest
 337     | c == ord '\b' = "\\b" ++ rest
 338     | c == ord '\f' = "\\f" ++ rest
 339     | c == ord '\n' = "\\n" ++ rest
 340     | c == ord '\r' = "\\r" ++ rest
 341     | c == ord '\t' = "\\t" ++ rest
 342     | c == ord '\v' = "\\v" ++ rest
 343     | otherwise     = ('\\':) $ shows c $ case rest of
 344         d:_ | isDigit d -> "\\&" ++ rest
 345         _               -> rest
 346
 347 #else
 348 -- We have 31-bit Chars and will simply use Show instances
 349 -- of Char and String.
 350
 351 pprHsChar :: Int -> SDoc
 352 pprHsChar c = text (show (chr c))
 353
 354 pprHsString :: FastString -> SDoc
 355 pprHsString fs = text (show (unpackFS fs))
 356
 357 #endif
 358
 359 instance Show FastString  where
 360     showsPrec p fs = showsPrecSDoc p (ppr fs)
 361 \end{code}
 362
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection{Other helper functions}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 \begin{code}
 371 pprCols = (100 :: Int) -- could make configurable
 372
 373 printDoc :: Mode -> Handle -> Doc -> IO ()
 374 printDoc mode hdl doc
 375   = fullRender mode pprCols 1.5 put done doc
 376   where
 377     put (Chr c)  next = hPutChar hdl c >> next
 378     put (Str s)  next = hPutStr  hdl s >> next
 379     put (PStr s) next = hPutFS   hdl s >> next
 380
 381     done = hPutChar hdl '\n'
 382
 383 showDocWith :: Mode -> Doc -> String
 384 showDocWith mode doc
 385   = fullRender mode 100 1.5 put "" doc
 386   where
 387     put (Chr c)   s  = c:s
 388     put (Str s1)  s2 = s1 ++ s2
 389     put (PStr s1) s2 = _UNPK_ s1 ++ s2
 390 \end{code}
 391
 392
 393 \begin{code}
 394 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 395 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
 396
 397 interppSP  :: Outputable a => [a] -> SDoc
 398 interppSP  xs = hsep (map ppr xs)
 399
 400 interpp'SP :: Outputable a => [a] -> SDoc
 401 interpp'SP xs = hsep (punctuate comma (map ppr xs))
 402
 403 pprQuotedList :: Outputable a => [a] -> SDoc
 404 -- [x,y,z]  ==>  `x', `y', `z'
 405 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 406 \end{code}
 407
 408
 409 %************************************************************************
 410 %*                                                                      *
 411 \subsection{Printing numbers verbally}
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 416 ``first'' etc.
 417
 418 \begin{code}
 419 speakNth :: Int -> SDoc
 420
 421 speakNth 1 = ptext SLIT("first")
 422 speakNth 2 = ptext SLIT("second")
 423 speakNth 3 = ptext SLIT("third")
 424 speakNth 4 = ptext SLIT("fourth")
 425 speakNth 5 = ptext SLIT("fifth")
 426 speakNth 6 = ptext SLIT("sixth")
 427 speakNth n = hcat [ int n, text st_nd_rd_th ]
 428   where
 429     st_nd_rd_th | n_rem_10 == 1 = "st"
 430                 | n_rem_10 == 2 = "nd"
 431                 | n_rem_10 == 3 = "rd"
 432                 | otherwise     = "th"
 433
 434     n_rem_10 = n `rem` 10
 435 \end{code}
 436
 437 \begin{code}
 438 speakNTimes :: Int {- >=1 -} -> SDoc
 439 speakNTimes t | t == 1     = ptext SLIT("once")
 440               | t == 2     = ptext SLIT("twice")
 441               | otherwise  = int t <+> ptext SLIT("times")
 442 \end{code}
 443
 444
 445 %************************************************************************
 446 %*                                                                      *
 447 \subsection{Error handling}
 448 %*                                                                      *
 449 %************************************************************************
 450
 451 \begin{code}
 452 pprPanic :: String -> SDoc -> a
 453 pprError :: String -> SDoc -> a
 454 pprTrace :: String -> SDoc -> a -> a
 455 pprPanic  = pprAndThen panic
 456 pprError  = pprAndThen error
 457 pprTrace  = pprAndThen trace
 458
 459 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 460                              where
 461                                doc = text heading <+> pretty_msg
 462
 463 pprAndThen :: (String -> a) -> String -> SDoc -> a
 464 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 465     where
 466      doc = sep [text heading, nest 4 pretty_msg]
 467
 468 assertPprPanic :: String -> Int -> SDoc -> a
 469 assertPprPanic file line msg
 470   = panic (show (doc PprDebug))
 471   where
 472     doc = sep [hsep[text "ASSERT failed! file",
 473                            text file,
 474                            text "line", int line],
 475                     msg]
 476
 477 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 478 warnPprTrace False file line msg x = x
 479 warnPprTrace True  file line msg x
 480   = trace (show (doc PprDebug)) x
 481   where
 482     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 483                msg]
 484 \end{code}