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(..), PrintUnqualified, alwaysQualify,
  18         getPprStyle, withPprStyle, pprDeeper,
  19         codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
  20         ifPprDebug, unqualStyle,
  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, showSDocUnqual, 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 {-# SOURCE #-}   Name( Name )
  53
  54 import IO               ( Handle, hPutChar, hPutStr, stderr, stdout )
  55 import CmdLineOpts      ( opt_PprStyle_Debug, opt_PprUserLength )
  56 import FastString
  57 import qualified Pretty
  58 import Pretty           ( Doc, Mode(..), TextDetails(..), fullRender )
  59 import Panic
  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 showSDocUnqual :: SDoc -> String
 210 -- Only used in the gruesome HsExpr.isOperator
 211 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 212
 213 showsPrecSDoc :: Int -> SDoc -> ShowS
 214 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 215
 216 showSDocIface :: SDoc -> String
 217 showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify))
 218
 219 showSDocDebug :: SDoc -> String
 220 showSDocDebug d = show (d PprDebug)
 221 \end{code}
 222
 223 \begin{code}
 224 empty sty      = Pretty.empty
 225 text s sty     = Pretty.text s
 226 char c sty     = Pretty.char c
 227 ptext s sty    = Pretty.ptext s
 228 int n sty      = Pretty.int n
 229 integer n sty  = Pretty.integer n
 230 float n sty    = Pretty.float n
 231 double n sty   = Pretty.double n
 232 rational n sty = Pretty.rational n
 233
 234 parens d sty       = Pretty.parens (d sty)
 235 braces d sty       = Pretty.braces (d sty)
 236 brackets d sty     = Pretty.brackets (d sty)
 237 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 238 angleBrackets d    = char '<' <> d <> char '>'
 239
 240 -- quotes encloses something in single quotes...
 241 -- but it omits them if the thing ends in a single quote
 242 -- so that we don't get `foo''.  Instead we just have foo'.
 243 quotes d sty = case show pp_d of
 244                  ('\'' : _) -> pp_d
 245                  other      -> Pretty.quotes pp_d
 246              where
 247                pp_d = d sty
 248
 249 semi sty   = Pretty.semi
 250 comma sty  = Pretty.comma
 251 colon sty  = Pretty.colon
 252 equals sty = Pretty.equals
 253 space sty  = Pretty.space
 254 lparen sty = Pretty.lparen
 255 rparen sty = Pretty.rparen
 256 lbrack sty = Pretty.lbrack
 257 rbrack sty = Pretty.rbrack
 258 lbrace sty = Pretty.lbrace
 259 rbrace sty = Pretty.rbrace
 260 dcolon sty = Pretty.ptext SLIT("::")
 261 underscore = char '_'
 262 dot        = char '.'
 263
 264 nest n d sty    = Pretty.nest n (d sty)
 265 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 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
 270 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 271 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 272 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 273 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 274 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 275 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 276 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 277
 278 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 279
 280 punctuate :: SDoc -> [SDoc] -> [SDoc]
 281 punctuate p []     = []
 282 punctuate p (d:ds) = go d ds
 283                    where
 284                      go d [] = [d]
 285                      go d (e:es) = (d <> p) : go e es
 286 \end{code}
 287
 288
 289 %************************************************************************
 290 %*                                                                      *
 291 \subsection[Outputable-class]{The @Outputable@ class}
 292 %*                                                                      *
 293 %************************************************************************
 294
 295 \begin{code}
 296 class Outputable a where
 297         ppr :: a -> SDoc
 298 \end{code}
 299
 300 \begin{code}
 301 instance Outputable Bool where
 302     ppr True  = ptext SLIT("True")
 303     ppr False = ptext SLIT("False")
 304
 305 instance Outputable Int where
 306    ppr n = int n
 307
 308 instance Outputable () where
 309    ppr _ = text "()"
 310
 311 instance (Outputable a) => Outputable [a] where
 312     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 313
 314 instance (Outputable a, Outputable b) => Outputable (a, b) where
 315     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 316
 317 instance Outputable a => Outputable (Maybe a) where
 318   ppr Nothing = ptext SLIT("Nothing")
 319   ppr (Just x) = ptext SLIT("Just") <+> ppr x
 320
 321 -- ToDo: may not be used
 322 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 323     ppr (x,y,z) =
 324       parens (sep [ppr x <> comma,
 325                    ppr y <> comma,
 326                    ppr z ])
 327
 328 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 329          Outputable (a, b, c, d) where
 330     ppr (x,y,z,w) =
 331       parens (sep [ppr x <> comma,
 332                    ppr y <> comma,
 333                    ppr z <> comma,
 334                    ppr w])
 335
 336 instance Outputable FastString where
 337     ppr fs = text (unpackFS fs)         -- Prints an unadorned string,
 338                                         -- no double quotes or anything
 339
 340 #if __GLASGOW_HASKELL__ < 410
 341 -- Assume we have only 8-bit Chars.
 342
 343 pprHsChar :: Int -> SDoc
 344 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
 345
 346 pprHsString :: FAST_STRING -> SDoc
 347 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs)))
 348
 349 showCharLit :: Int -> String -> String
 350 showCharLit c rest
 351     | c == ord '\"' = "\\\"" ++ rest
 352     | c == ord '\'' = "\\\'" ++ rest
 353     | c == ord '\\' = "\\\\" ++ rest
 354     | c >= 0x20 && c <= 0x7E = chr c : rest
 355     | c == ord '\a' = "\\a" ++ rest
 356     | c == ord '\b' = "\\b" ++ rest
 357     | c == ord '\f' = "\\f" ++ rest
 358     | c == ord '\n' = "\\n" ++ rest
 359     | c == ord '\r' = "\\r" ++ rest
 360     | c == ord '\t' = "\\t" ++ rest
 361     | c == ord '\v' = "\\v" ++ rest
 362     | otherwise     = ('\\':) $ shows c $ case rest of
 363         d:_ | isDigit d -> "\\&" ++ rest
 364         _               -> rest
 365
 366 #else
 367 -- We have 31-bit Chars and will simply use Show instances
 368 -- of Char and String.
 369
 370 pprHsChar :: Int -> SDoc
 371 pprHsChar c = text (show (chr c))
 372
 373 pprHsString :: FastString -> SDoc
 374 pprHsString fs = text (show (unpackFS fs))
 375
 376 #endif
 377
 378 instance Show FastString  where
 379     showsPrec p fs = showsPrecSDoc p (ppr fs)
 380 \end{code}
 381
 382
 383 %************************************************************************
 384 %*                                                                      *
 385 \subsection{Other helper functions}
 386 %*                                                                      *
 387 %************************************************************************
 388
 389 \begin{code}
 390 pprCols = (100 :: Int) -- could make configurable
 391
 392 printDoc :: Mode -> Handle -> Doc -> IO ()
 393 printDoc mode hdl doc
 394   = fullRender mode pprCols 1.5 put done doc
 395   where
 396     put (Chr c)  next = hPutChar hdl c >> next
 397     put (Str s)  next = hPutStr  hdl s >> next
 398     put (PStr s) next = hPutFS   hdl s >> next
 399
 400     done = hPutChar hdl '\n'
 401
 402 showDocWith :: Mode -> Doc -> String
 403 showDocWith mode doc
 404   = fullRender mode 100 1.5 put "" doc
 405   where
 406     put (Chr c)   s  = c:s
 407     put (Str s1)  s2 = s1 ++ s2
 408     put (PStr s1) s2 = _UNPK_ s1 ++ s2
 409 \end{code}
 410
 411
 412 \begin{code}
 413 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 414 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
 415
 416 interppSP  :: Outputable a => [a] -> SDoc
 417 interppSP  xs = hsep (map ppr xs)
 418
 419 interpp'SP :: Outputable a => [a] -> SDoc
 420 interpp'SP xs = hsep (punctuate comma (map ppr xs))
 421
 422 pprQuotedList :: Outputable a => [a] -> SDoc
 423 -- [x,y,z]  ==>  `x', `y', `z'
 424 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 425 \end{code}
 426
 427
 428 %************************************************************************
 429 %*                                                                      *
 430 \subsection{Printing numbers verbally}
 431 %*                                                                      *
 432 %************************************************************************
 433
 434 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 435 ``first'' etc.
 436
 437 \begin{code}
 438 speakNth :: Int -> SDoc
 439
 440 speakNth 1 = ptext SLIT("first")
 441 speakNth 2 = ptext SLIT("second")
 442 speakNth 3 = ptext SLIT("third")
 443 speakNth 4 = ptext SLIT("fourth")
 444 speakNth 5 = ptext SLIT("fifth")
 445 speakNth 6 = ptext SLIT("sixth")
 446 speakNth n = hcat [ int n, text st_nd_rd_th ]
 447   where
 448     st_nd_rd_th | n_rem_10 == 1 = "st"
 449                 | n_rem_10 == 2 = "nd"
 450                 | n_rem_10 == 3 = "rd"
 451                 | otherwise     = "th"
 452
 453     n_rem_10 = n `rem` 10
 454 \end{code}
 455
 456 \begin{code}
 457 speakNTimes :: Int {- >=1 -} -> SDoc
 458 speakNTimes t | t == 1     = ptext SLIT("once")
 459               | t == 2     = ptext SLIT("twice")
 460               | otherwise  = int t <+> ptext SLIT("times")
 461 \end{code}
 462
 463
 464 %************************************************************************
 465 %*                                                                      *
 466 \subsection{Error handling}
 467 %*                                                                      *
 468 %************************************************************************
 469
 470 \begin{code}
 471 pprPanic :: String -> SDoc -> a
 472 pprError :: String -> SDoc -> a
 473 pprTrace :: String -> SDoc -> a -> a
 474 pprPanic  = pprAndThen panic
 475 pprError  = pprAndThen error
 476 pprTrace  = pprAndThen trace
 477
 478 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 479                              where
 480                                doc = text heading <+> pretty_msg
 481
 482 pprAndThen :: (String -> a) -> String -> SDoc -> a
 483 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 484     where
 485      doc = sep [text heading, nest 4 pretty_msg]
 486
 487 assertPprPanic :: String -> Int -> SDoc -> a
 488 assertPprPanic file line msg
 489   = panic (show (doc PprDebug))
 490   where
 491     doc = sep [hsep[text "ASSERT failed! file",
 492                            text file,
 493                            text "line", int line],
 494                     msg]
 495
 496 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 497 warnPprTrace False file line msg x = x
 498 warnPprTrace True  file line msg x
 499   = trace (show (doc PprDebug)) x
 500   where
 501     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 502                msg]
 503 \end{code}