[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / lib / ghc / Pretty.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
3 %
4 \section[Pretty]{Pretty-printing data type}
5
6 \begin{code}
7 #if defined(COMPILING_GHC)
8 # include "HsVersions.h"
9 #else
10 # define FAST_STRING String
11 # define _LENGTH_    length
12 #endif
13
14 module Pretty (
15         Pretty(..),
16
17 #if defined(COMPILING_GHC)
18         PprStyle(..),
19         prettyToUn,
20         codeStyle, -- UNUSED: stySwitch,
21 #endif
22         ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger,
23         ppFloat, ppDouble,
24 #if __GLASGOW_HASKELL__ >= 23
25         -- may be able to *replace* ppDouble
26         ppRational,
27 #endif
28         ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
29         ppSemi, ppComma, ppEquals,
30
31         ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
32         ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
33         ppShow,
34 #if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
35         ppAppendFile,
36 #endif
37
38         -- abstract type, to complete the interface...
39         PrettyRep(..), CSeq, Delay
40 #if defined(COMPILING_GHC)
41         , GlobalSwitch, Unpretty(..)
42 #endif
43    ) where
44
45 import CharSeq
46 #if defined(COMPILING_GHC)
47 import Unpretty         ( Unpretty(..) )
48 import CmdLineOpts      ( GlobalSwitch )
49 #endif
50 \end{code}
51
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).
54
55 %************************************************
56 %*                                              *
57         \subsection{The interface}
58 %*                                              *
59 %************************************************
60
61 \begin{code}
62 ppNil           :: Pretty
63 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty
64
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
74 #endif
75
76 ppBeside        :: Pretty -> Pretty -> Pretty
77 ppBesides       :: [Pretty] -> Pretty
78 ppBesideSP      :: Pretty -> Pretty -> Pretty
79 ppCat           :: [Pretty] -> Pretty           -- i.e., ppBesidesSP
80
81 ppAbove         :: Pretty -> Pretty -> Pretty
82 ppAboves        :: [Pretty] -> Pretty
83
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
89
90 ppShow          :: Int -> Pretty -> [Char]
91
92 #if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
93 # if __GLASGOW_HASKELL__ < 23
94 #  define _FILE _Addr
95 # endif
96 ppAppendFile    :: _FILE -> Int -> Pretty -> PrimIO ()
97 #endif
98 \end{code}
99
100 %************************************************
101 %*                                              *
102         \subsection{The representation}
103 %*                                              *
104 %************************************************
105
106 \begin{code}
107 type Pretty = Int       -- The width to print in
108            -> Bool      -- True => vertical context
109            -> PrettyRep
110
111 data PrettyRep
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
116
117 data Delay a = MkDelay a
118
119 forceDel (MkDelay _) r = r
120
121 forceBool True  r = r
122 forceBool False r = r
123
124 forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r))
125
126 ppShow width p
127   = case (p width False) of
128       MkPrettyRep seq ll emp sl -> cShow seq
129
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
134 #endif
135
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.
139
140 ppStr  s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
141                            where ls = length s
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)
145
146 ppInt  n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
147                            where s = show n; ls = length s
148
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)
155 #endif
156
157 ppSP      = ppChar ' '
158 pp'SP     = ppStr ", "
159 ppLbrack  = ppChar '['
160 ppRbrack  = ppChar ']'
161 ppLparen  = ppChar '('
162 ppRparen  = ppChar ')'
163 ppSemi    = ppChar ';'
164 ppComma   = ppChar ','
165 ppEquals  = ppChar '='
166
167 ppInterleave sep ps = ppSep (pi ps)
168   where
169    pi []        = []
170    pi [x]       = [x]
171    pi (x:xs)    = (ppBeside x sep) : pi xs
172 \end{code}
173
174 ToDo: this could be better: main pt is: no extra spaces in between.
175
176 \begin{code}
177 ppIntersperse sep ps = ppBesides (pi ps)
178   where
179    pi []        = []
180    pi [x]       = [x]
181    pi (x:xs)    = (ppBeside x sep) : pi xs
182 \end{code}
183
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.
187
188 \begin{code}
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))
194                       (emp1 && emp2)
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
200          MkDelay ll2 = x_ll2
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}.
204
205 ppBesides [] = ppNil
206 ppBesides ps = foldr1 ppBeside ps
207 \end{code}
208
209 @ppBesideSP@ puts two things beside each other separated by a space.
210
211 \begin{code}
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)))
216                    (MkDelay (li + ll2))
217                    (emp1 && emp2)
218                    ((width >= wi) && (sl1 && sl2))
219        where -- NB: for case alt
220          seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
221          MkDelay ll2 = x_ll2
222          MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False
223          li, wi :: Int
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 ' ')
227 \end{code}
228
229 @ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@.
230
231 \begin{code}
232 ppCat []  = ppNil
233 ppCat ps  = foldr1 ppBesideSP ps
234 \end{code}
235
236 \begin{code}
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))
241                       (MkDelay ll2)
242                       -- ToDo: make ll depend on empties?
243                       (emp1 && emp2)
244                       False
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
251
252 ppAboves [] = ppNil
253 ppAboves ps = foldr1 ppAbove ps
254 \end{code}
255
256 \begin{code}
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
262 \end{code}
263
264 The length-check below \tr{(ll1+ll2+1) <= width} should really check for
265 max widths not the width of the last line.
266
267 \begin{code}
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 ->
273           if emp1 then
274               p2 width is_vert
275           else 
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))
280                         False
281                         (sl1 && sl2)
282           else
283               -- Nest it (pretty ppAbove-ish)
284               MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2')))
285                         (MkDelay ll2') -- ToDo: depend on empties
286                         False
287                         False
288        where -- NB: for case alt
289          seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
290          MkDelay ll2 = x_ll2
291          MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False
292              -- ToDo: more "is_vert if empty" stuff
293
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?
297 \end{code}
298
299 \begin{code}
300 ppSep []  width is_vert = ppNil width is_vert
301 ppSep [p] width is_vert = p     width is_vert
302
303 -- CURRENT, but BAD.  Quadratic behaviour on the perfectly reasonable
304 --      ppSep [a, ppSep[b, ppSep [c, ... ]]]
305
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
311         else
312            ppAboves ps width is_vert    -- Takes several lines
313 \end{code}
314
315 %************************************************************************
316 %*                                                                      *
317 \subsection[Outputable-print]{Pretty-printing stuff}
318 %*                                                                      *
319 %************************************************************************
320
321 ToDo: this is here for no-original-name reasons (mv?).
322
323 There is no clearly definitive list of @PprStyles@; I suggest the
324 following:
325
326 \begin{code}
327 #if defined(COMPILING_GHC)
328     -- to the end of file
329
330 data PprStyle
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
336                                 -- do?
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
350 \end{code}
351
352 The following test decides whether or not we are actually generating
353 code (either C or assembly).
354 \begin{code}
355 codeStyle :: PprStyle -> Bool
356 codeStyle (PprForC _) = True
357 codeStyle (PprForAsm _ _ _) = True
358 codeStyle _ = False
359
360 {- UNUSED:
361 stySwitch :: PprStyle -> GlobalSwitch -> Bool
362 stySwitch (PprInterface sw) = sw
363 stySwitch (PprForC sw) = sw
364 stySwitch (PprForAsm sw _ _) = sw
365 -}
366 \end{code}
367
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.
371
372 \begin{code}
373 prettyToUn :: Pretty -> Unpretty
374
375 prettyToUn p
376   = case (p 999999{-totally bogus width-} False{-also invented-}) of
377       MkPrettyRep seq ll emp sl -> seq
378
379 #endif {-COMPILING_GHC-}
380 \end{code}
381
382 -----------------------------------
383 \begin{code}
384 -- from Lennart
385 fromRationalX :: (RealFloat a) => Rational -> a
386
387 fromRationalX r =
388         let 
389             h = ceiling (huge `asTypeOf` x)
390             b = toInteger (floatRadix x)
391             x = fromRat 0 r
392             fromRat e0 r' =
393                 let d = denominator r'
394                     n = numerator r'
395                 in  if d > h then
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)
401                     else
402                        scaleFloat e0 (fromRational r')
403         in  x
404
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
409 integerLogBase b i =
410      if i < b then
411         0
412      else
413         -- Try squaring the base first to cut down the number of divisions.
414         let l = 2 * integerLogBase (b*b) i
415
416             doDiv :: Integer -> Int -> Int
417             doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
418         in
419         doDiv (i `div` (b^l)) l
420
421
422 ------------
423
424 -- Compute smallest and largest floating point values.
425 {-
426 tiny :: (RealFloat a) => a
427 tiny =
428         let (l, _) = floatRange x
429             x = encodeFloat 1 (l-1)
430         in  x
431 -}
432
433 huge :: (RealFloat a) => a
434 huge =
435         let (_, u) = floatRange x
436             d = floatDigits x
437             x = encodeFloat (floatRadix x ^ d - 1) (u - d)
438         in  x
439 \end{code}