Printf.hs 10.2 KB
Newer Older
1
{-# LANGUAGE Safe #-}
2
3
{-# LANGUAGE CPP #-}

4
5
6
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Printf
Simon Marlow's avatar
Simon Marlow committed
7
-- Copyright   :  (c) Lennart Augustsson, 2004-2008
8
9
10
11
12
13
14
15
16
17
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  lennart@augustsson.net
-- Stability   :  provisional
-- Portability :  portable
--
-- A C printf like formatter.
--
-----------------------------------------------------------------------------

18
19
{-# Language CPP #-}

20
21
22
23
module Text.Printf(
   printf, hPrintf,
   PrintfType, HPrintfType, PrintfArg, IsChar
) where
24
25

import Prelude
26
import Data.Char
27
28
import Data.Int
import Data.Word
29
30
31
32
33
34
import Numeric(showEFloat, showFFloat, showGFloat)
import System.IO

-------------------

-- | Format a variable number of arguments with the C-style formatting string.
35
-- The return value is either 'String' or @('IO' a)@.
36
37
38
39
40
41
42
--
-- The format string consists of ordinary characters and /conversion
-- specifications/, which specify how to format one of the arguments
-- to printf in the output string.  A conversion specification begins with the
-- character @%@, followed by one or more of the following flags:
--
-- >    -      left adjust (default is right adjust)
43
-- >    +      always use a sign (+ or -) for signed conversions
44
45
46
47
48
49
50
51
52
53
54
55
56
-- >    0      pad with zeroes rather than spaces
--
-- followed optionally by a field width:
-- 
-- >    num    field width
-- >    *      as num, but taken from argument list
--
-- followed optionally by a precision:
--
-- >    .num   precision (number of decimal places)
--
-- and finally, a format character:
--
57
58
59
60
61
62
-- >    c      character               Char, Int, Integer, ...
-- >    d      decimal                 Char, Int, Integer, ...
-- >    o      octal                   Char, Int, Integer, ...
-- >    x      hexadecimal             Char, Int, Integer, ...
-- >    X      hexadecimal             Char, Int, Integer, ...
-- >    u      unsigned decimal        Char, Int, Integer, ...
63
64
-- >    f      floating point          Float, Double
-- >    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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
-- >    s      string                  String
--
-- Mismatch between the argument types and the format string will cause
-- an exception to be thrown at runtime.
--
-- Examples:
--
-- >   > printf "%d\n" (23::Int)
-- >   23
-- >   > printf "%s %s\n" "Hello" "World"
-- >   Hello World
-- >   > printf "%.2f\n" pi
-- >   3.14
--
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
91
92
93
94
-- |The 'PrintfType' class provides the variable argument magic for
-- 'printf'.  Its implementation is intentionally not visible from
-- this module. If you attempt to pass an argument of a type which
-- is not an instance of this class to 'printf' or 'hPrintf', then
-- the compiler will report it as a missing instance of 'PrintfArg'.
95
96
97
class PrintfType t where
    spr :: String -> [UPrintf] -> t

98
-- | The 'HPrintfType' class provides the variable argument magic for
99
100
101
102
103
-- 'hPrintf'.  Its implementation is intentionally not visible from
-- this module.
class HPrintfType t where
    hspr :: Handle -> String -> [UPrintf] -> t

104
{- not allowed in Haskell 2010
105
106
107
108
instance PrintfType String where
    spr fmt args = uprintf fmt (reverse args)
-}
instance (IsChar c) => PrintfType [c] where
109
    spr fmts args = map fromChar (uprintf fmts (reverse args))
110
111

instance PrintfType (IO a) where
112
113
    spr fmts args = do
	putStr (uprintf fmts (reverse args))
114
	return (error "PrintfType (IO a): result should not be used.")
115
116

instance HPrintfType (IO a) where
117
118
    hspr hdl fmts args = do
	hPutStr hdl (uprintf fmts (reverse args))
119
	return (error "HPrintfType (IO a): result should not be used.")
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
128
129
130
131
132

class PrintfArg a where
    toUPrintf :: a -> UPrintf

instance PrintfArg Char where
    toUPrintf c = UChar c

133
{- not allowed in Haskell 2010
134
135
136
137
instance PrintfArg String where
    toUPrintf s = UString s
-}
instance (IsChar c) => PrintfArg [c] where
138
    toUPrintf = UString . map toChar
139
140

instance PrintfArg Int where
141
142
143
144
145
146
147
148
149
150
151
152
153
154
    toUPrintf = uInteger

instance PrintfArg Int8 where
    toUPrintf = uInteger

instance PrintfArg Int16 where
    toUPrintf = uInteger

instance PrintfArg Int32 where
    toUPrintf = uInteger

instance PrintfArg Int64 where
    toUPrintf = uInteger

155
#ifndef __NHC__
156
157
instance PrintfArg Word where
    toUPrintf = uInteger
158
#endif
159
160
161
162
163
164
165
166
167
168
169
170

instance PrintfArg Word8 where
    toUPrintf = uInteger

instance PrintfArg Word16 where
    toUPrintf = uInteger

instance PrintfArg Word32 where
    toUPrintf = uInteger

instance PrintfArg Word64 where
    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
180
181
182
    toUPrintf = UDouble

uInteger :: (Integral a, Bounded a) => a -> UPrintf
uInteger x = UInteger (toInteger $ minBound `asTypeOf` x) (toInteger x)
183
184
185
186
187
188
189
190
191
192
193

class IsChar c where
    toChar :: c -> Char
    fromChar :: Char -> c

instance IsChar Char where
    toChar c = c
    fromChar c = c

-------------------

194
data UPrintf = UChar Char | UString String | UInteger Integer Integer | UFloat Float | UDouble Double
195
196
197
198
199
200
201
202
203
204
205

uprintf :: String -> [UPrintf] -> String
uprintf ""       []       = ""
uprintf ""       (_:_)    = fmterr
uprintf ('%':'%':cs) us   = '%':uprintf cs us
uprintf ('%':_)  []       = argerr
uprintf ('%':cs) us@(_:_) = fmt cs us
uprintf (c:cs)   us       = c:uprintf cs us

fmt :: String -> [UPrintf] -> String
fmt cs us =
206
	let (width, prec, ladj, zero, plus, cs', us') = getSpecs False False False cs us
207
208
209
210
211
	    adjust (pre, str) = 
		let lstr = length str
		    lpre = length pre
		    fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
		in  if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
212
213
            adjust' ("", str) | plus = adjust ("+", str)
            adjust' ps = adjust ps
214
215
216
217
218
219
220
221
        in
	case cs' of
	[]     -> fmterr
	c:cs'' ->
	    case us' of
	    []     -> argerr
	    u:us'' ->
		(case c of
222
		'c' -> adjust  ("", [toEnum (toint u)])
223
224
225
226
227
228
		'd' -> adjust' (fmti prec u)
		'i' -> adjust' (fmti prec u)
		'x' -> adjust  ("", fmtu 16 prec u)
		'X' -> adjust  ("", map toUpper $ fmtu 16 prec u)
		'o' -> adjust  ("", fmtu 8  prec u)
		'u' -> adjust  ("", fmtu 10 prec u)
229
230
231
232
233
		'e' -> adjust' (dfmt' c prec u)
		'E' -> adjust' (dfmt' c prec u)
		'f' -> adjust' (dfmt' c prec u)
		'g' -> adjust' (dfmt' c prec u)
		'G' -> adjust' (dfmt' c prec u)
