2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Pretty]{Pretty-printing data type}
7 #if defined(COMPILING_GHC)
8 # include "HsVersions.h"
10 # define FAST_STRING String
11 # define _LENGTH_ length
17 #if defined(COMPILING_GHC)
20 ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger,
22 #if __GLASGOW_HASKELL__
23 -- may be able to *replace* ppDouble
26 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
27 ppSemi, ppComma, ppEquals,
28 ppBracket, ppParens, ppQuote,
30 ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
31 ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
34 #if defined(COMPILING_GHC)
38 -- abstract type, to complete the interface...
39 PrettyRep(..), CSeq, Delay
40 #if defined(COMPILING_GHC)
45 #if defined(COMPILING_GHC)
47 CHK_Ubiq() -- debugging consistency check
49 import Unpretty ( Unpretty(..) )
55 Based on John Hughes's pretty-printing library. Loosely. Very
58 %************************************************
60 \subsection{The interface}
62 %************************************************
66 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty
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
77 ppBracket :: Pretty -> Pretty -- put brackets around it
78 ppParens :: Pretty -> Pretty -- put parens around it
80 ppBeside :: Pretty -> Pretty -> Pretty
81 ppBesides :: [Pretty] -> Pretty
82 ppBesideSP :: Pretty -> Pretty -> Pretty
83 ppCat :: [Pretty] -> Pretty -- i.e., ppBesidesSP
85 ppAbove :: Pretty -> Pretty -> Pretty
86 ppAboves :: [Pretty] -> Pretty
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
94 ppShow :: Int -> Pretty -> [Char]
96 #if defined(COMPILING_GHC)
97 ppAppendFile :: _FILE -> Int -> Pretty -> IO ()
101 %************************************************
103 \subsection{The representation}
105 %************************************************
108 type Pretty = Int -- The width to print in
109 -> Bool -- True => vertical context
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
118 data Delay a = MkDelay a
120 forceDel (MkDelay _) r = r
123 forceBool False r = r
125 forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r))
128 = case (p width False) of
129 MkPrettyRep seq ll emp sl -> cShow seq
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
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.
141 ppStr s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
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)
147 ppInt n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
148 where s = show n; ls = length s
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)
157 ppLbrack = ppChar '['
158 ppRbrack = ppChar ']'
159 ppLparen = ppChar '('
160 ppRparen = ppChar ')'
163 ppEquals = ppChar '='
165 ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack)
166 ppParens p = ppBeside ppLparen (ppBeside p ppRparen)
167 ppQuote p = ppBeside (ppChar '`') (ppBeside p (ppChar '\''))
169 ppInterleave sep ps = ppSep (pi ps)
173 pi (x:xs) = (ppBeside x sep) : pi xs
176 ToDo: this could be better: main pt is: no extra spaces in between.
179 ppIntersperse sep ps = ppBesides (pi ps)
183 pi (x:xs) = (ppBeside x sep) : pi xs
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.
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))
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
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}.
208 ppBesides ps = foldr1 ppBeside ps
211 @ppBesideSP@ puts two things beside each other separated by a space.
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)))
220 ((width >= wi) && (sl1 && sl2))
221 where -- NB: for case alt
222 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
224 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False
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 ' ')
231 @ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@.
235 ppCat ps = foldr1 ppBesideSP ps
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))
244 -- ToDo: make ll depend on empties?
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
255 ppAboves ps = foldr1 ppAbove ps
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
266 The length-check below \tr{(ll1+ll2+1) <= width} should really check for
267 max widths not the width of the last line.
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 ->
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))
285 -- Nest it (pretty ppAbove-ish)
286 MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2')))
287 (MkDelay ll2') -- ToDo: depend on empties
290 where -- NB: for case alt
291 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
293 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False
294 -- ToDo: more "is_vert if empty" stuff
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?
302 ppSep [] width is_vert = ppNil width is_vert
303 ppSep [p] width is_vert = p width is_vert
305 -- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable
306 -- ppSep [a, ppSep[b, ppSep [c, ... ]]]
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
314 ppAboves ps width is_vert -- Takes several lines
318 @speakNth@ converts an integer to a verbal index; eg 1 maps to
322 speakNth :: Int -> Pretty
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 ]
332 st_nd_rd_th | n_rem_10 == 1 = "st"
333 | n_rem_10 == 2 = "nd"
334 | n_rem_10 == 3 = "rd"
337 n_rem_10 = n `rem` 10
341 %************************************************************************
343 \subsection[Outputable-print]{Pretty-printing stuff}
345 %************************************************************************
348 #if defined(COMPILING_GHC)
349 -- to the end of file
351 prettyToUn :: Pretty -> Unpretty
354 = case (p 999999{-totally bogus width-} False{-also invented-}) of
355 MkPrettyRep seq ll emp sl -> seq
357 #endif {-COMPILING_GHC-}
360 -----------------------------------
363 fromRationalX :: (RealFloat a) => Rational -> a
367 h = ceiling (huge `asTypeOf` x)
368 b = toInteger (floatRadix x)
371 let d = denominator r'
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)
380 scaleFloat e0 (fromRational r')
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
391 -- Try squaring the base first to cut down the number of divisions.
392 let l = 2 * integerLogBase (b*b) i
394 doDiv :: Integer -> Int -> Int
395 doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
397 doDiv (i `div` (b^l)) l
402 -- Compute smallest and largest floating point values.
404 tiny :: (RealFloat a) => a
406 let (l, _) = floatRange x
407 x = encodeFloat 1 (l-1)
411 huge :: (RealFloat a) => a
413 let (_, u) = floatRange x
415 x = encodeFloat (floatRadix x ^ d - 1) (u - d)