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