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