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