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