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