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