ghc/compiler/utils/Pretty.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[Pretty]{Pretty-printing data type}
   5
   6 \begin{code}
   7 #if defined(COMPILING_GHC)
   8 # include "HsVersions.h"
   9 #else
  10 # define FAST_STRING String
  11 # define _LENGTH_    length
  12 #endif
  13
  14 module Pretty (
  15         Pretty(..),
  16
  17 #if defined(COMPILING_GHC)
  18         PprStyle(..),
  19         prettyToUn,
  20         codeStyle, -- UNUSED: stySwitch,
  21 #endif
  22         ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger,
  23         ppFloat, ppDouble,
  24 #if __GLASGOW_HASKELL__ >= 23
  25         -- may be able to *replace* ppDouble
  26         ppRational,
  27 #endif
  28         ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
  29         ppSemi, ppComma, ppEquals,
  30
  31         ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
  32         ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
  33         ppShow,
  34 #if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
  35         ppAppendFile,
  36 #endif
  37
  38         -- abstract type, to complete the interface...
  39         PrettyRep(..), CSeq, Delay
  40 #if defined(COMPILING_GHC)
  41         , GlobalSwitch, Unpretty(..)
  42 #endif
  43    ) where
  44
  45 import CharSeq
  46 #if defined(COMPILING_GHC)
  47 import Unpretty         ( Unpretty(..) )
  48 import CmdLineOpts      ( GlobalSwitch )
  49 #endif
  50 \end{code}
  51
  52 Based on John Hughes's pretty-printing library.  For now, that code
  53 and notes for it are in files \tr{pp-rjmh*} (ToDo: rm).
  54
  55 %************************************************
  56 %*                                              *
  57         \subsection{The interface}
  58 %*                                              *
  59 %************************************************
  60
  61 \begin{code}
  62 ppNil           :: Pretty
  63 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty
  64
  65 ppStr           :: [Char] -> Pretty
  66 ppPStr          :: FAST_STRING -> Pretty
  67 ppChar          :: Char    -> Pretty
  68 ppInt           :: Int     -> Pretty
  69 ppInteger       :: Integer -> Pretty
  70 ppDouble        :: Double  -> Pretty
  71 ppFloat         :: Float   -> Pretty
  72 #if __GLASGOW_HASKELL__ >= 23
  73 ppRational      :: Rational -> Pretty
  74 #endif
  75
  76 ppBeside        :: Pretty -> Pretty -> Pretty
  77 ppBesides       :: [Pretty] -> Pretty
  78 ppBesideSP      :: Pretty -> Pretty -> Pretty
  79 ppCat           :: [Pretty] -> Pretty           -- i.e., ppBesidesSP
  80
  81 ppAbove         :: Pretty -> Pretty -> Pretty
  82 ppAboves        :: [Pretty] -> Pretty
  83
  84 ppInterleave    :: Pretty -> [Pretty] -> Pretty
  85 ppIntersperse   :: Pretty -> [Pretty] -> Pretty -- no spaces between, no ppSep
  86 ppSep           :: [Pretty] -> Pretty
  87 ppHang          :: Pretty -> Int -> Pretty -> Pretty
  88 ppNest          :: Int -> Pretty -> Pretty
  89
  90 ppShow          :: Int -> Pretty -> [Char]
  91
  92 #if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
  93 # if __GLASGOW_HASKELL__ < 23
  94 #  define _FILE _Addr
  95 # endif
  96 ppAppendFile    :: _FILE -> Int -> Pretty -> PrimIO ()
  97 #endif
  98 \end{code}
  99
 100 %************************************************
 101 %*                                              *
 102         \subsection{The representation}
 103 %*                                              *
 104 %************************************************
 105
 106 \begin{code}
 107 type Pretty = Int       -- The width to print in
 108            -> Bool      -- True => vertical context
 109            -> PrettyRep
 110
 111 data PrettyRep
 112   = MkPrettyRep CSeq    -- The text
 113                 (Delay Int) -- No of chars in last line
 114                 Bool    -- True if empty object
 115                 Bool    -- Fits on a single line in specified width
 116
 117 data Delay a = MkDelay a
 118
 119 forceDel (MkDelay _) r = r
 120
 121 forceBool True  r = r
 122 forceBool False r = r
 123
 124 forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r))
 125
 126 ppShow width p
 127   = case (p width False) of
 128       MkPrettyRep seq ll emp sl -> cShow seq
 129
 130 #if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
 131 ppAppendFile f width p
 132   = case (p width False) of
 133       MkPrettyRep seq ll emp sl -> cAppendFile f seq
 134 #endif
 135
 136 ppNil    width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0)
 137                            -- Doesn't fit if width < 0, otherwise, ppNil
 138                            -- will make ppBesides always return True.
 139
 140 ppStr  s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
 141                            where ls = length s
 142 ppPStr s width is_vert = MkPrettyRep (cPStr s) (MkDelay ls) False (width >= ls)
 143                            where ls = _LENGTH_ s
 144 ppChar c width is_vert = MkPrettyRep (cCh c) (MkDelay 1) False (width >= 1)
 145
 146 ppInt  n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
 147                            where s = show n; ls = length s
 148
 149 ppInteger n  = ppStr (show n)
 150 ppDouble  n  = ppStr (show n)
 151 ppFloat   n  = ppStr (show n)
 152 #if __GLASGOW_HASKELL__ >= 23
 153 --ppRational n = ppStr (_showRational 30 n)
 154 ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n)
 155 #endif
 156
 157 ppSP      = ppChar ' '
 158 pp'SP     = ppStr ", "
 159 ppLbrack  = ppChar '['
 160 ppRbrack  = ppChar ']'
 161 ppLparen  = ppChar '('
 162 ppRparen  = ppChar ')'
 163 ppSemi    = ppChar ';'
 164 ppComma   = ppChar ','
 165 ppEquals  = ppChar '='
 166
 167 ppInterleave sep ps = ppSep (pi ps)
 168   where
 169    pi []        = []
 170    pi [x]       = [x]
 171    pi (x:xs)    = (ppBeside x sep) : pi xs
 172 \end{code}
 173
 174 ToDo: this could be better: main pt is: no extra spaces in between.
 175
 176 \begin{code}
 177 ppIntersperse sep ps = ppBesides (pi ps)
 178   where
 179    pi []        = []
 180    pi [x]       = [x]
 181    pi (x:xs)    = (ppBeside x sep) : pi xs
 182 \end{code}
 183
 184 Laziness is important in @ppBeside@.  If the first thing is not a
 185 single line it will return @False@ for the single-line boolean without
 186 laying out the second.
 187
 188 \begin{code}
 189 ppBeside p1 p2 width is_vert
 190   = case (p1 width False) of
 191       MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
 192           MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2))
 193                       (MkDelay (ll1 + ll2))
 194                       (emp1 && emp2)
 195                       ((width >= 0) && (sl1 && sl2))
 196                       -- This sequence of (&&)'s ensures that ppBeside
 197                       -- returns a False for sl as soon as possible.
 198        where -- NB: for case alt
 199          seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
 200          MkDelay ll2 = x_ll2
 201          MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-ll1) False
 202          -- ToDo: if emp{1,2} then we really
 203          -- should be passing on "is_vert" to p{2,1}.
 204
 205 ppBesides [] = ppNil
 206 ppBesides ps = foldr1 ppBeside ps
 207 \end{code}
 208
 209 @ppBesideSP@ puts two things beside each other separated by a space.
 210
 211 \begin{code}
 212 ppBesideSP p1 p2 width is_vert
 213   = case (p1 width False) of
 214       MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
 215           MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2)))
 216                    (MkDelay (li + ll2))
 217                    (emp1 && emp2)
 218                    ((width >= wi) && (sl1 && sl2))
 219        where -- NB: for case alt
 220          seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
 221          MkDelay ll2 = x_ll2
 222          MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False
 223          li, wi :: Int
 224          li = if emp1 then 0 else ll1+1
 225          wi = if emp1 then 0 else 1
 226          sp = if emp1 || emp2 then cNil else (cCh ' ')
 227 \end{code}
 228
 229 @ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@.
 230
 231 \begin{code}
 232 ppCat []  = ppNil
 233 ppCat ps  = foldr1 ppBesideSP ps
 234 \end{code}
 235
 236 \begin{code}
 237 ppAbove p1 p2 width is_vert
 238   = case (p1 width True) of
 239       MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
 240           MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2))
 241                       (MkDelay ll2)
 242                       -- ToDo: make ll depend on empties?
 243                       (emp1 && emp2)
 244                       False
 245        where -- NB: for case alt
 246          nl = if emp1 || emp2 then cNil else cNL
 247          seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
 248          MkDelay ll2 = x_ll2 -- Don't "optimise" this away!
 249          MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 width True
 250              -- ToDo: ditto about passing is_vert if empties
 251
 252 ppAboves [] = ppNil
 253 ppAboves ps = foldr1 ppAbove ps
 254 \end{code}
 255
 256 \begin{code}
 257 ppNest n p width False = p width False
 258 ppNest n p width True
 259   = case (p (width-n) True) of
 260       MkPrettyRep seq (MkDelay ll) emp sl ->
 261         MkPrettyRep (cIndent n seq) (MkDelay (ll+n)) emp sl
 262 \end{code}
 263
 264 The length-check below \tr{(ll1+ll2+1) <= width} should really check for
 265 max widths not the width of the last line.
 266
 267 \begin{code}
 268 ppHang p1 n p2 width is_vert    -- This is a little bit stricter than it could
 269                                 -- be made with a little more effort.
 270                                 -- Eg the output always starts with seq1
 271   = case (p1 width False) of
 272       MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
 273           if emp1 then
 274               p2 width is_vert
 275           else
 276           if (ll1 <= n) || sl2 then     -- very ppBesideSP'ish
 277               -- Hang it if p1 shorter than indent or if it doesn't fit
 278               MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2)))
 279                         (MkDelay (ll1 + 1 + ll2))
 280                         False
 281                         (sl1 && sl2)
 282           else
 283               -- Nest it (pretty ppAbove-ish)
 284               MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2')))
 285                         (MkDelay ll2') -- ToDo: depend on empties
 286                         False
 287                         False
 288        where -- NB: for case alt
 289          seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
 290          MkDelay ll2 = x_ll2
 291          MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False
 292              -- ToDo: more "is_vert if empty" stuff
 293
 294          seq2' = forceInfo x_ll2' emp2' sl2' x_seq2'
 295          MkDelay ll2' = x_ll2'          -- Don't "optimise" this away!
 296          MkPrettyRep x_seq2' x_ll2' emp2' sl2' = p2 (width-n) False     -- ToDo: True?
 297 \end{code}
 298
 299 \begin{code}
 300 ppSep []  width is_vert = ppNil width is_vert
 301 ppSep [p] width is_vert = p     width is_vert
 302
 303 -- CURRENT, but BAD.  Quadratic behaviour on the perfectly reasonable
 304 --      ppSep [a, ppSep[b, ppSep [c, ... ]]]
 305
 306 ppSep ps  width is_vert
 307   = case (ppCat ps width is_vert) of
 308       MkPrettyRep seq x_ll emp sl ->
 309         if sl then                      -- Fits on one line
 310            MkPrettyRep seq x_ll emp sl
 311         else
 312            ppAboves ps width is_vert    -- Takes several lines
 313 \end{code}
 314
 315 %************************************************************************
 316 %*                                                                      *
 317 \subsection[Outputable-print]{Pretty-printing stuff}
 318 %*                                                                      *
 319 %************************************************************************
 320
 321 ToDo: this is here for no-original-name reasons (mv?).
 322
 323 There is no clearly definitive list of @PprStyles@; I suggest the
 324 following:
 325
 326 \begin{code}
 327 #if defined(COMPILING_GHC)
 328     -- to the end of file
 329
 330 data PprStyle
 331   = PprForUser                  -- Pretty-print in a way that will
 332                                 -- make sense to the ordinary user;
 333                                 -- must be very close to Haskell
 334                                 -- syntax, etc.  ToDo: how diff is
 335                                 -- this from what pprInterface must
 336                                 -- do?
 337   | PprDebug                    -- Standard debugging output
 338   | PprShowAll                  -- Debugging output which leaves
 339                                 -- nothing to the imagination
 340   | PprInterface                -- Interface generation
 341         (GlobalSwitch -> Bool)  --  (we can look at cmd-line flags)
 342   | PprForC                     -- must print out C-acceptable names
 343         (GlobalSwitch -> Bool)  --  (ditto)
 344   | PprUnfolding                -- for non-interface intermodule info
 345         (GlobalSwitch -> Bool)  -- the compiler writes/reads
 346   | PprForAsm                   -- must print out assembler-acceptable names
 347         (GlobalSwitch -> Bool)  --  (ditto)
 348         Bool                    -- prefix CLabel with underscore?
 349         (String -> String)      -- format AsmTempLabel
 350 \end{code}
 351
 352 The following test decides whether or not we are actually generating
 353 code (either C or assembly).
 354 \begin{code}
 355 codeStyle :: PprStyle -> Bool
 356 codeStyle (PprForC _) = True
 357 codeStyle (PprForAsm _ _ _) = True
 358 codeStyle _ = False
 359
 360 {- UNUSED:
 361 stySwitch :: PprStyle -> GlobalSwitch -> Bool
 362 stySwitch (PprInterface sw) = sw
 363 stySwitch (PprForC sw) = sw
 364 stySwitch (PprForAsm sw _ _) = sw
 365 -}
 366 \end{code}
 367
 368 Orthogonal to these printing styles are (possibly) some command-line
 369 flags that affect printing (often carried with the style).  The most
 370 likely ones are variations on how much type info is shown.
 371
 372 \begin{code}
 373 prettyToUn :: Pretty -> Unpretty
 374
 375 prettyToUn p
 376   = case (p 999999{-totally bogus width-} False{-also invented-}) of
 377       MkPrettyRep seq ll emp sl -> seq
 378
 379 #endif {-COMPILING_GHC-}
 380 \end{code}
 381
 382 -----------------------------------
 383 \begin{code}
 384 -- from Lennart
 385 fromRationalX :: (RealFloat a) => Rational -> a
 386
 387 fromRationalX r =
 388         let
 389             h = ceiling (huge `asTypeOf` x)
 390             b = toInteger (floatRadix x)
 391             x = fromRat 0 r
 392             fromRat e0 r' =
 393                 let d = denominator r'
 394                     n = numerator r'
 395                 in  if d > h then
 396                        let e = integerLogBase b (d `div` h) + 1
 397                        in  fromRat (e0-e) (n % (d `div` (b^e)))
 398                     else if abs n > h then
 399                        let e = integerLogBase b (abs n `div` h) + 1
 400                        in  fromRat (e0+e) ((n `div` (b^e)) % d)
 401                     else
 402                        scaleFloat e0 (fromRational r')
 403         in  x
 404
 405 -- Compute the discrete log of i in base b.
 406 -- Simplest way would be just divide i by b until it's smaller then b, but that would
 407 -- be very slow!  We are just slightly more clever.
 408 integerLogBase :: Integer -> Integer -> Int
 409 integerLogBase b i =
 410      if i < b then
 411         0
 412      else
 413         -- Try squaring the base first to cut down the number of divisions.
 414         let l = 2 * integerLogBase (b*b) i
 415
 416             doDiv :: Integer -> Int -> Int
 417             doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
 418         in
 419         doDiv (i `div` (b^l)) l
 420
 421
 422 ------------
 423
 424 -- Compute smallest and largest floating point values.
 425 {-
 426 tiny :: (RealFloat a) => a
 427 tiny =
 428         let (l, _) = floatRange x
 429             x = encodeFloat 1 (l-1)
 430         in  x
 431 -}
 432
 433 huge :: (RealFloat a) => a
 434 huge =
 435         let (_, u) = floatRange x
 436             d = floatDigits x
 437             x = encodeFloat (floatRadix x ^ d - 1) (u - d)
 438         in  x
 439 \end{code}