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