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