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_PprStyle_User, 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 False = ptext SLIT("False")
 250
 251 instance Outputable Int where
 252    ppr n = int n
 253
 254 instance (Outputable a) => Outputable [a] where
 255     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 256
 257 instance (Outputable a, Outputable b) => Outputable (a, b) where
 258     ppr (x,y) =
 259       hang (hcat [lparen, ppr x, comma]) 4 ((<>) (ppr y) rparen)
 260
 261 -- ToDo: may not be used
 262 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 263     ppr (x,y,z) =
 264       parens (sep [ (<>) (ppr x) comma,
 265                       (<>) (ppr y) comma,
 266                       ppr z ])
 267 \end{code}
 268
 269
 270 %************************************************************************
 271 %*                                                                      *
 272 \subsection{Other helper functions}
 273 %*                                                                      *
 274 %************************************************************************
 275
 276 \begin{code}
 277 pprCols = (100 :: Int) -- could make configurable
 278
 279 printDoc :: Mode -> Handle -> Doc -> IO ()
 280 printDoc mode hdl doc
 281   = fullRender mode pprCols 1.5 put done doc
 282   where
 283     put (Chr c)  next = hPutChar hdl c >> next
 284     put (Str s)  next = hPutStr  hdl s >> next
 285     put (PStr s) next = hPutFS   hdl s >> next
 286
 287     done = hPutChar hdl '\n'
 288 \end{code}
 289
 290
 291 \begin{code}
 292 interppSP  :: Outputable a => [a] -> SDoc
 293 interppSP  xs = hsep (map ppr xs)
 294
 295 interpp'SP :: Outputable a => [a] -> SDoc
 296 interpp'SP xs = hsep (punctuate comma (map ppr xs))
 297
 298 pprQuotedList :: Outputable a => [a] -> SDoc
 299 -- [x,y,z]  ==>  `x', `y', `z'
 300 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 301 \end{code}
 302
 303
 304
 305
 306 %************************************************************************
 307 %*                                                                      *
 308 \subsection{Printing numbers verbally}
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 313 ``first'' etc.
 314
 315 \begin{code}
 316 speakNth :: Int -> SDoc
 317
 318 speakNth 1 = ptext SLIT("first")
 319 speakNth 2 = ptext SLIT("second")
 320 speakNth 3 = ptext SLIT("third")
 321 speakNth 4 = ptext SLIT("fourth")
 322 speakNth 5 = ptext SLIT("fifth")
 323 speakNth 6 = ptext SLIT("sixth")
 324 speakNth n = hcat [ int n, text st_nd_rd_th ]
 325   where
 326     st_nd_rd_th | n_rem_10 == 1 = "st"
 327                 | n_rem_10 == 2 = "nd"
 328                 | n_rem_10 == 3 = "rd"
 329                 | otherwise     = "th"
 330
 331     n_rem_10 = n `rem` 10
 332 \end{code}
 333
 334 \begin{code}
 335 speakNTimes :: Int {- >=1 -} -> SDoc
 336 speakNTimes t | t == 1     = ptext SLIT("once")
 337               | t == 2     = ptext SLIT("twice")
 338               | otherwise  = int t <+> ptext SLIT("times")
 339 \end{code}
 340
 341 %************************************************************************
 342 %*                                                                      *
 343 \subsection[Utils-errors]{Error handling}
 344 %*                                                                      *
 345 %************************************************************************
 346
 347 \begin{code}
 348 pprPanic heading pretty_msg = panic (show (doc PprDebug))
 349                             where
 350                               doc = text heading <+> pretty_msg
 351
 352 pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg))
 353
 354 pprTrace heading pretty_msg = trace (show (doc PprDebug))
 355                             where
 356                               doc = text heading <+> pretty_msg
 357
 358 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 359                              where
 360                                doc = text heading <+> pretty_msg
 361
 362 assertPprPanic :: String -> Int -> SDoc -> a
 363 assertPprPanic file line msg
 364   = panic (show (doc PprDebug))
 365   where
 366     doc = sep [hsep[text "ASSERT failed! file",
 367                            text file,
 368                            text "line", int line],
 369                     msg]
 370 \end{code}