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