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