1 -----------------------------------------------------------------------------
3 -- Module : Text.Printf
4 -- Copyright : (c) Lennart Augustsson, 2004-2008
5 -- License : BSD-style (see the file libraries/base/LICENSE)
7 -- Maintainer : lennart@augustsson.net
8 -- Stability : provisional
9 -- Portability : portable
11 -- A C printf like formatter.
13 -----------------------------------------------------------------------------
17 PrintfType, HPrintfType, PrintfArg, IsChar
24 import Numeric(showEFloat, showFFloat, showGFloat)
29 -- | Format a variable number of arguments with the C-style formatting string.
30 -- The return value is either 'String' or @('IO' a)@.
32 -- The format string consists of ordinary characters and /conversion
33 -- specifications/, which specify how to format one of the arguments
34 -- to printf in the output string. A conversion specification begins with the
35 -- character @%@, followed by one or more of the following flags:
37 -- > - left adjust (default is right adjust)
38 -- > + always use a sign (+ or -) for signed conversions
39 -- > 0 pad with zeroes rather than spaces
41 -- followed optionally by a field width:
44 -- > * as num, but taken from argument list
46 -- followed optionally by a precision:
48 -- > .num precision (number of decimal places)
50 -- and finally, a format character:
52 -- > c character Char, Int, Integer, ...
53 -- > d decimal Char, Int, Integer, ...
54 -- > o octal Char, Int, Integer, ...
55 -- > x hexadecimal Char, Int, Integer, ...
56 -- > X hexadecimal Char, Int, Integer, ...
57 -- > u unsigned decimal Char, Int, Integer, ...
58 -- > f floating point Float, Double
59 -- > g general format float Float, Double
60 -- > G general format float Float, Double
61 -- > e exponent format float Float, Double
62 -- > E exponent format float Float, Double
65 -- Mismatch between the argument types and the format string will cause
66 -- an exception to be thrown at runtime.
70 -- > > printf "%d\n" (23::Int)
72 -- > > printf "%s %s\n" "Hello" "World"
74 -- > > printf "%.2f\n" pi
77 printf :: (PrintfType r) => String -> r
78 printf fmts = spr fmts []
80 -- | Similar to 'printf', except that output is via the specified
81 -- 'Handle'. The return type is restricted to @('IO' a)@.
82 hPrintf :: (HPrintfType r) => Handle -> String -> r
83 hPrintf hdl fmts = hspr hdl fmts []
85 -- |The 'PrintfType' class provides the variable argument magic for
86 -- 'printf'. Its implementation is intentionally not visible from
87 -- this module. If you attempt to pass an argument of a type which
88 -- is not an instance of this class to 'printf' or 'hPrintf', then
89 -- the compiler will report it as a missing instance of 'PrintfArg'.
90 class PrintfType t where
91 spr :: String -> [UPrintf] -> t
93 -- | The 'HPrintfType' class provides the variable argument magic for
94 -- 'hPrintf'. Its implementation is intentionally not visible from
96 class HPrintfType t where
97 hspr :: Handle -> String -> [UPrintf] -> t
99 {- not allowed in Haskell 98
100 instance PrintfType String where
101 spr fmt args = uprintf fmt (reverse args)
103 instance (IsChar c) => PrintfType [c] where
104 spr fmts args = map fromChar (uprintf fmts (reverse args))
106 instance PrintfType (IO a) where
108 putStr (uprintf fmts (reverse args))
111 instance HPrintfType (IO a) where
112 hspr hdl fmts args = do
113 hPutStr hdl (uprintf fmts (reverse args))
116 instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
117 spr fmts args = \ a -> spr fmts (toUPrintf a : args)
119 instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
120 hspr hdl fmts args = \ a -> hspr hdl fmts (toUPrintf a : args)
122 class PrintfArg a where
123 toUPrintf :: a -> UPrintf
125 instance PrintfArg Char where
126 toUPrintf c = UChar c
128 {- not allowed in Haskell 98
129 instance PrintfArg String where
130 toUPrintf s = UString s
132 instance (IsChar c) => PrintfArg [c] where
133 toUPrintf = UString . map toChar
135 instance PrintfArg Int where
138 instance PrintfArg Int8 where
141 instance PrintfArg Int16 where
144 instance PrintfArg Int32 where
147 instance PrintfArg Int64 where
150 instance PrintfArg Word where
153 instance PrintfArg Word8 where
156 instance PrintfArg Word16 where
159 instance PrintfArg Word32 where
162 instance PrintfArg Word64 where
165 instance PrintfArg Integer where
166 toUPrintf = UInteger 0
168 instance PrintfArg Float where
171 instance PrintfArg Double where
174 uInteger :: (Integral a, Bounded a) => a -> UPrintf
175 uInteger x = UInteger (toInteger $ minBound `asTypeOf` x) (toInteger x)
179 fromChar :: Char -> c
181 instance IsChar Char where
187 data UPrintf = UChar Char | UString String | UInteger Integer Integer | UFloat Float | UDouble Double
189 uprintf :: String -> [UPrintf] -> String
191 uprintf "" (_:_) = fmterr
192 uprintf ('%':'%':cs) us = '%':uprintf cs us
193 uprintf ('%':_) [] = argerr
194 uprintf ('%':cs) us@(_:_) = fmt cs us
195 uprintf (c:cs) us = c:uprintf cs us
197 fmt :: String -> [UPrintf] -> String
199 let (width, prec, ladj, zero, plus, cs', us') = getSpecs False False False cs us
201 let lstr = length str
203 fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
204 in if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
205 adjust' ("", str) | plus = adjust ("+", str)
206 adjust' ps = adjust ps
215 'c' -> adjust ("", [toEnum (toint u)])
216 'd' -> adjust' (fmti u)
217 'i' -> adjust' (fmti u)
218 'x' -> adjust ("", fmtu 16 u)
219 'X' -> adjust ("", map toUpper $ fmtu 16 u)
220 'o' -> adjust ("", fmtu 8 u)
221 'u' -> adjust ("", fmtu 10 u)
222 'e' -> adjust' (dfmt' c prec u)
223 'E' -> adjust' (dfmt' c prec u)
224 'f' -> adjust' (dfmt' c prec u)
225 'g' -> adjust' (dfmt' c prec u)
226 'G' -> adjust' (dfmt' c prec u)
227 's' -> adjust ("", tostr prec u)
228 _ -> perror ("bad formatting char " ++ [c])
229 ) ++ uprintf cs'' us''
231 fmti :: UPrintf -> (String, String)
232 fmti (UInteger _ i) = if i < 0 then ("-", show (-i)) else ("", show i)
233 fmti (UChar c) = fmti (uInteger (fromEnum c))
236 fmtu :: Integer -> UPrintf -> String
237 fmtu b (UInteger l i) = itosb b (if i < 0 then -2*l + i else i)
238 fmtu b (UChar c) = itosb b (toInteger (fromEnum c))
241 toint :: UPrintf -> Int
242 toint (UInteger _ i) = fromInteger i
243 toint (UChar c) = fromEnum c
246 tostr :: Int -> UPrintf -> String
247 tostr n (UString s) = if n >= 0 then take n s else s
250 itosb :: Integer -> Integer -> String
253 [intToDigit $ fromInteger n]
255 let (q, r) = quotRem n b in
256 itosb b q ++ [intToDigit $ fromInteger r]
258 stoi :: Int -> String -> (Int, String)
259 stoi a (c:cs) | isDigit c = stoi (a*10 + digitToInt c) cs
262 getSpecs :: Bool -> Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, Bool, String, [UPrintf])
263 getSpecs _ z s ('-':cs) us = getSpecs True z s cs us
264 getSpecs l z _ ('+':cs) us = getSpecs l z True cs us
265 getSpecs l _ s ('0':cs) us = getSpecs l True s cs us
266 getSpecs l z s ('*':cs) us =
267 let (us', n) = getStar us
270 '.':'*':r -> let (us''', p') = getStar us'
272 '.':r -> (stoi 0 r, us')
274 in (n, p, l, z, s, cs'', us'')
275 getSpecs l z s ('.':cs) us =
276 let ((p, cs'), us') =
278 '*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')
280 in (0, p, l, z, s, cs', us')
281 getSpecs l z s cs@(c:_) us | isDigit c =
282 let (n, cs') = stoi 0 cs
283 ((p, cs''), us') = case cs' of
284 '.':'*':r -> let (us'', p') = getStar us in ((p', r), us'')
285 '.':r -> (stoi 0 r, us)
287 in (n, p, l, z, s, cs'', us')
288 getSpecs l z s cs us = (0, -1, l, z, s, cs, us)
290 getStar :: [UPrintf] -> ([UPrintf], Int)
294 nu : us' -> (us', toint nu)
297 dfmt' :: Char -> Int -> UPrintf -> (String, String)
298 dfmt' c p (UDouble d) = dfmt c p d
299 dfmt' c p (UFloat f) = dfmt c p f
302 dfmt :: (RealFloat a) => Char -> Int -> a -> (String, String)
304 case (if isUpper c then map toUpper else id) $
309 _ -> error "Printf.dfmt: impossible"
311 (if p < 0 then Nothing else Just p) d "" of
315 perror :: String -> a
316 perror s = error ("Printf.printf: "++s)
317 fmterr, argerr, baderr :: a
318 fmterr = perror "formatting string ended prematurely"
319 argerr = perror "argument list ended prematurely"
320 baderr = perror "bad argument"