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