ghc/compiler/utils/Outputable.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1996
   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 module Outputable (
  11         Outputable(..),                 -- Class
  12
  13         PprStyle,
  14         getPprStyle, withPprStyle, pprDeeper,
  15         codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
  16         ifPprDebug, ifNotPprForUser,
  17
  18         SDoc,           -- Abstract
  19         interppSP, interpp'SP, pprQuotedList,
  20         empty, nest,
  21         text, char, ptext,
  22         int, integer, float, double, rational,
  23         parens, brackets, braces, quotes, doubleQuotes,
  24         semi, comma, colon, space, equals,
  25         lparen, rparen, lbrack, rbrack, lbrace, rbrace,
  26         (<>), (<+>), hcat, hsep,
  27         ($$), ($+$), vcat,
  28         sep, cat,
  29         fsep, fcat,
  30         hang, punctuate,
  31         speakNth, speakNTimes,
  32
  33         showSDoc, printSDoc, printErrs, printDump,
  34         printForC, printForAsm, printForIface,
  35         pprCols,
  36
  37         -- error handling
  38         pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic,
  39         panic, panic#, assertPanic
  40     ) where
  41
  42 #include "HsVersions.h"
  43
  44 import IO               ( Handle, hPutChar, hPutStr, stderr, stdout )
  45 import CmdLineOpts      ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprUserLength )
  46 import FastString
  47 import qualified Pretty
  48 import Pretty           ( Doc, Mode(..), TextDetails(..), fullRender )
  49 import Util             ( panic, assertPanic, panic# )
  50 import GlaExts          ( trace )
  51 \end{code}
  52
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{The @PprStyle@ data type}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 data PprStyle
  62   = PprUser Depth               -- Pretty-print in a way that will
  63                                 -- make sense to the ordinary user;
  64                                 -- must be very close to Haskell
  65                                 -- syntax, etc.
  66
  67   | PprDebug                    -- Standard debugging output
  68
  69   | PprInterface                -- Interface generation
  70
  71   | PprCode CodeStyle           -- Print code; either C or assembler
  72
  73
  74 data CodeStyle = CStyle         -- The format of labels differs for C and assembler
  75                | AsmStyle
  76
  77 data Depth = AllTheWay
  78            | PartWay Int        -- 0 => stop
  79 \end{code}
  80
  81 Orthogonal to the above printing styles are (possibly) some
  82 command-line flags that affect printing (often carried with the
  83 style).  The most likely ones are variations on how much type info is
  84 shown.
  85
  86 The following test decides whether or not we are actually generating
  87 code (either C or assembly), or generating interface files.
  88
  89 %************************************************************************
  90 %*                                                                      *
  91 \subsection{The @SDoc@ data type}
  92 %*                                                                      *
  93 %************************************************************************
  94
  95 \begin{code}
  96 type SDoc = PprStyle -> Doc
  97
  98 withPprStyle :: PprStyle -> SDoc -> SDoc
  99 withPprStyle sty d sty' = d sty
 100
 101 pprDeeper :: SDoc -> SDoc
 102 pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
 103 pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
 104 pprDeeper d other_sty             = d other_sty
 105
 106 getPprStyle :: (PprStyle -> SDoc) -> SDoc
 107 getPprStyle df sty = df sty sty
 108 \end{code}
 109
 110 \begin{code}
 111 codeStyle :: PprStyle -> Bool
 112 codeStyle (PprCode _)     = True
 113 codeStyle _               = False
 114
 115 asmStyle :: PprStyle -> Bool
 116 asmStyle (PprCode AsmStyle)  = True
 117 asmStyle other               = False
 118
 119 ifaceStyle :: PprStyle -> Bool
 120 ifaceStyle PprInterface   = True
 121 ifaceStyle other          = False
 122
 123 debugStyle :: PprStyle -> Bool
 124 debugStyle PprDebug       = True
 125 debugStyle other          = False
 126
 127 userStyle ::  PprStyle -> Bool
 128 userStyle (PprUser _) = True
 129 userStyle other       = False
 130 \end{code}
 131
 132 \begin{code}
 133 ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style
 134 ifNotPprForUser d sty@(PprUser _) = Pretty.empty
 135 ifNotPprForUser d sty             = d sty
 136
 137 ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
 138 ifPprDebug d sty@PprDebug = d sty
 139 ifPprDebug d sty          = Pretty.empty
 140 \end{code}
 141
 142 \begin{code}
 143 printSDoc :: SDoc -> PprStyle -> IO ()
 144 printSDoc d sty = printDoc PageMode stdout (d sty)
 145
 146 -- I'm not sure whether the direct-IO approach of printDoc
 147 -- above is better or worse than the put-big-string approach here
 148 printErrs :: SDoc -> IO ()
 149 printErrs doc = printDoc PageMode stderr (final_doc user_style)
 150               where
 151                 final_doc = doc $$ text ""
 152                 user_style = mkUserStyle (PartWay opt_PprUserLength)
 153
 154 printDump :: SDoc -> IO ()
 155 printDump doc = printDoc PageMode stderr (final_doc PprDebug)
 156               where
 157                 final_doc = doc $$ text ""
 158
 159
 160 -- printForC, printForAsm doe what they sound like
 161 printForC :: Handle -> SDoc -> IO ()
 162 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
 163
 164 printForAsm :: Handle -> SDoc -> IO ()
 165 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
 166
 167 -- printForIface prints all on one line for interface files.
 168 -- It's called repeatedly for successive lines
 169 printForIface :: Handle -> SDoc -> IO ()
 170 printForIface handle doc = printDoc OneLineMode handle (doc PprInterface)
 171
 172
 173 -- showSDoc just blasts it out as a string
 174 showSDoc :: SDoc -> String
 175 showSDoc d = show (d (mkUserStyle AllTheWay))
 176
 177 mkUserStyle depth |  opt_PprStyle_Debug
 178                   || opt_PprStyle_All = PprDebug
 179                   |  otherwise        = PprUser depth
 180 \end{code}
 181
 182 \begin{code}
 183 empty sty      = Pretty.empty
 184 text s sty     = Pretty.text s
 185 char c sty     = Pretty.char c
 186 ptext s sty    = Pretty.ptext s
 187 int n sty      = Pretty.int n
 188 integer n sty  = Pretty.integer n
 189 float n sty    = Pretty.float n
 190 double n sty   = Pretty.double n
 191 rational n sty = Pretty.rational n
 192
 193 parens d sty       = Pretty.parens (d sty)
 194 braces d sty       = Pretty.braces (d sty)
 195 brackets d sty     = Pretty.brackets (d sty)
 196 quotes d sty       = Pretty.quotes (d sty)
 197 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 198
 199 semi sty   = Pretty.semi
 200 comma sty  = Pretty.comma
 201 colon sty  = Pretty.colon
 202 equals sty = Pretty.equals
 203 space sty  = Pretty.space
 204 lparen sty = Pretty.lparen
 205 rparen sty = Pretty.rparen
 206 lbrack sty = Pretty.lbrack
 207 rbrack sty = Pretty.rbrack
 208 lbrace sty = Pretty.lbrace
 209 rbrace sty = Pretty.rbrace
 210
 211 nest n d sty    = Pretty.nest n (d sty)
 212 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 213 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 214 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 215 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 216
 217 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 218 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 219 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 220 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 221 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 222 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 223 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 224
 225 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 226
 227 punctuate :: SDoc -> [SDoc] -> [SDoc]
 228 punctuate p []     = []
 229 punctuate p (d:ds) = go d ds
 230                    where
 231                      go d [] = [d]
 232                      go d (e:es) = (d <> p) : go e es
 233 \end{code}
 234
 235
 236 %************************************************************************
 237 %*                                                                      *
 238 \subsection[Outputable-class]{The @Outputable@ class}
 239 %*                                                                      *
 240 %************************************************************************
 241
 242 \begin{code}
 243 class Outputable a where
 244         ppr :: a -> SDoc
 245 \end{code}
 246
 247 \begin{code}
 248 instance Outputable Bool where
 249     ppr True  = ptext SLIT("True")
 250     ppr False = ptext SLIT("False")
 251
 252 instance Outputable Int where
 253    ppr n = int n
 254
 255 instance (Outputable a) => Outputable [a] where
 256     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 257
 258 instance (Outputable a, Outputable b) => Outputable (a, b) where
 259     ppr (x,y) =
 260       hang (hcat [lparen, ppr x, comma]) 4 ((<>) (ppr y) rparen)
 261
 262 -- ToDo: may not be used
 263 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 264     ppr (x,y,z) =
 265       parens (sep [ (<>) (ppr x) comma,
 266                       (<>) (ppr y) comma,
 267                       ppr z ])
 268 \end{code}
 269
 270
 271 %************************************************************************
 272 %*                                                                      *
 273 \subsection{Other helper functions}
 274 %*                                                                      *
 275 %************************************************************************
 276
 277 \begin{code}
 278 pprCols = (100 :: Int) -- could make configurable
 279
 280 printDoc :: Mode -> Handle -> Doc -> IO ()
 281 printDoc mode hdl doc
 282   = fullRender mode pprCols 1.5 put done doc
 283 {-
 284   = _readHandle hdl                                 >>= \ htype ->
 285     let fp = _filePtr htype in
 286     fullRender mode pprCols 1.5 (put (fp::_Addr)) (done fp) doc
 287 -}
 288   where
 289 {-
 290     put fp (Chr c)  next = _scc_ "hPutChar" ((_ccall_ stg_putc c (fp::_Addr))::PrimIO ()) `seqPrimIO` next
 291     put fp (Str s)  next = _scc_ "hPutStr"  (put_str fp s)          >> next
 292     put fp (PStr s) next = _scc_ "hPutFS"   (put_str fp (_UNPK_ s)) >> next
 293
 294     put_str fp (c1@(C# _) : cs)
 295       = _ccall_ stg_putc  c1 (fp::_Addr)        `seqPrimIO`
 296         put_str fp cs
 297     put_str fp [] = return ()
 298 -}
 299     put (Chr c)  next = _scc_ "hPutChar" (hPutChar hdl c) >> next
 300     put (Str s)  next = _scc_ "hPutStr"  (hPutStr  hdl s) >> next
 301     put (PStr s) next = _scc_ "hPutFS"   (hPutFS   hdl s) >> next
 302
 303 {-
 304     string_txt (Chr c)   s2 = c   :  s2
 305     string_txt (Str s1)  s2 = s1  ++ s2
 306     string_txt (PStr s1) s2 = _UNPK_ s1 ++ s2
 307     done fp = ((_ccall_ stg_putc '\n' (fp::_Addr))::PrimIO ()) `seqPrimIO` return () --hPutChar hdl '\n'
 308 -}
 309
 310     done = hPutChar hdl '\n'
 311 \end{code}
 312
 313
 314 \begin{code}
 315 interppSP  :: Outputable a => [a] -> SDoc
 316 interppSP  xs = hsep (map ppr xs)
 317
 318 interpp'SP :: Outputable a => [a] -> SDoc
 319 interpp'SP xs = hsep (punctuate comma (map ppr xs))
 320
 321 pprQuotedList :: Outputable a => [a] -> SDoc
 322 -- [x,y,z]  ==>  `x', `y', `z'
 323 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 324 \end{code}
 325
 326
 327
 328
 329 %************************************************************************
 330 %*                                                                      *
 331 \subsection{Printing numbers verbally}
 332 %*                                                                      *
 333 %************************************************************************
 334
 335 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 336 ``first'' etc.
 337
 338 \begin{code}
 339 speakNth :: Int -> SDoc
 340
 341 speakNth 1 = ptext SLIT("first")
 342 speakNth 2 = ptext SLIT("second")
 343 speakNth 3 = ptext SLIT("third")
 344 speakNth 4 = ptext SLIT("fourth")
 345 speakNth 5 = ptext SLIT("fifth")
 346 speakNth 6 = ptext SLIT("sixth")
 347 speakNth n = hcat [ int n, text st_nd_rd_th ]
 348   where
 349     st_nd_rd_th | n_rem_10 == 1 = "st"
 350                 | n_rem_10 == 2 = "nd"
 351                 | n_rem_10 == 3 = "rd"
 352                 | otherwise     = "th"
 353
 354     n_rem_10 = n `rem` 10
 355 \end{code}
 356
 357 \begin{code}
 358 speakNTimes :: Int {- >=1 -} -> SDoc
 359 speakNTimes t | t == 1     = ptext SLIT("once")
 360               | t == 2     = ptext SLIT("twice")
 361               | otherwise  = int t <+> ptext SLIT("times")
 362 \end{code}
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection[Utils-errors]{Error handling}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 \begin{code}
 371 pprPanic heading pretty_msg = panic (show (doc PprDebug))
 372                             where
 373                               doc = text heading <+> pretty_msg
 374
 375 pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg))
 376
 377 pprTrace heading pretty_msg = trace (show (doc PprDebug))
 378                             where
 379                               doc = text heading <+> pretty_msg
 380
 381 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 382                              where
 383                                doc = text heading <+> pretty_msg
 384
 385 assertPprPanic :: String -> Int -> SDoc -> a
 386 assertPprPanic file line msg
 387   = panic (show (doc PprDebug))
 388   where
 389     doc = sep [hsep[text "ASSERT failed! file",
 390                            text file,
 391                            text "line", int line],
 392                     msg]
 393 \end{code}