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, ppCurlies,
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 ppCurlies p = ppBeside (ppChar '{') (ppBeside p (ppChar '}'))
172 ppQuote p = ppBeside (ppChar '`') (ppBeside p (ppChar '\''))
174 ppInterleave sep ps = ppSep (pi ps)
178 pi (x:xs) = (ppBeside x sep) : pi xs
181 ToDo: this could be better: main pt is: no extra spaces in between.
184 ppIntersperse sep ps = ppBesides (pi ps)
188 pi (x:xs) = (ppBeside x sep) : pi xs
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.
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))
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
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}.
213 ppBesides ps = foldr1 ppBeside ps
216 @ppBesideSP@ puts two things beside each other separated by a space.
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)))
225 ((width >= wi) && (sl1 && sl2))
226 where -- NB: for case alt
227 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
229 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False
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 ' ')
236 @ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@.
240 ppCat ps = foldr1 ppBesideSP ps
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))
249 -- ToDo: make ll depend on empties?
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
260 ppAboves ps = foldr1 ppAbove ps
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
271 The length-check below \tr{(ll1+ll2+1) <= width} should really check for
272 max widths not the width of the last line.
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 ->
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))
290 -- Nest it (pretty ppAbove-ish)
291 MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2')))
292 (MkDelay ll2') -- ToDo: depend on empties
295 where -- NB: for case alt
296 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
298 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False
299 -- ToDo: more "is_vert if empty" stuff
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?
307 ppSep [] width is_vert = ppNil width is_vert
308 ppSep [p] width is_vert = p width is_vert
310 -- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable
311 -- ppSep [a, ppSep[b, ppSep [c, ... ]]]
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
319 ppAboves ps width is_vert -- Takes several lines
323 @speakNth@ converts an integer to a verbal index; eg 1 maps to
327 speakNth :: Int -> Pretty
329 speakNth 1 = ppStr "first"
330 speakNth 2 = ppStr "second"
331 speakNth 3 = ppStr "third"
332 speakNth 4 = ppStr "fourth"
333 speakNth 5 = ppStr "fifth"
334 speakNth 6 = ppStr "sixth"
335 speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ]
337 st_nd_rd_th | n_rem_10 == 1 = "st"
338 | n_rem_10 == 2 = "nd"
339 | n_rem_10 == 3 = "rd"
342 n_rem_10 = n `rem` 10
346 %************************************************************************
348 \subsection[Outputable-print]{Pretty-printing stuff}
350 %************************************************************************
353 #if defined(COMPILING_GHC)
354 -- to the end of file
356 prettyToUn :: Pretty -> Unpretty
359 = case (p 999999{-totally bogus width-} False{-also invented-}) of
360 MkPrettyRep seq ll emp sl -> seq
362 #endif {-COMPILING_GHC-}
365 -----------------------------------
368 fromRationalX :: (RealFloat a) => Rational -> a
372 h = ceiling (huge `asTypeOf` x)
373 b = toInteger (floatRadix x)
376 let d = denominator r'
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)
385 scaleFloat e0 (fromRational r')
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
396 -- Try squaring the base first to cut down the number of divisions.
397 let l = 2 * integerLogBase (b*b) i
399 doDiv :: Integer -> Int -> Int
400 doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
402 doDiv (i `div` (b^l)) l
407 -- Compute smallest and largest floating point values.
409 tiny :: (RealFloat a) => a
411 let (l, _) = floatRange x
412 x = encodeFloat 1 (l-1)
416 huge :: (RealFloat a) => a
418 let (_, u) = floatRange x
420 x = encodeFloat (floatRadix x ^ d - 1) (u - d)