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