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   where
 284     put (Chr c)  next = hPutChar hdl c >> next
 285     put (Str s)  next = hPutStr  hdl s >> next
 286     put (PStr s) next = hPutFS   hdl s >> next
 287
 288     done = hPutChar hdl '\n'
 289 \end{code}
 290
 291
 292 \begin{code}
 293 interppSP  :: Outputable a => [a] -> SDoc
 294 interppSP  xs = hsep (map ppr xs)
 295
 296 interpp'SP :: Outputable a => [a] -> SDoc
 297 interpp'SP xs = hsep (punctuate comma (map ppr xs))
 298
 299 pprQuotedList :: Outputable a => [a] -> SDoc
 300 -- [x,y,z]  ==>  `x', `y', `z'
 301 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 302 \end{code}
 303
 304
 305
 306
 307 %************************************************************************
 308 %*                                                                      *
 309 \subsection{Printing numbers verbally}
 310 %*                                                                      *
 311 %************************************************************************
 312
 313 @speakNth@ converts an integer to a verbal index; eg 1 maps to
 314 ``first'' etc.
 315
 316 \begin{code}
 317 speakNth :: Int -> SDoc
 318
 319 speakNth 1 = ptext SLIT("first")
 320 speakNth 2 = ptext SLIT("second")
 321 speakNth 3 = ptext SLIT("third")
 322 speakNth 4 = ptext SLIT("fourth")
 323 speakNth 5 = ptext SLIT("fifth")
 324 speakNth 6 = ptext SLIT("sixth")
 325 speakNth n = hcat [ int n, text st_nd_rd_th ]
 326   where
 327     st_nd_rd_th | n_rem_10 == 1 = "st"
 328                 | n_rem_10 == 2 = "nd"
 329                 | n_rem_10 == 3 = "rd"
 330                 | otherwise     = "th"
 331
 332     n_rem_10 = n `rem` 10
 333 \end{code}
 334
 335 \begin{code}
 336 speakNTimes :: Int {- >=1 -} -> SDoc
 337 speakNTimes t | t == 1     = ptext SLIT("once")
 338               | t == 2     = ptext SLIT("twice")
 339               | otherwise  = int t <+> ptext SLIT("times")
 340 \end{code}
 341
 342 %************************************************************************
 343 %*                                                                      *
 344 \subsection[Utils-errors]{Error handling}
 345 %*                                                                      *
 346 %************************************************************************
 347
 348 \begin{code}
 349 pprPanic heading pretty_msg = panic (show (doc PprDebug))
 350                             where
 351                               doc = text heading <+> pretty_msg
 352
 353 pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg))
 354
 355 pprTrace heading pretty_msg = trace (show (doc PprDebug))
 356                             where
 357                               doc = text heading <+> pretty_msg
 358
 359 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 360                              where
 361                                doc = text heading <+> pretty_msg
 362
 363 assertPprPanic :: String -> Int -> SDoc -> a
 364 assertPprPanic file line msg
 365   = panic (show (doc PprDebug))
 366   where
 367     doc = sep [hsep[text "ASSERT failed! file",
 368                            text file,
 369                            text "line", int line],
 370                     msg]
 371 \end{code}