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