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, userStyle, debugStyle, asmStyle,
  17         ifPprDebug, unqualStyle,
  18
  19         SDoc,           -- Abstract
  20         docToSDoc,
  21         interppSP, interpp'SP, pprQuotedList, pprWithCommas,
  22         empty, nest,
  23         text, char, ftext, 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, printForUser,
  37         pprCode, mkCodeStyle,
  38         showSDoc, showSDocForUser, showSDocDebug,
  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(..) )
  57 import Panic
  58
  59 import Word             ( Word32 )
  60 import IO               ( Handle, stderr, stdout, hFlush )
  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 debugStyle :: PprStyle -> Bool
 155 debugStyle PprDebug       = True
 156 debugStyle other          = False
 157
 158 userStyle ::  PprStyle -> Bool
 159 userStyle (PprUser _ _) = True
 160 userStyle other         = False
 161
 162 ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
 163 ifPprDebug d sty@PprDebug = d sty
 164 ifPprDebug d sty          = Pretty.empty
 165 \end{code}
 166
 167 \begin{code}
 168 -- Unused [7/02 sof]
 169 printSDoc :: SDoc -> PprStyle -> IO ()
 170 printSDoc d sty = do
 171   Pretty.printDoc PageMode stdout (d sty)
 172   hFlush stdout
 173
 174 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
 175 -- above is better or worse than the put-big-string approach here
 176 printErrs :: PrintUnqualified -> SDoc -> IO ()
 177 printErrs unqual doc = do
 178    Pretty.printDoc PageMode stderr (doc style)
 179    hFlush stderr
 180  where
 181    style = mkUserStyle unqual (PartWay opt_PprUserLength)
 182
 183 printDump :: SDoc -> IO ()
 184 printDump doc = do
 185    Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
 186    hFlush stdout
 187  where
 188    better_doc = doc $$ text ""
 189     -- We used to always print in debug style, but I want
 190     -- to try the effect of a more user-ish style (unless you
 191     -- say -dppr-debug
 192
 193 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 194 printForUser handle unqual doc
 195   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 196
 197 -- printForC, printForAsm do what they sound like
 198 printForC :: Handle -> SDoc -> IO ()
 199 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
 200
 201 printForAsm :: Handle -> SDoc -> IO ()
 202 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
 203
 204 pprCode :: CodeStyle -> SDoc -> SDoc
 205 pprCode cs d = withPprStyle (PprCode cs) d
 206
 207 mkCodeStyle :: CodeStyle -> PprStyle
 208 mkCodeStyle = PprCode
 209
 210 -- Can't make SDoc an instance of Show because SDoc is just a function type
 211 -- However, Doc *is* an instance of Show
 212 -- showSDoc just blasts it out as a string
 213 showSDoc :: SDoc -> String
 214 showSDoc d = show (d defaultUserStyle)
 215
 216 showSDocForUser :: PrintUnqualified -> SDoc -> String
 217 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
 218
 219 showSDocUnqual :: SDoc -> String
 220 -- Only used in the gruesome HsExpr.isOperator
 221 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 222
 223 showsPrecSDoc :: Int -> SDoc -> ShowS
 224 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 225
 226 showSDocDebug :: SDoc -> String
 227 showSDocDebug d = show (d PprDebug)
 228 \end{code}
 229
 230 \begin{code}
 231 docToSDoc :: Doc -> SDoc
 232 docToSDoc d = \_ -> d
 233
 234 empty sty      = Pretty.empty
 235 text s sty     = Pretty.text s
 236 char c sty     = Pretty.char c
 237 ftext s sty    = Pretty.ftext s
 238 ptext s sty    = Pretty.ptext s
 239 int n sty      = Pretty.int n
 240 integer n sty  = Pretty.integer n
 241 float n sty    = Pretty.float n
 242 double n sty   = Pretty.double n
 243 rational n sty = Pretty.rational n
 244
 245 parens d sty       = Pretty.parens (d sty)
 246 braces d sty       = Pretty.braces (d sty)
 247 brackets d sty     = Pretty.brackets (d sty)
 248 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 249 angleBrackets d    = char '<' <> d <> char '>'
 250
 251 -- quotes encloses something in single quotes...
 252 -- but it omits them if the thing ends in a single quote
 253 -- so that we don't get `foo''.  Instead we just have foo'.
 254 quotes d sty = case show pp_d of
 255                  ('\'' : _) -> pp_d
 256                  other      -> Pretty.quotes pp_d
 257              where
 258                pp_d = d sty
 259
 260 semi sty   = Pretty.semi
 261 comma sty  = Pretty.comma
 262 colon sty  = Pretty.colon
 263 equals sty = Pretty.equals
 264 space sty  = Pretty.space
 265 lparen sty = Pretty.lparen
 266 rparen sty = Pretty.rparen
 267 lbrack sty = Pretty.lbrack
 268 rbrack sty = Pretty.rbrack
 269 lbrace sty = Pretty.lbrace
 270 rbrace sty = Pretty.rbrace
 271 dcolon sty = Pretty.ptext SLIT("::")
 272 underscore = char '_'
 273 dot        = char '.'
 274
 275 nest n d sty    = Pretty.nest n (d sty)
 276 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 277 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 278 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 279 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 280
 281 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 282 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 283 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 284 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 285 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 286 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 287 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 288
 289 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 290
 291 punctuate :: SDoc -> [SDoc] -> [SDoc]
 292 punctuate p []     = []
 293 punctuate p (d:ds) = go d ds
 294                    where
 295                      go d [] = [d]
 296                      go d (e:es) = (d <> p) : go e es
 297 \end{code}
 298
 299
 300 %************************************************************************
 301 %*                                                                      *
 302 \subsection[Outputable-class]{The @Outputable@ class}
 303 %*                                                                      *
 304 %************************************************************************
 305
 306 \begin{code}
 307 class Outputable a where
 308         ppr :: a -> SDoc
 309 \end{code}
 310
 311 \begin{code}
 312 instance Outputable Bool where
 313     ppr True  = ptext SLIT("True")
 314     ppr False = ptext SLIT("False")
 315
 316 instance Outputable Int where
 317    ppr n = int n
 318
 319 instance Outputable () where
 320    ppr _ = text "()"
 321
 322 instance (Outputable a) => Outputable [a] where
 323     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 324
 325 instance (Outputable a, Outputable b) => Outputable (a, b) where
 326     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 327
 328 instance Outputable a => Outputable (Maybe a) where
 329   ppr Nothing = ptext SLIT("Nothing")
 330   ppr (Just x) = ptext SLIT("Just") <+> ppr x
 331
 332 -- ToDo: may not be used
 333 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 334     ppr (x,y,z) =
 335       parens (sep [ppr x <> comma,
 336                    ppr y <> comma,
 337                    ppr z ])
 338
 339 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 340          Outputable (a, b, c, d) where
 341     ppr (x,y,z,w) =
 342       parens (sep [ppr x <> comma,
 343                    ppr y <> comma,
 344                    ppr z <> comma,
 345                    ppr w])
 346
 347 instance Outputable FastString where
 348     ppr fs = text (unpackFS fs)         -- Prints an unadorned string,
 349                                         -- no double quotes or anything
 350
 351 #if __GLASGOW_HASKELL__ < 410
 352 -- Assume we have only 8-bit Chars.
 353
 354 pprHsChar :: Int -> SDoc
 355 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
 356
 357 pprHsString :: FastString -> SDoc
 358 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (unpackIntFS fs)))
 359
 360 showCharLit :: Int -> String -> String
 361 showCharLit c rest
 362     | c == ord '\"' = "\\\"" ++ rest
 363     | c == ord '\'' = "\\\'" ++ rest
 364     | c == ord '\\' = "\\\\" ++ rest
 365     | c >= 0x20 && c <= 0x7E = chr c : rest
 366     | c == ord '\a' = "\\a" ++ rest
 367     | c == ord '\b' = "\\b" ++ rest
 368     | c == ord '\f' = "\\f" ++ rest
 369     | c == ord '\n' = "\\n" ++ rest
 370     | c == ord '\r' = "\\r" ++ rest
 371     | c == ord '\t' = "\\t" ++ rest
 372     | c == ord '\v' = "\\v" ++ rest
 373     | otherwise     = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of
 374         d:_ | isDigit d -> "\\&" ++ rest
 375         _               -> rest
 376
 377 #else
 378 -- We have 31-bit Chars and will simply use Show instances
 379 -- of Char and String.
 380
 381 pprHsChar :: Int -> SDoc
 382 pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32))
 383             | otherwise    = text (show (chr c))
 384
 385 pprHsString :: FastString -> SDoc
 386 pprHsString fs = text (show (unpackFS fs))
 387
 388 #endif
 389
 390 instance Show FastString  where
 391     showsPrec p fs = showsPrecSDoc p (ppr fs)
 392 \end{code}
 393
 394
 395 %************************************************************************
 396 %*                                                                      *
 397 \subsection{Other helper functions}
 398 %*                                                                      *
 399 %************************************************************************
 400
 401 \begin{code}
 402 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 403 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
 404
 405 interppSP  :: Outputable a => [a] -> SDoc
 406 interppSP  xs = hsep (map ppr xs)
 407
 408 interpp'SP :: Outputable a => [a] -> SDoc
 409 interpp'SP xs = hsep (punctuate comma (map ppr xs))
 410
 411 pprQuotedList :: Outputable a => [a] -> SDoc
 412 -- [x,y,z]  ==>  `x', `y', `z'
 413 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 414 \end{code}
 415
 416
 417 %************************************************************************
 418 %*                                                                      *
 419 \subsection{Printing numbers verbally}
 420 %*                                                                      *
 421 %************************************************************************
 422
 423 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 424 ``first'' etc.
 425
 426 \begin{code}
 427 speakNth :: Int -> SDoc
 428
 429 speakNth 1 = ptext SLIT("first")
 430 speakNth 2 = ptext SLIT("second")
 431 speakNth 3 = ptext SLIT("third")
 432 speakNth 4 = ptext SLIT("fourth")
 433 speakNth 5 = ptext SLIT("fifth")
 434 speakNth 6 = ptext SLIT("sixth")
 435 speakNth n = hcat [ int n, text suffix ]
 436   where
 437     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 438            | last_dig == 1 = "st"
 439            | last_dig == 2 = "nd"
 440            | last_dig == 3 = "rd"
 441            | otherwise     = "th"
 442
 443     last_dig = n `rem` 10
 444 \end{code}
 445
 446 \begin{code}
 447 speakNTimes :: Int {- >=1 -} -> SDoc
 448 speakNTimes t | t == 1     = ptext SLIT("once")
 449               | t == 2     = ptext SLIT("twice")
 450               | otherwise  = int t <+> ptext SLIT("times")
 451 \end{code}
 452
 453
 454 %************************************************************************
 455 %*                                                                      *
 456 \subsection{Error handling}
 457 %*                                                                      *
 458 %************************************************************************
 459
 460 \begin{code}
 461 pprPanic :: String -> SDoc -> a
 462 pprError :: String -> SDoc -> a
 463 pprTrace :: String -> SDoc -> a -> a
 464 pprPanic  = pprAndThen panic
 465 pprError  = pprAndThen error
 466 pprTrace  = pprAndThen trace
 467
 468 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 469                              where
 470                                doc = text heading <+> pretty_msg
 471
 472 pprAndThen :: (String -> a) -> String -> SDoc -> a
 473 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 474     where
 475      doc = sep [text heading, nest 4 pretty_msg]
 476
 477 assertPprPanic :: String -> Int -> SDoc -> a
 478 assertPprPanic file line msg
 479   = panic (show (doc PprDebug))
 480   where
 481     doc = sep [hsep[text "ASSERT failed! file",
 482                            text file,
 483                            text "line", int line],
 484                     msg]
 485
 486 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 487 warnPprTrace False file line msg x = x
 488 warnPprTrace True  file line msg x
 489   = trace (show (doc PprDebug)) x
 490   where
 491     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 492                msg]
 493 \end{code}