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