Simon Marlow's avatar
Simon Marlow committed
234
		's' -> adjust  ("", tostr prec u)
235
		_   -> perror ("bad formatting char " ++ [c])
236
237
		 ) ++ uprintf cs'' us''

238
239
240
241
242
243
244
245
246
fmti :: Int -> UPrintf -> (String, String)
fmti prec (UInteger _ i) = if i < 0 then ("-", integral_prec prec (show (-i))) else ("", integral_prec prec (show i))
fmti _ (UChar c)         = fmti 0 (uInteger (fromEnum c))
fmti _ _                 = baderr

fmtu :: Integer -> Int -> UPrintf -> String
fmtu b prec (UInteger l i) = integral_prec prec (itosb b (if i < 0 then -2*l + i else i))
fmtu b _    (UChar c)      = itosb b (toInteger (fromEnum c))
fmtu _ _ _                 = baderr
247

248
249
integral_prec :: Int -> String -> String
integral_prec prec integral = (replicate (prec - (length integral)) '0') ++ integral
250

251
252
253
254
255
toint :: UPrintf -> Int
toint (UInteger _ i) = fromInteger i
toint (UChar c)      = fromEnum c
toint _		     = baderr

Simon Marlow's avatar
Simon Marlow committed
256
257
258
tostr :: Int -> UPrintf -> String
tostr n (UString s) = if n >= 0 then take n s else s
tostr _ _		  = baderr
259
260
261
262

