SafeHaskell: Added SafeHaskell to base
[packages/base.git] / Text / Printf.hs
1 {-# LANGUAGE Safe #-}
2 {-# LANGUAGE CPP #-}
3
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module : Text.Printf
7 -- Copyright : (c) Lennart Augustsson, 2004-2008
8 -- License : BSD-style (see the file libraries/base/LICENSE)
9 --
10 -- Maintainer : lennart@augustsson.net
11 -- Stability : provisional
12 -- Portability : portable
13 --
14 -- A C printf like formatter.
15 --
16 -----------------------------------------------------------------------------
17
18 {-# Language CPP #-}
19
20 module Text.Printf(
21 printf, hPrintf,
22 PrintfType, HPrintfType, PrintfArg, IsChar
23 ) where
24
25 import Prelude
26 import Data.Char
27 import Data.Int
28 import Data.Word
29 import Numeric(showEFloat, showFFloat, showGFloat)
30 import System.IO
31
32 -------------------
33
34 -- | Format a variable number of arguments with the C-style formatting string.
35 -- The return value is either 'String' or @('IO' a)@.
36 --
37 -- The format string consists of ordinary characters and /conversion
38 -- specifications/, which specify how to format one of the arguments
39 -- to printf in the output string. A conversion specification begins with the
40 -- character @%@, followed by one or more of the following flags:
41 --
42 -- > - left adjust (default is right adjust)
43 -- > + always use a sign (+ or -) for signed conversions
44 -- > 0 pad with zeroes rather than spaces
45 --
46 -- followed optionally by a field width:
47 --
48 -- > num field width
49 -- > * as num, but taken from argument list
50 --
51 -- followed optionally by a precision:
52 --
53 -- > .num precision (number of decimal places)
54 --
55 -- and finally, a format character:
56 --
57 -- > c character Char, Int, Integer, ...
58 -- > d decimal Char, Int, Integer, ...
59 -- > o octal Char, Int, Integer, ...
60 -- > x hexadecimal Char, Int, Integer, ...
61 -- > X hexadecimal Char, Int, Integer, ...
62 -- > u unsigned decimal Char, Int, Integer, ...
63 -- > f floating point Float, Double
64 -- > g general format float Float, Double
65 -- > G general format float Float, Double
66 -- > e exponent format float Float, Double
67 -- > E exponent format float Float, Double
68 -- > s string String
69 --
70 -- Mismatch between the argument types and the format string will cause
71 -- an exception to be thrown at runtime.
72 --
73 -- Examples:
74 --
75 -- > > printf "%d\n" (23::Int)
76 -- > 23
77 -- > > printf "%s %s\n" "Hello" "World"
78 -- > Hello World
79 -- > > printf "%.2f\n" pi
80 -- > 3.14
81 --
82 printf :: (PrintfType r) => String -> r
83 printf fmts = spr fmts []
84
85 -- | Similar to 'printf', except that output is via the specified
86 -- 'Handle'. The return type is restricted to @('IO' a)@.
87 hPrintf :: (HPrintfType r) => Handle -> String -> r
88 hPrintf hdl fmts = hspr hdl fmts []
89
90 -- |The 'PrintfType' class provides the variable argument magic for
91 -- 'printf'. Its implementation is intentionally not visible from
92 -- this module. If you attempt to pass an argument of a type which
93 -- is not an instance of this class to 'printf' or 'hPrintf', then
94 -- the compiler will report it as a missing instance of 'PrintfArg'.
95 class PrintfType t where
96 spr :: String -> [UPrintf] -> t
97
98 -- | The 'HPrintfType' class provides the variable argument magic for
99 -- 'hPrintf'. Its implementation is intentionally not visible from
100 -- this module.
101 class HPrintfType t where
102 hspr :: Handle -> String -> [UPrintf] -> t
103
104 {- not allowed in Haskell 98
105 instance PrintfType String where
106 spr fmt args = uprintf fmt (reverse args)
107 -}
108 instance (IsChar c) => PrintfType [c] where
109 spr fmts args = map fromChar (uprintf fmts (reverse args))
110
111 instance PrintfType (IO a) where
112 spr fmts args = do
113 putStr (uprintf fmts (reverse args))
114 return undefined
115
116 instance HPrintfType (IO a) where
117 hspr hdl fmts args = do
118 hPutStr hdl (uprintf fmts (reverse args))
119 return undefined
120
121 instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
122 spr fmts args = \ a -> spr fmts (toUPrintf a : args)
123
124 instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
125 hspr hdl fmts args = \ a -> hspr hdl fmts (toUPrintf a : args)
126
127 class PrintfArg a where
128 toUPrintf :: a -> UPrintf
129
130 instance PrintfArg Char where
131 toUPrintf c = UChar c
132
133 {- not allowed in Haskell 98
134 instance PrintfArg String where
135 toUPrintf s = UString s
136 -}
137 instance (IsChar c) => PrintfArg [c] where
138 toUPrintf = UString . map toChar
139
140 instance PrintfArg Int where
141 toUPrintf = uInteger
142
143 instance PrintfArg Int8 where
144 toUPrintf = uInteger
145
146 instance PrintfArg Int16 where
147 toUPrintf = uInteger
148
149 instance PrintfArg Int32 where
150 toUPrintf = uInteger
151
152 instance PrintfArg Int64 where
153 toUPrintf = uInteger
154
155 #ifndef __NHC__
156 instance PrintfArg Word where
157 toUPrintf = uInteger
158 #endif
159
160 instance PrintfArg Word8 where
161 toUPrintf = uInteger
162
163 instance PrintfArg Word16 where
164 toUPrintf = uInteger
165
166 instance PrintfArg Word32 where
167 toUPrintf = uInteger
168
169 instance PrintfArg Word64 where
170 toUPrintf = uInteger
171
172 instance PrintfArg Integer where
173 toUPrintf = UInteger 0
174
175 instance PrintfArg Float where
176 toUPrintf = UFloat
177
178 instance PrintfArg Double where
179 toUPrintf = UDouble
180
181 uInteger :: (Integral a, Bounded a) => a -> UPrintf
182 uInteger x = UInteger (toInteger $ minBound `asTypeOf` x) (toInteger x)
183
184 class IsChar c where
185 toChar :: c -> Char
186 fromChar :: Char -> c
187
188 instance IsChar Char where
189 toChar c = c
190 fromChar c = c
191
192 -------------------
193
194 data UPrintf = UChar Char | UString String | UInteger Integer Integer | UFloat Float | UDouble Double
195
196 uprintf :: String -> [UPrintf] -> String
197 uprintf "" [] = ""
198 uprintf "" (_:_) = fmterr
199 uprintf ('%':'%':cs) us = '%':uprintf cs us
200 uprintf ('%':_) [] = argerr
201 uprintf ('%':cs) us@(_:_) = fmt cs us
202 uprintf (c:cs) us = c:uprintf cs us
203
204 fmt :: String -> [UPrintf] -> String
205 fmt cs us =
206 let (width, prec, ladj, zero, plus, cs', us') = getSpecs False False False cs us
207 adjust (pre, str) =
208 let lstr = length str
209 lpre = length pre
210 fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
211 in if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
212 adjust' ("", str) | plus = adjust ("+", str)
213 adjust' ps = adjust ps
214 in
215 case cs' of
216 [] -> fmterr
217 c:cs'' ->
218 case us' of
219 [] -> argerr
220 u:us'' ->
221 (case c of
222 'c' -> adjust ("", [toEnum (toint u)])
223 'd' -> adjust' (fmti prec u)
224 'i' -> adjust' (fmti prec u)
225 'x' -> adjust ("", fmtu 16 prec u)
226 'X' -> adjust ("", map toUpper $ fmtu 16 prec u)
227 'o' -> adjust ("", fmtu 8 prec u)
228 'u' -> adjust ("", fmtu 10 prec u)
229 'e' -> adjust' (dfmt' c prec u)
230 'E' -> adjust' (dfmt' c prec u)
231 'f' -> adjust' (dfmt' c prec u)
232 'g' -> adjust' (dfmt' c prec u)
233 'G' -> adjust' (dfmt' c prec u)
234 's' -> adjust ("", tostr prec u)
235 _ -> perror ("bad formatting char " ++ [c])
236 ) ++ uprintf cs'' us''
237
238 fmti :: Int -> UPrintf -> (String, String)
239 fmti prec (UInteger _ i) = if i < 0 then ("-", integral_prec prec (show (-i))) else ("", integral_prec prec (show i))
240 fmti _ (UChar c) = fmti 0 (uInteger (fromEnum c))
241 fmti _ _ = baderr
242
243 fmtu :: Integer -> Int -> UPrintf -> String
244 fmtu b prec (UInteger l i) = integral_prec prec (itosb b (if i < 0 then -2*l + i else i))
245 fmtu b _ (UChar c) = itosb b (toInteger (fromEnum c))
246 fmtu _ _ _ = baderr
247
248 integral_prec :: Int -> String -> String
249 integral_prec prec integral = (replicate (prec - (length integral)) '0') ++ integral
250
251 toint :: UPrintf -> Int
252 toint (UInteger _ i) = fromInteger i
253 toint (UChar c) = fromEnum c
254 toint _ = baderr
255
256 tostr :: Int -> UPrintf -> String
257 tostr n (UString s) = if n >= 0 then take n s else s
258 tostr _ _ = baderr
259
260 itosb :: Integer -> Integer -> String
261 itosb b n =
262 if n < b then
263 [intToDigit $ fromInteger n]
264 else
265 let (q, r) = quotRem n b in
266 itosb b q ++ [intToDigit $ fromInteger r]
267
268 stoi :: Int -> String -> (Int, String)
269 stoi a (c:cs) | isDigit c = stoi (a*10 + digitToInt c) cs
270 stoi a cs = (a, cs)
271
272 getSpecs :: Bool -> Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, Bool, String, [UPrintf])
273 getSpecs _ z s ('-':cs) us = getSpecs True z s cs us
274 getSpecs l z _ ('+':cs) us = getSpecs l z True cs us
275 getSpecs l _ s ('0':cs) us = getSpecs l True s cs us
276 getSpecs l z s ('*':cs) us =
277 let (us', n) = getStar us
278 ((p, cs''), us'') =
279 case cs of
280 '.':'*':r -> let (us''', p') = getStar us'
281 in ((p', r), us''')
282 '.':r -> (stoi 0 r, us')
283 _ -> ((-1, cs), us')
284 in (n, p, l, z, s, cs'', us'')
285 getSpecs l z s ('.':cs) us =
286 let ((p, cs'), us') =
287 case cs of
288 '*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')
289 _ -> (stoi 0 cs, us)
290 in (0, p, l, z, s, cs', us')
291 getSpecs l z s cs@(c:_) us | isDigit c =
292 let (n, cs') = stoi 0 cs
293 ((p, cs''), us') = case cs' of
294 '.':'*':r -> let (us'', p') = getStar us in ((p', r), us'')
295 '.':r -> (stoi 0 r, us)
296 _ -> ((-1, cs'), us)
297 in (n, p, l, z, s, cs'', us')
298 getSpecs l z s cs us = (0, -1, l, z, s, cs, us)
299
300 getStar :: [UPrintf] -> ([UPrintf], Int)
301 getStar us =
302 case us of
303 [] -> argerr
304 nu : us' -> (us', toint nu)
305
306
307 dfmt' :: Char -> Int -> UPrintf -> (String, String)
308 dfmt' c p (UDouble d) = dfmt c p d
309 dfmt' c p (UFloat f) = dfmt c p f
310 dfmt' _ _ _ = baderr
311
312 dfmt :: (RealFloat a) => Char -> Int -> a -> (String, String)
313 dfmt c p d =
314 case (if isUpper c then map toUpper else id) $
315 (case toLower c of
316 'e' -> showEFloat
317 'f' -> showFFloat
318 'g' -> showGFloat
319 _ -> error "Printf.dfmt: impossible"
320 )
321 (if p < 0 then Nothing else Just p) d "" of
322 '-':cs -> ("-", cs)
323 cs -> ("" , cs)
324
325 perror :: String -> a
326 perror s = error ("Printf.printf: "++s)
327 fmterr, argerr, baderr :: a
328 fmterr = perror "formatting string ended prematurely"
329 argerr = perror "argument list ended prematurely"
330 baderr = perror "bad argument"