2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
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 codeStyle, -- UNUSED: stySwitch,
22 ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger,
24 #if __GLASGOW_HASKELL__ >= 23
25 -- may be able to *replace* ppDouble
28 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
29 ppSemi, ppComma, ppEquals,
31 ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
32 ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
34 #if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
38 -- abstract type, to complete the interface...
39 PrettyRep(..), CSeq, Delay
40 #if defined(COMPILING_GHC)
41 , GlobalSwitch, Unpretty(..)
46 #if defined(COMPILING_GHC)
47 import Unpretty ( Unpretty(..) )
48 import CmdLineOpts ( GlobalSwitch )
52 Based on John Hughes's pretty-printing library. For now, that code
53 and notes for it are in files \tr{pp-rjmh*} (ToDo: rm).
55 %************************************************
57 \subsection{The interface}
59 %************************************************
63 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty
65 ppStr :: [Char] -> Pretty
66 ppPStr :: FAST_STRING -> Pretty
67 ppChar :: Char -> Pretty
68 ppInt :: Int -> Pretty
69 ppInteger :: Integer -> Pretty
70 ppDouble :: Double -> Pretty
71 ppFloat :: Float -> Pretty
72 #if __GLASGOW_HASKELL__ >= 23
73 ppRational :: Rational -> Pretty
76 ppBeside :: Pretty -> Pretty -> Pretty
77 ppBesides :: [Pretty] -> Pretty
78 ppBesideSP :: Pretty -> Pretty -> Pretty
79 ppCat :: [Pretty] -> Pretty -- i.e., ppBesidesSP
81 ppAbove :: Pretty -> Pretty -> Pretty
82 ppAboves :: [Pretty] -> Pretty
84 ppInterleave :: Pretty -> [Pretty] -> Pretty
85 ppIntersperse :: Pretty -> [Pretty] -> Pretty -- no spaces between, no ppSep
86 ppSep :: [Pretty] -> Pretty
87 ppHang :: Pretty -> Int -> Pretty -> Pretty
88 ppNest :: Int -> Pretty -> Pretty
90 ppShow :: Int -> Pretty -> [Char]
92 #if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
93 # if __GLASGOW_HASKELL__ < 23
96 ppAppendFile :: _FILE -> Int -> Pretty -> PrimIO ()
100 %************************************************
102 \subsection{The representation}
104 %************************************************
107 type Pretty = Int -- The width to print in
108 -> Bool -- True => vertical context
112 = MkPrettyRep CSeq -- The text
113 (Delay Int) -- No of chars in last line
114 Bool -- True if empty object
115 Bool -- Fits on a single line in specified width
117 data Delay a = MkDelay a
119 forceDel (MkDelay _) r = r
122 forceBool False r = r
124 forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r))
127 = case (p width False) of
128 MkPrettyRep seq ll emp sl -> cShow seq
130 #if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
131 ppAppendFile f width p
132 = case (p width False) of
133 MkPrettyRep seq ll emp sl -> cAppendFile f seq
136 ppNil width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0)
137 -- Doesn't fit if width < 0, otherwise, ppNil
138 -- will make ppBesides always return True.
140 ppStr s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
142 ppPStr s width is_vert = MkPrettyRep (cPStr s) (MkDelay ls) False (width >= ls)
143 where ls = _LENGTH_ s
144 ppChar c width is_vert = MkPrettyRep (cCh c) (MkDelay 1) False (width >= 1)
146 ppInt n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
147 where s = show n; ls = length s
149 ppInteger n = ppStr (show n)
150 ppDouble n = ppStr (show n)
151 ppFloat n = ppStr (show n)
152 #if __GLASGOW_HASKELL__ >= 23
153 --ppRational n = ppStr (_showRational 30 n)
154 ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n)
159 ppLbrack = ppChar '['
160 ppRbrack = ppChar ']'
161 ppLparen = ppChar '('
162 ppRparen = ppChar ')'
165 ppEquals = ppChar '='
167 ppInterleave sep ps = ppSep (pi ps)
171 pi (x:xs) = (ppBeside x sep) : pi xs
174 ToDo: this could be better: main pt is: no extra spaces in between.
177 ppIntersperse sep ps = ppBesides (pi ps)
181 pi (x:xs) = (ppBeside x sep) : pi xs
184 Laziness is important in @ppBeside@. If the first thing is not a
185 single line it will return @False@ for the single-line boolean without
186 laying out the second.
189 ppBeside p1 p2 width is_vert
190 = case (p1 width False) of
191 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
192 MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2))
193 (MkDelay (ll1 + ll2))
195 ((width >= 0) && (sl1 && sl2))
196 -- This sequence of (&&)'s ensures that ppBeside
197 -- returns a False for sl as soon as possible.
198 where -- NB: for case alt
199 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
201 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-ll1) False
202 -- ToDo: if emp{1,2} then we really
203 -- should be passing on "is_vert" to p{2,1}.
206 ppBesides ps = foldr1 ppBeside ps
209 @ppBesideSP@ puts two things beside each other separated by a space.
212 ppBesideSP p1 p2 width is_vert
213 = case (p1 width False) of
214 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
215 MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2)))
218 ((width >= wi) && (sl1 && sl2))
219 where -- NB: for case alt
220 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
222 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False
224 li = if emp1 then 0 else ll1+1
225 wi = if emp1 then 0 else 1
226 sp = if emp1 || emp2 then cNil else (cCh ' ')
229 @ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@.
233 ppCat ps = foldr1 ppBesideSP ps
237 ppAbove p1 p2 width is_vert
238 = case (p1 width True) of
239 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
240 MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2))
242 -- ToDo: make ll depend on empties?
245 where -- NB: for case alt
246 nl = if emp1 || emp2 then cNil else cNL
247 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
248 MkDelay ll2 = x_ll2 -- Don't "optimise" this away!
249 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 width True
250 -- ToDo: ditto about passing is_vert if empties
253 ppAboves ps = foldr1 ppAbove ps
257 ppNest n p width False = p width False
258 ppNest n p width True
259 = case (p (width-n) True) of
260 MkPrettyRep seq (MkDelay ll) emp sl ->
261 MkPrettyRep (cIndent n seq) (MkDelay (ll+n)) emp sl
264 The length-check below \tr{(ll1+ll2+1) <= width} should really check for
265 max widths not the width of the last line.
268 ppHang p1 n p2 width is_vert -- This is a little bit stricter than it could
269 -- be made with a little more effort.
270 -- Eg the output always starts with seq1
271 = case (p1 width False) of
272 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
276 if (ll1 <= n) || sl2 then -- very ppBesideSP'ish
277 -- Hang it if p1 shorter than indent or if it doesn't fit
278 MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2)))
279 (MkDelay (ll1 + 1 + ll2))
283 -- Nest it (pretty ppAbove-ish)
284 MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2')))
285 (MkDelay ll2') -- ToDo: depend on empties
288 where -- NB: for case alt
289 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
291 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False
292 -- ToDo: more "is_vert if empty" stuff
294 seq2' = forceInfo x_ll2' emp2' sl2' x_seq2'
295 MkDelay ll2' = x_ll2' -- Don't "optimise" this away!
296 MkPrettyRep x_seq2' x_ll2' emp2' sl2' = p2 (width-n) False -- ToDo: True?
300 ppSep [] width is_vert = ppNil width is_vert
301 ppSep [p] width is_vert = p width is_vert
303 -- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable
304 -- ppSep [a, ppSep[b, ppSep [c, ... ]]]
306 ppSep ps width is_vert
307 = case (ppCat ps width is_vert) of
308 MkPrettyRep seq x_ll emp sl ->
309 if sl then -- Fits on one line
310 MkPrettyRep seq x_ll emp sl
312 ppAboves ps width is_vert -- Takes several lines
315 %************************************************************************
317 \subsection[Outputable-print]{Pretty-printing stuff}
319 %************************************************************************
321 ToDo: this is here for no-original-name reasons (mv?).
323 There is no clearly definitive list of @PprStyles@; I suggest the
327 #if defined(COMPILING_GHC)
328 -- to the end of file
331 = PprForUser -- Pretty-print in a way that will
332 -- make sense to the ordinary user;
333 -- must be very close to Haskell
334 -- syntax, etc. ToDo: how diff is
335 -- this from what pprInterface must
337 | PprDebug -- Standard debugging output
338 | PprShowAll -- Debugging output which leaves
339 -- nothing to the imagination
340 | PprInterface -- Interface generation
341 (GlobalSwitch -> Bool) -- (we can look at cmd-line flags)
342 | PprForC -- must print out C-acceptable names
343 (GlobalSwitch -> Bool) -- (ditto)
344 | PprUnfolding -- for non-interface intermodule info
345 (GlobalSwitch -> Bool) -- the compiler writes/reads
346 | PprForAsm -- must print out assembler-acceptable names
347 (GlobalSwitch -> Bool) -- (ditto)
348 Bool -- prefix CLabel with underscore?
349 (String -> String) -- format AsmTempLabel
352 The following test decides whether or not we are actually generating
353 code (either C or assembly).
355 codeStyle :: PprStyle -> Bool
356 codeStyle (PprForC _) = True
357 codeStyle (PprForAsm _ _ _) = True
361 stySwitch :: PprStyle -> GlobalSwitch -> Bool
362 stySwitch (PprInterface sw) = sw
363 stySwitch (PprForC sw) = sw
364 stySwitch (PprForAsm sw _ _) = sw
368 Orthogonal to these printing styles are (possibly) some command-line
369 flags that affect printing (often carried with the style). The most
370 likely ones are variations on how much type info is shown.
373 prettyToUn :: Pretty -> Unpretty
376 = case (p 999999{-totally bogus width-} False{-also invented-}) of
377 MkPrettyRep seq ll emp sl -> seq
379 #endif {-COMPILING_GHC-}
382 -----------------------------------
385 fromRationalX :: (RealFloat a) => Rational -> a
389 h = ceiling (huge `asTypeOf` x)
390 b = toInteger (floatRadix x)
393 let d = denominator r'
396 let e = integerLogBase b (d `div` h) + 1
397 in fromRat (e0-e) (n % (d `div` (b^e)))
398 else if abs n > h then
399 let e = integerLogBase b (abs n `div` h) + 1
400 in fromRat (e0+e) ((n `div` (b^e)) % d)
402 scaleFloat e0 (fromRational r')
405 -- Compute the discrete log of i in base b.
406 -- Simplest way would be just divide i by b until it's smaller then b, but that would
407 -- be very slow! We are just slightly more clever.
408 integerLogBase :: Integer -> Integer -> Int
413 -- Try squaring the base first to cut down the number of divisions.
414 let l = 2 * integerLogBase (b*b) i
416 doDiv :: Integer -> Int -> Int
417 doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
419 doDiv (i `div` (b^l)) l
424 -- Compute smallest and largest floating point values.
426 tiny :: (RealFloat a) => a
428 let (l, _) = floatRange x
429 x = encodeFloat 1 (l-1)
433 huge :: (RealFloat a) => a
435 let (_, u) = floatRange x
437 x = encodeFloat (floatRadix x ^ d - 1) (u - d)