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,
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 -> PrimIO ()
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)
168 ppInterleave sep ps = ppSep (pi ps)
172 pi (x:xs) = (ppBeside x sep) : pi xs
175 ToDo: this could be better: main pt is: no extra spaces in between.
178 ppIntersperse sep ps = ppBesides (pi ps)
182 pi (x:xs) = (ppBeside x sep) : pi xs
185 Laziness is important in @ppBeside@. If the first thing is not a
186 single line it will return @False@ for the single-line boolean without
187 laying out the second.
190 ppBeside p1 p2 width is_vert
191 = case (p1 width False) of
192 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
193 MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2))
194 (MkDelay (ll1 + ll2))
196 ((width >= 0) && (sl1 && sl2))
197 -- This sequence of (&&)'s ensures that ppBeside
198 -- returns a False for sl as soon as possible.
199 where -- NB: for case alt
200 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
202 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-ll1) False
203 -- ToDo: if emp{1,2} then we really
204 -- should be passing on "is_vert" to p{2,1}.
207 ppBesides ps = foldr1 ppBeside ps
210 @ppBesideSP@ puts two things beside each other separated by a space.
213 ppBesideSP p1 p2 width is_vert
214 = case (p1 width False) of
215 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
216 MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2)))
219 ((width >= wi) && (sl1 && sl2))
220 where -- NB: for case alt
221 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
223 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False
225 li = if emp1 then 0 else ll1+1
226 wi = if emp1 then 0 else 1
227 sp = if emp1 || emp2 then cNil else (cCh ' ')
230 @ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@.
234 ppCat ps = foldr1 ppBesideSP ps
238 ppAbove p1 p2 width is_vert
239 = case (p1 width True) of
240 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
241 MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2))
243 -- ToDo: make ll depend on empties?
246 where -- NB: for case alt
247 nl = if emp1 || emp2 then cNil else cNL
248 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
249 MkDelay ll2 = x_ll2 -- Don't "optimise" this away!
250 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 width True
251 -- ToDo: ditto about passing is_vert if empties
254 ppAboves ps = foldr1 ppAbove ps
258 ppNest n p width False = p width False
259 ppNest n p width True
260 = case (p (width-n) True) of
261 MkPrettyRep seq (MkDelay ll) emp sl ->
262 MkPrettyRep (cIndent n seq) (MkDelay (ll+n)) emp sl
265 The length-check below \tr{(ll1+ll2+1) <= width} should really check for
266 max widths not the width of the last line.
269 ppHang p1 n p2 width is_vert -- This is a little bit stricter than it could
270 -- be made with a little more effort.
271 -- Eg the output always starts with seq1
272 = case (p1 width False) of
273 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
277 if (ll1 <= n) || sl2 then -- very ppBesideSP'ish
278 -- Hang it if p1 shorter than indent or if it doesn't fit
279 MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2)))
280 (MkDelay (ll1 + 1 + ll2))
284 -- Nest it (pretty ppAbove-ish)
285 MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2')))
286 (MkDelay ll2') -- ToDo: depend on empties
289 where -- NB: for case alt
290 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
292 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False
293 -- ToDo: more "is_vert if empty" stuff
295 seq2' = forceInfo x_ll2' emp2' sl2' x_seq2'
296 MkDelay ll2' = x_ll2' -- Don't "optimise" this away!
297 MkPrettyRep x_seq2' x_ll2' emp2' sl2' = p2 (width-n) False -- ToDo: True?
301 ppSep [] width is_vert = ppNil width is_vert
302 ppSep [p] width is_vert = p width is_vert
304 -- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable
305 -- ppSep [a, ppSep[b, ppSep [c, ... ]]]
307 ppSep ps width is_vert
308 = case (ppCat ps width is_vert) of
309 MkPrettyRep seq x_ll emp sl ->
310 if sl then -- Fits on one line
311 MkPrettyRep seq x_ll emp sl
313 ppAboves ps width is_vert -- Takes several lines
317 @speakNth@ converts an integer to a verbal index; eg 1 maps to
321 speakNth :: Int -> Pretty
323 speakNth 1 = ppStr "first"
324 speakNth 2 = ppStr "second"
325 speakNth 3 = ppStr "third"
326 speakNth 4 = ppStr "fourth"
327 speakNth 5 = ppStr "fifth"
328 speakNth 6 = ppStr "sixth"
329 speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ]
331 st_nd_rd_th | n_rem_10 == 1 = "st"
332 | n_rem_10 == 2 = "nd"
333 | n_rem_10 == 3 = "rd"
336 n_rem_10 = n `rem` 10
340 %************************************************************************
342 \subsection[Outputable-print]{Pretty-printing stuff}
344 %************************************************************************
347 #if defined(COMPILING_GHC)
348 -- to the end of file
350 prettyToUn :: Pretty -> Unpretty
353 = case (p 999999{-totally bogus width-} False{-also invented-}) of
354 MkPrettyRep seq ll emp sl -> seq
356 #endif {-COMPILING_GHC-}
359 -----------------------------------
362 fromRationalX :: (RealFloat a) => Rational -> a
366 h = ceiling (huge `asTypeOf` x)
367 b = toInteger (floatRadix x)
370 let d = denominator r'
373 let e = integerLogBase b (d `div` h) + 1
374 in fromRat (e0-e) (n % (d `div` (b^e)))
375 else if abs n > h then
376 let e = integerLogBase b (abs n `div` h) + 1
377 in fromRat (e0+e) ((n `div` (b^e)) % d)
379 scaleFloat e0 (fromRational r')
382 -- Compute the discrete log of i in base b.
383 -- Simplest way would be just divide i by b until it's smaller then b, but that would
384 -- be very slow! We are just slightly more clever.
385 integerLogBase :: Integer -> Integer -> Int
390 -- Try squaring the base first to cut down the number of divisions.
391 let l = 2 * integerLogBase (b*b) i
393 doDiv :: Integer -> Int -> Int
394 doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
396 doDiv (i `div` (b^l)) l
401 -- Compute smallest and largest floating point values.
403 tiny :: (RealFloat a) => a
405 let (l, _) = floatRange x
406 x = encodeFloat 1 (l-1)
410 huge :: (RealFloat a) => a
412 let (_, u) = floatRange x
414 x = encodeFloat (floatRadix x ^ d - 1) (u - d)