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 PprDebug)
 164               where
 165                 final_doc = doc $$ text ""
 166
 167
 168 -- printForC, printForAsm doe what they sound like
 169 printForC :: Handle -> SDoc -> IO ()
 170 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
 171
 172 printForAsm :: Handle -> SDoc -> IO ()
 173 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
 174
 175 -- printForIface prints all on one line for interface files.
 176 -- It's called repeatedly for successive lines
 177 printForIface :: Handle -> SDoc -> IO ()
 178 printForIface handle doc = printDoc OneLineMode handle (doc PprInterface)
 179
 180 pprCode :: CodeStyle -> SDoc -> SDoc
 181 pprCode cs d = withPprStyle (PprCode cs) d
 182
 183 -- Can't make SDoc an instance of Show because SDoc is just a function type
 184 -- However, Doc *is* an instance of Show
 185 -- showSDoc just blasts it out as a string
 186 showSDoc :: SDoc -> String
 187 showSDoc d = show (d (mkUserStyle AllTheWay))
 188
 189 showSDocDebug :: SDoc -> String
 190 showSDocDebug d = show (d PprDebug)
 191
 192 showsPrecSDoc :: Int -> SDoc -> ShowS
 193 showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
 194
 195 mkUserStyle depth |  opt_PprStyle_Debug = PprDebug
 196                   |  otherwise          = PprUser depth
 197 \end{code}
 198
 199 \begin{code}
 200 empty sty      = Pretty.empty
 201 text s sty     = Pretty.text s
 202 char c sty     = Pretty.char c
 203 ptext s sty    = Pretty.ptext s
 204 int n sty      = Pretty.int n
 205 integer n sty  = Pretty.integer n
 206 float n sty    = Pretty.float n
 207 double n sty   = Pretty.double n
 208 rational n sty = Pretty.rational n
 209
 210 parens d sty       = Pretty.parens (d sty)
 211 braces d sty       = Pretty.braces (d sty)
 212 brackets d sty     = Pretty.brackets (d sty)
 213 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 214
 215 -- quotes encloses something in single quotes...
 216 -- but it omits them if the thing ends in a single quote
 217 -- so that we don't get `foo''.  Instead we just have foo'.
 218 quotes d sty = case show pp_d of
 219                  ('\'' : _) -> pp_d
 220                  other      -> Pretty.quotes pp_d
 221              where
 222                pp_d = d sty
 223
 224 semi sty   = Pretty.semi
 225 comma sty  = Pretty.comma
 226 colon sty  = Pretty.colon
 227 equals sty = Pretty.equals
 228 space sty  = Pretty.space
 229 lparen sty = Pretty.lparen
 230 rparen sty = Pretty.rparen
 231 lbrack sty = Pretty.lbrack
 232 rbrack sty = Pretty.rbrack
 233 lbrace sty = Pretty.lbrace
 234 rbrace sty = Pretty.rbrace
 235 dcolon sty = Pretty.ptext SLIT("::")
 236 underscore = char '_'
 237 dot        = char '.'
 238
 239 nest n d sty    = Pretty.nest n (d sty)
 240 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 241 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 242 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 243 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 244
 245 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 246 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 247 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 248 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 249 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 250 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 251 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 252
 253 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 254
 255 punctuate :: SDoc -> [SDoc] -> [SDoc]
 256 punctuate p []     = []
 257 punctuate p (d:ds) = go d ds
 258                    where
 259                      go d [] = [d]
 260                      go d (e:es) = (d <> p) : go e es
 261 \end{code}
 262
 263
 264 %************************************************************************
 265 %*                                                                      *
 266 \subsection[Outputable-class]{The @Outputable@ class}
 267 %*                                                                      *
 268 %************************************************************************
 269
 270 \begin{code}
 271 class Outputable a where
 272         ppr :: a -> SDoc
 273 \end{code}
 274
 275 \begin{code}
 276 instance Outputable Bool where
 277     ppr True  = ptext SLIT("True")
 278     ppr False = ptext SLIT("False")
 279
 280 instance Outputable Int where
 281    ppr n = int n
 282
 283 instance (Outputable a) => Outputable [a] where
 284     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 285
 286 instance (Outputable a, Outputable b) => Outputable (a, b) where
 287     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 288
 289 instance Outputable a => Outputable (Maybe a) where
 290   ppr Nothing = text "Nothing"
 291   ppr (Just x) = text "Just" <+> ppr x
 292
 293 -- ToDo: may not be used
 294 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 295     ppr (x,y,z) =
 296       parens (sep [ppr x <> comma,
 297                    ppr y <> comma,
 298                    ppr z ])
 299
 300 instance Outputable FastString where
 301     ppr fs = text (unpackFS fs)         -- Prints an unadorned string,
 302                                         -- no double quotes or anything
 303
 304 pprFSAsString :: FastString -> SDoc                     -- The Char instance of Show prints
 305 pprFSAsString fs = text (showList (unpackFS fs) "")     -- strings with double quotes and escapes
 306
 307 instance Show FastString  where
 308     showsPrec p fs = showsPrecSDoc p (ppr fs)
 309 \end{code}
 310
 311
 312 %************************************************************************
 313 %*                                                                      *
 314 \subsection{Other helper functions}
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 \begin{code}
 319 pprCols = (100 :: Int) -- could make configurable
 320
 321 printDoc :: Mode -> Handle -> Doc -> IO ()
 322 printDoc mode hdl doc
 323   = fullRender mode pprCols 1.5 put done doc
 324   where
 325     put (Chr c)  next = hPutChar hdl c >> next
 326     put (Str s)  next = hPutStr  hdl s >> next
 327     put (PStr s) next = hPutFS   hdl s >> next
 328
 329     done = hPutChar hdl '\n'
 330 \end{code}
 331
 332
 333 \begin{code}
 334 interppSP  :: Outputable a => [a] -> SDoc
 335 interppSP  xs = hsep (map ppr xs)
 336
 337 interpp'SP :: Outputable a => [a] -> SDoc
 338 interpp'SP xs = hsep (punctuate comma (map ppr xs))
 339
 340 pprQuotedList :: Outputable a => [a] -> SDoc
 341 -- [x,y,z]  ==>  `x', `y', `z'
 342 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 343 \end{code}
 344
 345
 346 %************************************************************************
 347 %*                                                                      *
 348 \subsection{Printing numbers verbally}
 349 %*                                                                      *
 350 %************************************************************************
 351
 352 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 353 ``first'' etc.
 354
 355 \begin{code}
 356 speakNth :: Int -> SDoc
 357
 358 speakNth 1 = ptext SLIT("first")
 359 speakNth 2 = ptext SLIT("second")
 360 speakNth 3 = ptext SLIT("third")
 361 speakNth 4 = ptext SLIT("fourth")
 362 speakNth 5 = ptext SLIT("fifth")
 363 speakNth 6 = ptext SLIT("sixth")
 364 speakNth n = hcat [ int n, text st_nd_rd_th ]
 365   where
 366     st_nd_rd_th | n_rem_10 == 1 = "st"
 367                 | n_rem_10 == 2 = "nd"
 368                 | n_rem_10 == 3 = "rd"
 369                 | otherwise     = "th"
 370
 371     n_rem_10 = n `rem` 10
 372 \end{code}
 373
 374 \begin{code}
 375 speakNTimes :: Int {- >=1 -} -> SDoc
 376 speakNTimes t | t == 1     = ptext SLIT("once")
 377               | t == 2     = ptext SLIT("twice")
 378               | otherwise  = int t <+> ptext SLIT("times")
 379 \end{code}
 380
 381
 382 %************************************************************************
 383 %*                                                                      *
 384 \subsection{Error handling}
 385 %*                                                                      *
 386 %************************************************************************
 387
 388 \begin{code}
 389 pprPanic :: String -> SDoc -> a
 390 pprError :: String -> SDoc -> a
 391 pprTrace :: String -> SDoc -> a -> a
 392 pprPanic  = pprAndThen panic
 393 pprError  = pprAndThen error
 394 pprTrace  = pprAndThen trace
 395
 396 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 397                              where
 398                                doc = text heading <+> pretty_msg
 399
 400 pprAndThen :: (String -> a) -> String -> SDoc -> a
 401 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 402     where
 403      doc = sep [text heading, nest 4 pretty_msg]
 404
 405 assertPprPanic :: String -> Int -> SDoc -> a
 406 assertPprPanic file line msg
 407   = panic (show (doc PprDebug))
 408   where
 409     doc = sep [hsep[text "ASSERT failed! file",
 410                            text file,
 411                            text "line", int line],
 412                     msg]
 413
 414 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 415 warnPprTrace False file line msg x = x
 416 warnPprTrace True  file line msg x
 417   = trace (show (doc PprDebug)) x
 418   where
 419     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 420                msg]
 421 \end{code}