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