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
16 #if defined(COMPILING_GHC)
22 ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger,
24 #if __GLASGOW_HASKELL__
25 -- may be able to *replace* ppDouble
28 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
29 ppSemi, ppComma, ppEquals,
30 ppBracket, ppParens, ppQuote,
32 ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
33 ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
36 #if defined(COMPILING_GHC)
40 -- abstract type, to complete the interface...
44 #if defined(COMPILING_GHC)
46 CHK_Ubiq() -- debugging consistency check
50 import Unpretty ( SYN_IE(Unpretty) )
58 Based on John Hughes's pretty-printing library. Loosely. Very
61 %************************************************
63 \subsection{The interface}
65 %************************************************
69 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty
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
80 ppBracket :: Pretty -> Pretty -- put brackets around it
81 ppParens :: Pretty -> Pretty -- put parens around it
83 ppBeside :: Pretty -> Pretty -> Pretty
84 ppBesides :: [Pretty] -> Pretty
85 ppBesideSP :: Pretty -> Pretty -> Pretty
86 ppCat :: [Pretty] -> Pretty -- i.e., ppBesidesSP
88 ppAbove :: Pretty -> Pretty -> Pretty
89 ppAboves :: [Pretty] -> Pretty
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
97 ppShow :: Int -> Pretty -> [Char]
99 #if defined(COMPILING_GHC)
100 ppPutStr :: Handle -> Int -> Pretty -> IO ()
104 %************************************************
106 \subsection{The representation}
108 %************************************************
111 type Pretty = Int -- The width to print in
112 -> Bool -- True => vertical context
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
121 data Delay a = MkDelay a
123 forceDel (MkDelay _) r = r
126 forceBool False r = r
128 forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r))
131 = case (p width False) of
132 MkPrettyRep seq ll emp sl -> cShow seq
134 #if defined(COMPILING_GHC)
136 = case (p width False) of
137 MkPrettyRep seq ll emp sl -> cPutStr f seq
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.
144 ppStr s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
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)
150 ppInt n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
151 where s = show n; ls = length s
153 ppInteger n = ppStr (show n)
154 ppDouble n = ppStr (show n)
155 ppFloat n = ppStr (show n)
157 ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n)
161 ppLbrack = ppChar '['
162 ppRbrack = ppChar ']'
163 ppLparen = ppChar '('
164 ppRparen = ppChar ')'
167 ppEquals = ppChar '='
169 ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack)
170 ppParens p = ppBeside ppLparen (ppBeside p ppRparen)
171 ppQuote p = ppBeside (ppChar '`') (ppBeside p (ppChar '\''))
173 ppInterleave sep ps = ppSep (pi ps)
177 pi (x:xs) = (ppBeside x sep) : pi xs
180 ToDo: this could be better: main pt is: no extra spaces in between.
183 ppIntersperse sep ps = ppBesides (pi ps)
187 pi (x:xs) = (ppBeside x sep) : pi xs
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.
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))
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
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}.
212 ppBesides ps = foldr1 ppBeside ps
215 @ppBesideSP@ puts two things beside each other separated by a space.
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)))
224 ((width >= wi) && (sl1 && sl2))
225 where -- NB: for case alt
226 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
228 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False
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 ' ')
235 @ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@.
239 ppCat ps = foldr1 ppBesideSP ps
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))
248 -- ToDo: make ll depend on empties?
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
259 ppAboves ps = foldr1 ppAbove ps
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
270 The length-check below \tr{(ll1+ll2+1) <= width} should really check for
271 max widths not the width of the last line.
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 ->
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))
289 -- Nest it (pretty ppAbove-ish)
290 MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2')))
291 (MkDelay ll2') -- ToDo: depend on empties
294 where -- NB: for case alt
295 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
297 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False
298 -- ToDo: more "is_vert if empty" stuff
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?
306 ppSep [] width is_vert = ppNil width is_vert
307 ppSep [p] width is_vert = p width is_vert
309 -- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable
310 -- ppSep [a, ppSep[b, ppSep [c, ... ]]]
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
318 ppAboves ps width is_vert -- Takes several lines
322 @speakNth@ converts an integer to a verbal index; eg 1 maps to
326 speakNth :: Int -> Pretty
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 ]
336 st_nd_rd_th | n_rem_10 == 1 = "st"
337 | n_rem_10 == 2 = "nd"
338 | n_rem_10 == 3 = "rd"
341 n_rem_10 = n `rem` 10
345 %************************************************************************
347 \subsection[Outputable-print]{Pretty-printing stuff}
349 %************************************************************************
352 #if defined(COMPILING_GHC)
353 -- to the end of file
355 prettyToUn :: Pretty -> Unpretty
358 = case (p 999999{-totally bogus width-} False{-also invented-}) of
359 MkPrettyRep seq ll emp sl -> seq
361 #endif {-COMPILING_GHC-}
364 -----------------------------------
367 fromRationalX :: (RealFloat a) => Rational -> a
371 h = ceiling (huge `asTypeOf` x)
372 b = toInteger (floatRadix x)
375 let d = denominator r'
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)
384 scaleFloat e0 (fromRational r')
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
395 -- Try squaring the base first to cut down the number of divisions.
396 let l = 2 * integerLogBase (b*b) i
398 doDiv :: Integer -> Int -> Int
399 doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
401 doDiv (i `div` (b^l)) l
406 -- Compute smallest and largest floating point values.
408 tiny :: (RealFloat a) => a
410 let (l, _) = floatRange x
411 x = encodeFloat 1 (l-1)
415 huge :: (RealFloat a) => a
417 let (_, u) = floatRange x
419 x = encodeFloat (floatRadix x ^ d - 1) (u - d)