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