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