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