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, 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(..), 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 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 ptext s sty    = Pretty.ptext s
 231 int n sty      = Pretty.int n
 232 integer n sty  = Pretty.integer n
 233 float n sty    = Pretty.float n
 234 double n sty   = Pretty.double n
 235 rational n sty = Pretty.rational n
 236
 237 parens d sty       = Pretty.parens (d sty)
 238 braces d sty       = Pretty.braces (d sty)
 239 brackets d sty     = Pretty.brackets (d sty)
 240 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 241 angleBrackets d    = char '<' <> d <> char '>'
 242
 243 -- quotes encloses something in single quotes...
 244 -- but it omits them if the thing ends in a single quote
 245 -- so that we don't get `foo''.  Instead we just have foo'.
 246 quotes d sty = case show pp_d of
 247                  ('\'' : _) -> pp_d
 248                  other      -> Pretty.quotes pp_d
 249              where
 250                pp_d = d sty
 251
 252 semi sty   = Pretty.semi
 253 comma sty  = Pretty.comma
 254 colon sty  = Pretty.colon
 255 equals sty = Pretty.equals
 256 space sty  = Pretty.space
 257 lparen sty = Pretty.lparen
 258 rparen sty = Pretty.rparen
 259 lbrack sty = Pretty.lbrack
 260 rbrack sty = Pretty.rbrack
 261 lbrace sty = Pretty.lbrace
 262 rbrace sty = Pretty.rbrace
 263 dcolon sty = Pretty.ptext SLIT("::")
 264 underscore = char '_'
 265 dot        = char '.'
 266
 267 nest n d sty    = Pretty.nest n (d sty)
 268 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 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
 273 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 274 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 275 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 276 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 277 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 278 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 279 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 280
 281 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 282
 283 punctuate :: SDoc -> [SDoc] -> [SDoc]
 284 punctuate p []     = []
 285 punctuate p (d:ds) = go d ds
 286                    where
 287                      go d [] = [d]
 288                      go d (e:es) = (d <> p) : go e es
 289 \end{code}
 290
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection[Outputable-class]{The @Outputable@ class}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 \begin{code}
 299 class Outputable a where
 300         ppr :: a -> SDoc
 301 \end{code}
 302
 303 \begin{code}
 304 instance Outputable Bool where
 305     ppr True  = ptext SLIT("True")
 306     ppr False = ptext SLIT("False")
 307
 308 instance Outputable Int where
 309    ppr n = int n
 310
 311 instance Outputable () where
 312    ppr _ = text "()"
 313
 314 instance (Outputable a) => Outputable [a] where
 315     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 316
 317 instance (Outputable a, Outputable b) => Outputable (a, b) where
 318     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 319
 320 instance Outputable a => Outputable (Maybe a) where
 321   ppr Nothing = ptext SLIT("Nothing")
 322   ppr (Just x) = ptext SLIT("Just") <+> ppr x
 323
 324 -- ToDo: may not be used
 325 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 326     ppr (x,y,z) =
 327       parens (sep [ppr x <> comma,
 328                    ppr y <> comma,
 329                    ppr z ])
 330
 331 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 332          Outputable (a, b, c, d) where
 333     ppr (x,y,z,w) =
 334       parens (sep [ppr x <> comma,
 335                    ppr y <> comma,
 336                    ppr z <> comma,
 337                    ppr w])
 338
 339 instance Outputable FastString where
 340     ppr fs = text (unpackFS fs)         -- Prints an unadorned string,
 341                                         -- no double quotes or anything
 342
 343 #if __GLASGOW_HASKELL__ < 410
 344 -- Assume we have only 8-bit Chars.
 345
 346 pprHsChar :: Int -> SDoc
 347 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
 348
 349 pprHsString :: FAST_STRING -> SDoc
 350 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs)))
 351
 352 showCharLit :: Int -> String -> String
 353 showCharLit c rest
 354     | c == ord '\"' = "\\\"" ++ rest
 355     | c == ord '\'' = "\\\'" ++ rest
 356     | c == ord '\\' = "\\\\" ++ rest
 357     | c >= 0x20 && c <= 0x7E = chr c : rest
 358     | c == ord '\a' = "\\a" ++ rest
 359     | c == ord '\b' = "\\b" ++ rest
 360     | c == ord '\f' = "\\f" ++ rest
 361     | c == ord '\n' = "\\n" ++ rest
 362     | c == ord '\r' = "\\r" ++ rest
 363     | c == ord '\t' = "\\t" ++ rest
 364     | c == ord '\v' = "\\v" ++ rest
 365     | otherwise     = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of
 366         d:_ | isDigit d -> "\\&" ++ rest
 367         _               -> rest
 368
 369 #else
 370 -- We have 31-bit Chars and will simply use Show instances
 371 -- of Char and String.
 372
 373 pprHsChar :: Int -> SDoc
 374 pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32))
 375             | otherwise    = text (show (chr c))
 376
 377 pprHsString :: FastString -> SDoc
 378 pprHsString fs = text (show (unpackFS fs))
 379
 380 #endif
 381
 382 instance Show FastString  where
 383     showsPrec p fs = showsPrecSDoc p (ppr fs)
 384 \end{code}
 385
 386
 387 %************************************************************************
 388 %*                                                                      *
 389 \subsection{Other helper functions}
 390 %*                                                                      *
 391 %************************************************************************
 392
 393 \begin{code}
 394 showDocWith :: Mode -> Doc -> String
 395 showDocWith mode doc
 396   = fullRender mode 100 1.5 put "" doc
 397   where
 398     put (Chr c)   s  = c:s
 399     put (Str s1)  s2 = s1 ++ s2
 400     put (PStr s1) s2 = _UNPK_ s1 ++ s2
 401 \end{code}
 402
 403
 404 \begin{code}
 405 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
 406 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
 407
 408 interppSP  :: Outputable a => [a] -> SDoc
 409 interppSP  xs = hsep (map ppr xs)
 410
 411 interpp'SP :: Outputable a => [a] -> SDoc
 412 interpp'SP xs = hsep (punctuate comma (map ppr xs))
 413
 414 pprQuotedList :: Outputable a => [a] -> SDoc
 415 -- [x,y,z]  ==>  `x', `y', `z'
 416 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 417 \end{code}
 418
 419
 420 %************************************************************************
 421 %*                                                                      *
 422 \subsection{Printing numbers verbally}
 423 %*                                                                      *
 424 %************************************************************************
 425
 426 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 427 ``first'' etc.
 428
 429 \begin{code}
 430 speakNth :: Int -> SDoc
 431
 432 speakNth 1 = ptext SLIT("first")
 433 speakNth 2 = ptext SLIT("second")
 434 speakNth 3 = ptext SLIT("third")
 435 speakNth 4 = ptext SLIT("fourth")
 436 speakNth 5 = ptext SLIT("fifth")
 437 speakNth 6 = ptext SLIT("sixth")
 438 speakNth n = hcat [ int n, text st_nd_rd_th ]
 439   where
 440     st_nd_rd_th | n_rem_10 == 1 = "st"
 441                 | n_rem_10 == 2 = "nd"
 442                 | n_rem_10 == 3 = "rd"
 443                 | otherwise     = "th"
 444
 445     n_rem_10 = n `rem` 10
 446 \end{code}
 447
 448 \begin{code}
 449 speakNTimes :: Int {- >=1 -} -> SDoc
 450 speakNTimes t | t == 1     = ptext SLIT("once")
 451               | t == 2     = ptext SLIT("twice")
 452               | otherwise  = int t <+> ptext SLIT("times")
 453 \end{code}
 454
 455
 456 %************************************************************************
 457 %*                                                                      *
 458 \subsection{Error handling}
 459 %*                                                                      *
 460 %************************************************************************
 461
 462 \begin{code}
 463 pprPanic :: String -> SDoc -> a
 464 pprError :: String -> SDoc -> a
 465 pprTrace :: String -> SDoc -> a -> a
 466 pprPanic  = pprAndThen panic
 467 pprError  = pprAndThen error
 468 pprTrace  = pprAndThen trace
 469
 470 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 471                              where
 472                                doc = text heading <+> pretty_msg
 473
 474 pprAndThen :: (String -> a) -> String -> SDoc -> a
 475 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 476     where
 477      doc = sep [text heading, nest 4 pretty_msg]
 478
 479 assertPprPanic :: String -> Int -> SDoc -> a
 480 assertPprPanic file line msg
 481   = panic (show (doc PprDebug))
 482   where
 483     doc = sep [hsep[text "ASSERT failed! file",
 484                            text file,
 485                            text "line", int line],
 486                     msg]
 487
 488 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 489 warnPprTrace False file line msg x = x
 490 warnPprTrace True  file line msg x
 491   = trace (show (doc PprDebug)) x
 492   where
 493     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 494                msg]
 495 \end{code}