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 stderr (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 FastString where
 309     ppr fs = text (unpackFS fs)         -- Prints an unadorned string,
 310                                         -- no double quotes or anything
 311
 312 pprFSAsString :: FastString -> SDoc                     -- The Char instance of Show prints
 313 pprFSAsString fs = text (showList (unpackFS fs) "")     -- strings with double quotes and escapes
 314
 315 instance Show FastString  where
 316     showsPrec p fs = showsPrecSDoc p (ppr fs)
 317 \end{code}
 318
 319
 320 %************************************************************************
 321 %*                                                                      *
 322 \subsection{Other helper functions}
 323 %*                                                                      *
 324 %************************************************************************
 325
 326 \begin{code}
 327 pprCols = (100 :: Int) -- could make configurable
 328
 329 printDoc :: Mode -> Handle -> Doc -> IO ()
 330 printDoc mode hdl doc
 331   = fullRender mode pprCols 1.5 put done doc
 332   where
 333     put (Chr c)  next = hPutChar hdl c >> next
 334     put (Str s)  next = hPutStr  hdl s >> next
 335     put (PStr s) next = hPutFS   hdl s >> next
 336
 337     done = hPutChar hdl '\n'
 338
 339 showDocWith :: Mode -> Doc -> String
 340 showDocWith mode doc
 341   = fullRender PageMode 100 1.5 put "" doc
 342   where
 343     put (Chr c)   s  = c:s
 344     put (Str s1)  s2 = s1 ++ s2
 345     put (PStr s1) s2 = _UNPK_ s1 ++ s2
 346 \end{code}
 347
 348
 349 \begin{code}
 350 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 351 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
 352
 353 interppSP  :: Outputable a => [a] -> SDoc
 354 interppSP  xs = hsep (map ppr xs)
 355
 356 interpp'SP :: Outputable a => [a] -> SDoc
 357 interpp'SP xs = hsep (punctuate comma (map ppr xs))
 358
 359 pprQuotedList :: Outputable a => [a] -> SDoc
 360 -- [x,y,z]  ==>  `x', `y', `z'
 361 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 362 \end{code}
 363
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection{Printing numbers verbally}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 372 ``first'' etc.
 373
 374 \begin{code}
 375 speakNth :: Int -> SDoc
 376
 377 speakNth 1 = ptext SLIT("first")
 378 speakNth 2 = ptext SLIT("second")
 379 speakNth 3 = ptext SLIT("third")
 380 speakNth 4 = ptext SLIT("fourth")
 381 speakNth 5 = ptext SLIT("fifth")
 382 speakNth 6 = ptext SLIT("sixth")
 383 speakNth n = hcat [ int n, text st_nd_rd_th ]
 384   where
 385     st_nd_rd_th | n_rem_10 == 1 = "st"
 386                 | n_rem_10 == 2 = "nd"
 387                 | n_rem_10 == 3 = "rd"
 388                 | otherwise     = "th"
 389
 390     n_rem_10 = n `rem` 10
 391 \end{code}
 392
 393 \begin{code}
 394 speakNTimes :: Int {- >=1 -} -> SDoc
 395 speakNTimes t | t == 1     = ptext SLIT("once")
 396               | t == 2     = ptext SLIT("twice")
 397               | otherwise  = int t <+> ptext SLIT("times")
 398 \end{code}
 399
 400
 401 %************************************************************************
 402 %*                                                                      *
 403 \subsection{Error handling}
 404 %*                                                                      *
 405 %************************************************************************
 406
 407 \begin{code}
 408 pprPanic :: String -> SDoc -> a
 409 pprError :: String -> SDoc -> a
 410 pprTrace :: String -> SDoc -> a -> a
 411 pprPanic  = pprAndThen panic
 412 pprError  = pprAndThen error
 413 pprTrace  = pprAndThen trace
 414
 415 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 416                              where
 417                                doc = text heading <+> pretty_msg
 418
 419 pprAndThen :: (String -> a) -> String -> SDoc -> a
 420 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 421     where
 422      doc = sep [text heading, nest 4 pretty_msg]
 423
 424 assertPprPanic :: String -> Int -> SDoc -> a
 425 assertPprPanic file line msg
 426   = panic (show (doc PprDebug))
 427   where
 428     doc = sep [hsep[text "ASSERT failed! file",
 429                            text file,
 430                            text "line", int line],
 431                     msg]
 432
 433 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 434 warnPprTrace False file line msg x = x
 435 warnPprTrace True  file line msg x
 436   = trace (show (doc PprDebug)) x
 437   where
 438     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 439                msg]
 440 \end{code}