itosb :: Integer -> Integer -> String
itosb b n = 
	if n < b then 
263
	    [intToDigit $ fromInteger n]
264
265
	else
	    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
271
stoi a cs                 = (a, cs)

272
273
274
275
getSpecs :: Bool -> Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, Bool, String, [UPrintf])
getSpecs _ z s ('-':cs) us = getSpecs True z s cs us
getSpecs l z _ ('+':cs) us = getSpecs l z True cs us
getSpecs l _ s ('0':cs) us = getSpecs l True s cs us
Simon Marlow's avatar
Simon Marlow committed
276
277
278
getSpecs l z s ('*':cs) us =
	let (us', n) = getStar us
	    ((p, cs''), us'') =
279
		    case cs of
Simon Marlow's avatar
Simon Marlow committed
280
281
282
283
                    '.':'*':r -> let (us''', p') = getStar us'
		    	      	 in  ((p', r), us''')
		    '.':r     -> (stoi 0 r, us')
		    _         -> ((-1, cs), us')
284
	in  (abs n, p, if n < 0 then not l else l, z, s, cs'', us'')
285
getSpecs l z s ('.':cs) us =
Simon Marlow's avatar
Simon Marlow committed
286
287
288
289
290
	let ((p, cs'), us') = 
	        case cs of
		'*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')
                _ ->        (stoi 0 cs, us)
	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
Simon Marlow's avatar
Simon Marlow committed
293
294
295
296
297
	    ((p, cs''), us') = case cs' of
	    	 	       '.':'*':r -> let (us'', p') = getStar us in ((p', r), us'')
		               '.':r -> (stoi 0 r, us)
			       _     -> ((-1, cs'), us)
	in  (n, p, l, z, s, cs'', us')
298
getSpecs l z s cs       us = (0, -1, l, z, s, cs, us)
299

Simon Marlow's avatar
Simon Marlow committed
300
301
302
303
304
305
306
getStar :: [UPrintf] -> ([UPrintf], Int)
getStar us =
    case us of
    [] -> argerr
    nu : us' -> (us', toint nu)


307
dfmt' :: Char -> Int -> UPrintf -> (String, String)
308
309
dfmt' c p (UDouble d) = dfmt c p d
dfmt' c p (UFloat f)  = dfmt c p f
310
311
312
313
314
315
316
317
318
319
320
dfmt' _ _ _           = baderr

dfmt :: (RealFloat a) => Char -> Int -> a -> (String, String)
dfmt c p d =
	case (if isUpper c then map toUpper else id) $
             (case toLower c of
                  'e' -> showEFloat
                  'f' -> showFFloat
                  'g' -> showGFloat
                  _   -> error "Printf.dfmt: impossible"
             )
321
322
323
324
               (if p < 0 then Nothing else Just p) d "" of
	'-':cs -> ("-", cs)
	cs     -> ("" , cs)

325
perror :: String -> a
326
perror s = error ("Printf.printf: "++s)
327
fmterr, argerr, baderr :: a
328
329
330
fmterr = perror "formatting string ended prematurely"
argerr = perror "argument list ended prematurely"
baderr = perror "bad argument"
dterei's avatar
dterei committed
331