[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / lib / hbc / Printf.hs
1 --
2 -- A C printf like formatter.
3 -- Conversion specs:
4 -- - left adjust
5 -- num field width
6 -- * as num, but taken from argument list
7 -- . separates width from precision
8 -- Formatting characters:
9 -- c Char, Int, Integer
10 -- d Char, Int, Integer
11 -- o Char, Int, Integer
12 -- x Char, Int, Integer
13 -- u Char, Int, Integer
14 -- f Float, Double
15 -- g Float, Double
16 -- e Float, Double
17 -- s String
18 --
19 module Printf(UPrintf(..), printf) where
20
21 #if defined(__HBC__)
22 import LMLfmtf
23 #endif
24
25 #if defined(__YALE_HASKELL__)
26 import PrintfPrims
27 #endif
28
29 #if defined(__GLASGOW_HASKELL__)
30 import PreludeGlaST
31 import TyArray ( _ByteArray(..) )
32 #endif
33
34 data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
35
36 printf :: String -> [UPrintf] -> String
37 printf "" [] = ""
38 printf "" (_:_) = fmterr
39 printf ('%':'%':cs) us = '%':printf cs us
40 printf ('%':_) [] = argerr
41 printf ('%':cs) us@(_:_) = fmt cs us
42 printf (c:cs) us = c:printf cs us
43
44 fmt :: String -> [UPrintf] -> String
45 fmt cs us =
46 let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
47 adjust (pre, str) =
48 let lstr = length str
49 lpre = length pre
50 fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
51 in if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
52 in
53 case cs' of
54 [] -> fmterr
55 c:cs'' ->
56 case us' of
57 [] -> argerr
58 u:us'' ->
59 (case c of
60 'c' -> adjust ("", [chr (toint u)])
61 'd' -> adjust (fmti u)
62 'x' -> adjust ("", fmtu 16 u)
63 'o' -> adjust ("", fmtu 8 u)
64 'u' -> adjust ("", fmtu 10 u)
65 #if defined __YALE_HASKELL__
66 'e' -> adjust (fmte prec (todbl u))
67 'f' -> adjust (fmtf prec (todbl u))
68 'g' -> adjust (fmtg prec (todbl u))
69 #else
70 'e' -> adjust (dfmt c prec (todbl u))
71 'f' -> adjust (dfmt c prec (todbl u))
72 'g' -> adjust (dfmt c prec (todbl u))
73 #endif
74 's' -> adjust ("", tostr u)
75 c -> perror ("bad formatting char " ++ [c])
76 ) ++ printf cs'' us''
77
78 fmti (UInt i) = if i < 0 then
79 if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
80 else
81 ("", itos i)
82 fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
83 fmti (UChar c) = fmti (UInt (ord c))
84 fmti u = baderr
85
86 fmtu b (UInt i) = if i < 0 then
87 if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
88 else
89 itosb b (toInteger i)
90 fmtu b (UInteger i) = itosb b i
91 fmtu b (UChar c) = itosb b (toInteger (ord c))
92 fmtu b u = baderr
93
94 maxi :: Integer
95 maxi = (toInteger maxInt + 1) * 2
96
97 toint (UInt i) = i
98 toint (UInteger i) = toInt i
99 toint (UChar c) = ord c
100 toint u = baderr
101
102 tostr (UString s) = s
103 tostr u = baderr
104
105 todbl (UDouble d) = d
106 #if defined(__GLASGOW_HASKELL__)
107 todbl (UFloat (F# f)) = D# (float2Double# f) -- What a great system(TM) !
108 #else
109 todbl (UFloat f) = fromRational (toRational f)
110 #endif
111 todbl u = baderr
112
113 itos n =
114 if n < 10 then
115 [chr (ord '0' + toInt n)]
116 else
117 let (q, r) = quotRem n 10 in
118 itos q ++ [chr (ord '0' + toInt r)]
119
120 chars :: Array Int Char
121 #if __HASKELL1__ < 3
122 chars = array (0,15) (zipWith (:=) [0..] "0123456789abcdef")
123 #else
124 chars = array (0,15) (zipWith (\x y -> (x,y)) [0..] "0123456789abcdef")
125 #endif
126
127 itosb :: Integer -> Integer -> String
128 itosb b n =
129 if n < b then
130 [chars ! fromInteger n]
131 else
132 let (q, r) = quotRem n b in
133 itosb b q ++ [chars ! fromInteger r]
134
135 stoi :: Int -> String -> (Int, String)
136 stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs
137 stoi a cs = (a, cs)
138
139 getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
140 getSpecs l z ('-':cs) us = getSpecs True z cs us
141 getSpecs l z ('0':cs) us = getSpecs l True cs us
142 getSpecs l z ('*':cs) us =
143 case us of
144 [] -> argerr
145 nu : us' ->
146 let n = toint nu
147 (p, cs'', us'') =
148 case cs of
149 '.':'*':r -> case us' of { [] -> argerr; pu:us'' -> (toint pu, r, us'') }
150 '.':r -> let (n, cs') = stoi 0 r in (n, cs', us')
151 _ -> (-1, cs, us')
152 in (n, p, l, z, cs'', us'')
153 getSpecs l z cs@(c:_) us | isDigit c =
154 let (n, cs') = stoi 0 cs
155 (p, cs'') = case cs' of
156 '.':r -> stoi 0 r
157 _ -> (-1, cs')
158 in (n, p, l, z, cs'', us)
159 getSpecs l z cs us = (0, -1, l, z, cs, us)
160
161 #if !defined(__YALE_HASKELL__)
162 dfmt :: Char -> Int -> Double -> (String, String)
163 #endif
164
165 #if defined(__GLASGOW_HASKELL__)
166 dfmt c{-e,f, or g-} prec d
167 = unsafePerformPrimIO (
168 newCharArray (0 :: Int, 511){-pathetic malloc-} `thenStrictlyST` \ sprintf_here ->
169 let
170 sprintf_fmt = "%1" ++ (if prec < 0 then "" else '.':itos prec) ++ [c]
171 in
172 _ccall_ sprintf sprintf_here sprintf_fmt d `seqPrimIO`
173 freezeCharArray sprintf_here `thenST` \ (_ByteArray _ arr#) ->
174 let
175 unpack :: Int# -> [Char]
176 unpack nh = case (ord# (indexCharArray# arr# nh)) of
177 0# -> []
178 ch -> case (nh +# 1#) of
179 mh -> C# (chr# ch) : unpack mh
180 in
181 returnPrimIO (
182 case (indexCharArray# arr# 0#) of
183 '-'# -> ("-", unpack 1#)
184 _ -> ("" , unpack 0#)
185 )
186 )
187 #endif
188
189 #if defined(__HBC__)
190 dfmt c p d =
191 case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of
192 '-':cs -> ("-", cs)
193 cs -> ("" , cs)
194 #endif
195
196 #if defined(__YALE_HASKELL__)
197 fmte p d =
198 case (primFmte p d) of
199 '-':cs -> ("-",cs)
200 cs -> ("",cs)
201 fmtf p d =
202 case (primFmtf p d) of
203 '-':cs -> ("-",cs)
204 cs -> ("",cs)
205 fmtg p d =
206 case (primFmtg p d) of
207 '-':cs -> ("-",cs)
208 cs -> ("",cs)
209 #endif
210
211 perror s = error ("Printf.printf: "++s)
212 fmterr = perror "formatting string ended prematurely"
213 argerr = perror "argument list ended prematurely"
214 baderr = perror "bad argument"
215
216 #if defined(__YALE_HASKELL__)
217 -- This is needed because standard Haskell does not have toInt
218
219 toInt :: Integral a => a -> Int
220 toInt x = fromIntegral x
221 #endif