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