ghc/compiler/utils/Pretty.lhs

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