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