84ecd89c9c0018e37592d530e606c6d88ad43c1f
[packages/base.git] / Text / Printf.hs
1 {-# LANGUAGE Safe #-}
2 {-# LANGUAGE CPP #-}
3 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 700
4 {-# LANGUAGE GADTs #-}
5 #endif
6
7 -----------------------------------------------------------------------------
8 -- |
9 -- Module : Text.Printf
10 -- Copyright : (c) Lennart Augustsson and Bart Massey 2013
11 -- License : BSD-style (see the file LICENSE in this distribution)
12 --
13 -- Maintainer : Bart Massey <bart@cs.pdx.edu>
14 -- Stability : provisional
15 -- Portability : portable
16 --
17 -- A C @printf(3)@-like formatter. This version has been
18 -- extended by Bart Massey as per the recommendations of
19 -- John Meacham and Simon Marlow
20 -- \<<http://comments.gmane.org/gmane.comp.lang.haskell.libraries/4726>\>
21 -- to support extensible formatting for new datatypes. It
22 -- has also been extended to support almost all C
23 -- @printf(3)@ syntax.
24 -----------------------------------------------------------------------------
25
26 module Text.Printf(
27 -- * Printing Functions
28 printf, hPrintf,
29 -- * Extending To New Types
30 --
31 -- | This 'printf' can be extended to format types
32 -- other than those provided for by default. This
33 -- is done by instancing 'PrintfArg' and providing
34 -- a 'formatArg' for the type. It is possible to
35 -- provide a 'parseFormat' to process type-specific
36 -- modifiers, but the default instance is usually
37 -- the best choice.
38 --
39 -- For example:
40 --
41 -- > instance PrintfArg () where
42 -- > formatArg x fmt | fmtChar (vFmt 'U' fmt) == 'U' =
43 -- > formatString "()" (fmt { fmtChar = 's', fmtPrecision = Nothing })
44 -- > formatArg _ fmt = errorBadFormat $ fmtChar fmt
45 -- >
46 -- > main :: IO ()
47 -- > main = printf "[%-3.1U]\n" ()
48 --
49 -- prints \"@[() ]@\". Note the use of 'formatString' to
50 -- take care of field formatting specifications in a convenient
51 -- way.
52 PrintfArg(..),
53 FieldFormatter,
54 FieldFormat(..),
55 FormatAdjustment(..), FormatSign(..),
56 vFmt,
57 -- ** Handling Type-specific Modifiers
58 --
59 -- | In the unlikely case that modifier characters of
60 -- some kind are desirable for a user-provided type,
61 -- a 'ModifierParser' can be provided to process these
62 -- characters. The resulting modifiers will appear in
63 -- the 'FieldFormat' for use by the type-specific formatter.
64 ModifierParser, FormatParse(..),
65 -- ** Standard Formatters
66 --
67 -- | These formatters for standard types are provided for
68 -- convenience in writting new type-specific formatters:
69 -- a common pattern is to throw to 'formatString' or
70 -- 'formatInteger' to do most of the format handling for
71 -- a new type.
72 formatString, formatChar, formatInt,
73 formatInteger, formatRealFloat,
74 -- ** Raising Errors
75 --
76 -- | These functions are used internally to raise various
77 -- errors, and are exported for use by new type-specific
78 -- formatters.
79 errorBadFormat, errorShortFormat, errorMissingArgument,
80 errorBadArgument,
81 perror,
82 -- * Implementation Internals
83 -- | These types are needed for implementing processing
84 -- variable numbers of arguments to 'printf' and 'hPrintf'.
85 -- Their implementation is intentionally not visible from
86 -- this module. If you attempt to pass an argument of a type
87 -- which is not an instance of the appropriate class to
88 -- 'printf' or 'hPrintf', then the compiler will report it
89 -- as a missing instance of 'PrintfArg'. (All 'PrintfArg'
90 -- instances are 'PrintfType' instances.)
91 PrintfType, HPrintfType,
92 -- | This class is needed as a Haskell98 compatibility
93 -- workaround for the lack of FlexibleInstances.
94 IsChar(..)
95 ) where
96
97 import Prelude
98 import Data.Char
99 import Data.Int
100 import Data.List
101 import Data.Word
102 import Numeric
103 import System.IO
104
105 -------------------
106
107 -- | Format a variable number of arguments with the C-style formatting string.
108 -- The return value is either 'String' or @('IO' a)@ (which
109 -- should be @('IO' '()')@, but Haskell's type system
110 -- makes this hard).
111 --
112 -- The format string consists of ordinary characters and
113 -- /conversion specifications/, which specify how to format
114 -- one of the arguments to 'printf' in the output string. A
115 -- format specification is introduced by the @%@ character;
116 -- this character can be self-escaped into the format string
117 -- using @%%@. A format specification ends with a /format
118 -- character/ that provides the primary information about
119 -- how to format the value. The rest of the conversion
120 -- specification is optional. In order, one may have flag
121 -- characters, a width specifier, a precision specifier, and
122 -- type-specific modifier characters.
123 --
124 -- Unlike C @printf(3)@, the formatting of this 'printf'
125 -- is driven by the argument type; formatting is type specific. The
126 -- types formatted by 'printf' \"out of the box\" are:
127 --
128 -- * 'Integral' types, including 'Char'
129 --
130 -- * 'String'
131 --
132 -- * 'RealFloat' types
133 --
134 -- 'printf' is also extensible to support other types: see below.
135 --
136 -- A conversion specification begins with the
137 -- character @%@, followed by zero or more of the following flags:
138 --
139 -- > - left adjust (default is right adjust)
140 -- > + always use a sign (+ or -) for signed conversions
141 -- > space leading space for positive numbers in signed conversions
142 -- > 0 pad with zeros rather than spaces
143 -- > # use an \"alternate form\": see below
144 --
145 -- When both flags are given, @-@ overrides @0@ and @+@ overrides space.
146 -- A negative width specifier in a @*@ conversion is treated as
147 -- positive but implies the left adjust flag.
148 --
149 -- The \"alternate form\" for unsigned radix conversions is
150 -- as in C @printf(3)@:
151 --
152 -- > %o prefix with a leading 0 if needed
153 -- > %x prefix with a leading 0x if nonzero
154 -- > %X prefix with a leading 0X if nonzero
155 -- > %b prefix with a leading 0b if nonzero
156 -- > %[eEfFgG] ensure that the number contains a decimal point
157 --
158 -- Any flags are followed optionally by a field width:
159 --
160 -- > num field width
161 -- > * as num, but taken from argument list
162 --
163 -- The field width is a minimum, not a maximum: it will be
164 -- expanded as needed to avoid mutilating a value.
165 --
166 -- Any field width is followed optionally by a precision:
167 --
168 -- > .num precision
169 -- > . same as .0
170 -- > .* as num, but taken from argument list
171 --
172 -- Negative precision is taken as 0. The meaning of the
173 -- precision depends on the conversion type.
174 --
175 -- > Integral minimum number of digits to show
176 -- > RealFloat number of digits after the decimal point
177 -- > String maximum number of characters
178 --
179 -- The precision for Integral types is accomplished by zero-padding.
180 -- If both precision and zero-pad are given for an Integral field,
181 -- the zero-pad is ignored.
182 --
183 -- Any precision is followed optionally for Integral types
184 -- by a width modifier; the only use of this modifier being
185 -- to set the implicit size of the operand for conversion of
186 -- a negative operand to unsigned:
187 --
188 -- > hh Int8
189 -- > h Int16
190 -- > l Int32
191 -- > ll Int64
192 -- > L Int64
193 --
194 -- The specification ends with a format character:
195 --
196 -- > c character Integral
197 -- > d decimal Integral
198 -- > o octal Integral
199 -- > x hexadecimal Integral
200 -- > X hexadecimal Integral
201 -- > b binary Integral
202 -- > u unsigned decimal Integral
203 -- > f floating point RealFloat
204 -- > F floating point RealFloat
205 -- > g general format float RealFloat
206 -- > G general format float RealFloat
207 -- > e exponent format float RealFloat
208 -- > E exponent format float RealFloat
209 -- > s string String
210 -- > v default format any type
211 --
212 -- The \"%v\" specifier is provided for all built-in types,
213 -- and should be provided for user-defined type formatters
214 -- as well. It picks a \"best\" representation for the given
215 -- type. For the built-in types the \"%v\" specifier is
216 -- converted as follows:
217 --
218 -- > c Char
219 -- > u other unsigned Integral
220 -- > d other signed Integral
221 -- > g RealFloat
222 -- > s String
223 --
224 -- Mismatch between the argument types and the format
225 -- string, as well as any other syntactic or semantic errors
226 -- in the format string, will cause an exception to be
227 -- thrown at runtime.
228 --
229 -- Note that the formatting for 'RealFloat' types is
230 -- currently a bit different from that of C @printf(3)@,
231 -- conforming instead to 'Numeric.showEFloat',
232 -- 'Numeric.showFFloat' and 'Numeric.showGFloat' (and their
233 -- alternate versions 'Numeric.showFFloatAlt' and
234 -- 'Numeric.showGFloatAlt'). This is hard to fix: the fixed
235 -- versions would format in a backward-incompatible way.
236 -- In any case the Haskell behavior is generally more
237 -- sensible than the C behavior. A brief summary of some
238 -- key differences:
239 --
240 -- * Haskell 'printf' never uses the default \"6-digit\" precision
241 -- used by C printf.
242 --
243 -- * Haskell 'printf' treats the \"precision\" specifier as
244 -- indicating the number of digits after the decimal point.
245 --
246 -- * Haskell 'printf' prints the exponent of e-format
247 -- numbers without a gratuitous plus sign, and with the
248 -- minimum possible number of digits.
249 --
250 -- * Haskell 'printf' will place a zero after a decimal point when
251 -- possible.
252 --
253 -- Examples:
254 --
255 -- > > printf "%d\n" (23::Int)
256 -- > 23
257 -- > > printf "%s %s\n" "Hello" "World"
258 -- > Hello World
259 -- > > printf "%.2f\n" pi
260 -- > 3.14
261 --
262 printf :: (PrintfType r) => String -> r
263 printf fmts = spr fmts []
264
265 -- | Similar to 'printf', except that output is via the specified
266 -- 'Handle'. The return type is restricted to @('IO' a)@.
267 hPrintf :: (HPrintfType r) => Handle -> String -> r
268 hPrintf hdl fmts = hspr hdl fmts []
269
270 -- |The 'PrintfType' class provides the variable argument magic for
271 -- 'printf'. Its implementation is intentionally not visible from
272 -- this module. If you attempt to pass an argument of a type which
273 -- is not an instance of this class to 'printf' or 'hPrintf', then
274 -- the compiler will report it as a missing instance of 'PrintfArg'.
275 class PrintfType t where
276 spr :: String -> [UPrintf] -> t
277
278 -- | The 'HPrintfType' class provides the variable argument magic for
279 -- 'hPrintf'. Its implementation is intentionally not visible from
280 -- this module.
281 class HPrintfType t where
282 hspr :: Handle -> String -> [UPrintf] -> t
283
284 {- not allowed in Haskell 2010
285 instance PrintfType String where
286 spr fmt args = uprintf fmt (reverse args)
287 -}
288 instance (IsChar c) => PrintfType [c] where
289 spr fmts args = map fromChar (uprintf fmts (reverse args))
290
291 -- Note that this should really be (IO ()), but GHC's
292 -- type system won't readily let us say that without
293 -- bringing the GADTs. So we go conditional for these defs.
294
295 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 700
296
297 instance (a ~ ()) => PrintfType (IO a) where
298 spr fmts args =
299 putStr $ map fromChar $ uprintf fmts $ reverse args
300
301 instance (a ~ ()) => HPrintfType (IO a) where
302 hspr hdl fmts args = do
303 hPutStr hdl (uprintf fmts (reverse args))
304
305 #else
306
307 instance PrintfType (IO a) where
308 spr fmts args = do
309 putStr $ map fromChar $ uprintf fmts $ reverse args
310 return (error "PrintfType (IO a): result should not be used.")
311
312 instance HPrintfType (IO a) where
313 hspr hdl fmts args = do
314 hPutStr hdl (uprintf fmts (reverse args))
315 return (error "HPrintfType (IO a): result should not be used.")
316
317 #endif
318
319
320 instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
321 spr fmts args = \ a -> spr fmts
322 ((parseFormat a, formatArg a) : args)
323
324 instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
325 hspr hdl fmts args = \ a -> hspr hdl fmts
326 ((parseFormat a, formatArg a) : args)
327
328 -- | Typeclass of 'printf'-formattable values. The 'formatArg' method
329 -- takes a value and a field format descriptor and either fails due
330 -- to a bad descriptor or produces a 'ShowS' as the result. The
331 -- default 'parseFormat' expects no modifiers: this is the normal
332 -- case. Minimal instance: 'formatArg'.
333 class PrintfArg a where
334 formatArg :: a -> FieldFormatter
335 parseFormat :: a -> ModifierParser
336 parseFormat _ (c : cs) = FormatParse "" c cs
337 parseFormat _ "" = errorShortFormat
338
339 instance PrintfArg Char where
340 formatArg = formatChar
341 parseFormat _ cf = parseIntFormat (undefined :: Int) cf
342
343 instance (IsChar c) => PrintfArg [c] where
344 formatArg = formatString
345
346 instance PrintfArg Int where
347 formatArg = formatInt
348 parseFormat = parseIntFormat
349
350 instance PrintfArg Int8 where
351 formatArg = formatInt
352 parseFormat = parseIntFormat
353
354 instance PrintfArg Int16 where
355 formatArg = formatInt
356 parseFormat = parseIntFormat
357
358 instance PrintfArg Int32 where
359 formatArg = formatInt
360 parseFormat = parseIntFormat
361
362 instance PrintfArg Int64 where
363 formatArg = formatInt
364 parseFormat = parseIntFormat
365
366 instance PrintfArg Word where
367 formatArg = formatInt
368 parseFormat = parseIntFormat
369
370 instance PrintfArg Word8 where
371 formatArg = formatInt
372 parseFormat = parseIntFormat
373
374 instance PrintfArg Word16 where
375 formatArg = formatInt
376 parseFormat = parseIntFormat
377
378 instance PrintfArg Word32 where
379 formatArg = formatInt
380 parseFormat = parseIntFormat
381
382 instance PrintfArg Word64 where
383 formatArg = formatInt
384 parseFormat = parseIntFormat
385
386 instance PrintfArg Integer where
387 formatArg = formatInteger
388 parseFormat = parseIntFormat
389
390 instance PrintfArg Float where
391 formatArg = formatRealFloat
392
393 instance PrintfArg Double where
394 formatArg = formatRealFloat
395
396 -- | This class, with only the one instance, is used as
397 -- a workaround for the fact that 'String', as a concrete
398 -- type, is not allowable as a typeclass instance. 'IsChar'
399 -- is exported for backward-compatibility.
400 class IsChar c where
401 toChar :: c -> Char
402 fromChar :: Char -> c
403
404 instance IsChar Char where
405 toChar c = c
406 fromChar c = c
407
408 -------------------
409
410 -- | Whether to left-adjust or zero-pad a field. These are
411 -- mutually exclusive, with 'LeftAdjust' taking precedence.
412 data FormatAdjustment = LeftAdjust | ZeroPad
413
414 -- | How to handle the sign of a numeric field. These are
415 -- mutually exclusive, with 'SignPlus' taking precedence.
416 data FormatSign = SignPlus | SignSpace
417
418 -- | Description of field formatting for 'formatArg'. See UNIX `printf`(3)
419 -- for a description of how field formatting works.
420 data FieldFormat = FieldFormat {
421 fmtWidth :: Maybe Int, -- ^ Total width of the field.
422 fmtPrecision :: Maybe Int, -- ^ Secondary field width specifier.
423 fmtAdjust :: Maybe FormatAdjustment, -- ^ Kind of filling or padding
424 -- to be done.
425 fmtSign :: Maybe FormatSign, -- ^ Whether to insist on a
426 -- plus sign for positive
427 -- numbers.
428 fmtAlternate :: Bool, -- ^ Indicates an "alternate
429 -- format". See printf(3)
430 -- for the details, which
431 -- vary by argument spec.
432 fmtModifiers :: String, -- ^ Characters that appeared
433 -- immediately to the left of
434 -- 'fmtChar' in the format
435 -- and were accepted by the
436 -- type's 'parseFormat'.
437 -- Normally the empty string.
438 fmtChar :: Char -- ^ The format character
439 -- 'printf' was invoked
440 -- with. 'formatArg' should
441 -- fail unless this character
442 -- matches the type. It is
443 -- normal to handle many
444 -- different format
445 -- characters for a single
446 -- type.
447 }
448
449 -- | The \"format parser\" walks over argument-type-specific
450 -- modifier characters to find the primary format character.
451 -- This is the type of its result.
452 data FormatParse = FormatParse {
453 fpModifiers :: String, -- ^ Any modifiers found.
454 fpChar :: Char, -- ^ Primary format character.
455 fpRest :: String -- ^ Rest of the format string.
456 }
457
458 -- Contains the "modifier letters" that can precede an
459 -- integer type.
460 intModifierMap :: [(String, Integer)]
461 intModifierMap = [
462 ("hh", toInteger (minBound :: Int8)),
463 ("h", toInteger (minBound :: Int16)),
464 ("l", toInteger (minBound :: Int32)),
465 ("ll", toInteger (minBound :: Int64)),
466 ("L", toInteger (minBound :: Int64)) ]
467
468 parseIntFormat :: Integral a => a -> String -> FormatParse
469 parseIntFormat _ s =
470 case foldr matchPrefix Nothing intModifierMap of
471 Just m -> m
472 Nothing ->
473 case s of
474 c : cs -> FormatParse "" c cs
475 "" -> errorShortFormat
476 where
477 matchPrefix (p, _) m@(Just (FormatParse p0 _ _))
478 | length p0 >= length p = m
479 | otherwise = case getFormat p of
480 Nothing -> m
481 Just fp -> Just fp
482 matchPrefix (p, _) Nothing =
483 getFormat p
484 getFormat p =
485 stripPrefix p s >>= fp
486 where
487 fp (c : cs) = Just $ FormatParse p c cs
488 fp "" = errorShortFormat
489
490 -- | This is the type of a field formatter reified over its
491 -- argument.
492 type FieldFormatter = FieldFormat -> ShowS
493
494 -- | Type of a function that will parse modifier characters
495 -- from the format string.
496 type ModifierParser = String -> FormatParse
497
498 -- | Substitute a \'v\' format character with the given
499 -- default format character in the 'FieldFormat'. A
500 -- convenience for user-implemented types, which should
501 -- support \"%v\".
502 vFmt :: Char -> FieldFormat -> FieldFormat
503 vFmt c ufmt@(FieldFormat {fmtChar = 'v'}) = ufmt {fmtChar = c}
504 vFmt _ ufmt = ufmt
505
506 -- | Formatter for 'Char' values.
507 formatChar :: Char -> FieldFormatter
508 formatChar x ufmt =
509 formatIntegral (Just 0) (toInteger $ ord x) $ vFmt 'c' ufmt
510
511 -- | Formatter for 'String' values.
512 formatString :: IsChar a => [a] -> FieldFormatter
513 formatString x ufmt =
514 case fmtChar $ vFmt 's' ufmt of
515 's' -> map toChar . (adjust ufmt ("", ts) ++)
516 where
517 ts = map toChar $ trunc $ fmtPrecision ufmt
518 where
519 trunc Nothing = x
520 trunc (Just n) = take n x
521 c -> errorBadFormat c
522
523 -- Possibly apply the int modifiers to get a new
524 -- int width for conversion.
525 fixupMods :: FieldFormat -> Maybe Integer -> Maybe Integer
526 fixupMods ufmt m =
527 let mods = fmtModifiers ufmt in
528 case mods of
529 "" -> m
530 _ -> case lookup mods intModifierMap of
531 Just m0 -> Just m0
532 Nothing -> perror "unknown format modifier"
533
534 -- | Formatter for 'Int' values.
535 formatInt :: (Integral a, Bounded a) => a -> FieldFormatter
536 formatInt x ufmt =
537 let lb = toInteger $ minBound `asTypeOf` x
538 m = fixupMods ufmt (Just lb)
539 ufmt' = case lb of
540 0 -> vFmt 'u' ufmt
541 _ -> ufmt
542 in
543 formatIntegral m (toInteger x) ufmt'
544
545 -- | Formatter for 'Integer' values.
546 formatInteger :: Integer -> FieldFormatter
547 formatInteger x ufmt =
548 let m = fixupMods ufmt Nothing in
549 formatIntegral m x ufmt
550
551 -- All formatting for integral types is handled
552 -- consistently. The only difference is between Integer and
553 -- bounded types; this difference is handled by the 'm'
554 -- argument containing the lower bound.
555 formatIntegral :: Maybe Integer -> Integer -> FieldFormatter
556 formatIntegral m x ufmt0 =
557 let prec = fmtPrecision ufmt0 in
558 case fmtChar ufmt of
559 'd' -> (adjustSigned ufmt (fmti prec x) ++)
560 'i' -> (adjustSigned ufmt (fmti prec x) ++)
561 'x' -> (adjust ufmt (fmtu 16 (alt "0x" x) prec m x) ++)
562 'X' -> (adjust ufmt (upcase $ fmtu 16 (alt "0X" x) prec m x) ++)
563 'b' -> (adjust ufmt (fmtu 2 (alt "0b" x) prec m x) ++)
564 'o' -> (adjust ufmt (fmtu 8 (alt "0" x) prec m x) ++)
565 'u' -> (adjust ufmt (fmtu 10 Nothing prec m x) ++)
566 'c' | x >= fromIntegral (ord (minBound :: Char)) &&
567 x <= fromIntegral (ord (maxBound :: Char)) &&
568 fmtPrecision ufmt == Nothing &&
569 fmtModifiers ufmt == "" ->
570 formatString [chr $ fromIntegral x] (ufmt { fmtChar = 's' })
571 'c' -> perror "illegal char conversion"
572 c -> errorBadFormat c
573 where
574 ufmt = vFmt 'd' $ case ufmt0 of
575 FieldFormat { fmtPrecision = Just _, fmtAdjust = Just ZeroPad } ->
576 ufmt0 { fmtAdjust = Nothing }
577 _ -> ufmt0
578 alt _ 0 = Nothing
579 alt p _ = case fmtAlternate ufmt of
580 True -> Just p
581 False -> Nothing
582 upcase (s1, s2) = (s1, map toUpper s2)
583
584 -- | Formatter for 'RealFloat' values.
585 formatRealFloat :: RealFloat a => a -> FieldFormatter
586 formatRealFloat x ufmt =
587 let c = fmtChar $ vFmt 'g' ufmt
588 prec = fmtPrecision ufmt
589 alt = fmtAlternate ufmt
590 in
591 case c of
592 'e' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
593 'E' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
594 'f' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
595 'F' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
596 'g' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
597 'G' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
598 _ -> errorBadFormat c
599
600 -- This is the type carried around for arguments in
601 -- the varargs code.
602 type UPrintf = (ModifierParser, FieldFormatter)
603
604 -- Given a format string and a list of formatting functions
605 -- (the actual argument value having already been baked into
606 -- each of these functions before delivery), return the
607 -- actual formatted text string.
608 uprintf :: String -> [UPrintf] -> String
609 uprintf s us = uprintfs s us ""
610
611 -- This function does the actual work, producing a ShowS
612 -- instead of a string, for future expansion and for
613 -- misguided efficiency.
614 uprintfs :: String -> [UPrintf] -> ShowS
615 uprintfs "" [] = id
616 uprintfs "" (_:_) = errorShortFormat
617 uprintfs ('%':'%':cs) us = ('%' :) . uprintfs cs us
618 uprintfs ('%':_) [] = errorMissingArgument
619 uprintfs ('%':cs) us@(_:_) = fmt cs us
620 uprintfs (c:cs) us = (c :) . uprintfs cs us
621
622 -- Given a suffix of the format string starting just after
623 -- the percent sign, and the list of remaining unprocessed
624 -- arguments in the form described above, format the portion
625 -- of the output described by this field description, and
626 -- then continue with 'uprintfs'.
627 fmt :: String -> [UPrintf] -> ShowS
628 fmt cs0 us0 =
629 case getSpecs False False Nothing False cs0 us0 of
630 (_, _, []) -> errorMissingArgument
631 (ufmt, cs, (_, u) : us) -> u ufmt . uprintfs cs us
632
633 -- Given field formatting information, and a tuple
634 -- consisting of a prefix (for example, a minus sign) that
635 -- is supposed to go before the argument value and a string
636 -- representing the value, return the properly padded and
637 -- formatted result.
638 adjust :: FieldFormat -> (String, String) -> String
639 adjust ufmt (pre, str) =
640 let naturalWidth = length pre + length str
641 zero = case fmtAdjust ufmt of
642 Just ZeroPad -> True
643 _ -> False
644 left = case fmtAdjust ufmt of
645 Just LeftAdjust -> True
646 _ -> False
647 fill = case fmtWidth ufmt of
648 Just width | naturalWidth < width ->
649 let fillchar = if zero then '0' else ' ' in
650 replicate (width - naturalWidth) fillchar
651 _ -> ""
652 in
653 if left
654 then pre ++ str ++ fill
655 else if zero
656 then pre ++ fill ++ str
657 else fill ++ pre ++ str
658
659 -- For positive numbers with an explicit sign field ("+" or
660 -- " "), adjust accordingly.
661 adjustSigned :: FieldFormat -> (String, String) -> String
662 adjustSigned ufmt@(FieldFormat {fmtSign = Just SignPlus}) ("", str) =
663 adjust ufmt ("+", str)
664 adjustSigned ufmt@(FieldFormat {fmtSign = Just SignSpace}) ("", str) =
665 adjust ufmt (" ", str)
666 adjustSigned ufmt ps =
667 adjust ufmt ps
668
669 -- Format a signed integer in the "default" fashion.
670 -- This will be subjected to adjust subsequently.
671 fmti :: Maybe Int -> Integer -> (String, String)
672 fmti prec i
673 | i < 0 = ("-", integral_prec prec (show (-i)))
674 | otherwise = ("", integral_prec prec (show i))
675
676 -- Format an unsigned integer in the "default" fashion.
677 -- This will be subjected to adjust subsequently. The 'b'
678 -- argument is the base, the 'pre' argument is the prefix,
679 -- and the '(Just m)' argument is the implicit lower-bound
680 -- size of the operand for conversion from signed to
681 -- unsigned. Thus, this function will refuse to convert an
682 -- unbounded negative integer to an unsigned string.
683 fmtu :: Integer -> Maybe String -> Maybe Int -> Maybe Integer -> Integer
684 -> (String, String)
685 fmtu b (Just pre) prec m i =
686 let ("", s) = fmtu b Nothing prec m i in
687 case pre of
688 "0" -> case s of
689 '0' : _ -> ("", s)
690 _ -> (pre, s)
691 _ -> (pre, s)
692 fmtu b Nothing prec0 m0 i0 =
693 case fmtu' prec0 m0 i0 of
694 Just s -> ("", s)
695 Nothing -> errorBadArgument
696 where
697 fmtu' :: Maybe Int -> Maybe Integer -> Integer -> Maybe String
698 fmtu' prec (Just m) i | i < 0 =
699 fmtu' prec Nothing (-2 * m + i)
700 fmtu' (Just prec) _ i | i >= 0 =
701 fmap (integral_prec (Just prec)) $ fmtu' Nothing Nothing i
702 fmtu' Nothing _ i | i >= 0 =
703 Just $ showIntAtBase b intToDigit i ""
704 fmtu' _ _ _ = Nothing
705
706
707 -- This is used by 'fmtu' and 'fmti' to zero-pad an
708 -- int-string to a required precision.
709 integral_prec :: Maybe Int -> String -> String
710 integral_prec Nothing integral = integral
711 integral_prec (Just 0) "0" = ""
712 integral_prec (Just prec) integral =
713 replicate (prec - length integral) '0' ++ integral
714
715 stoi :: String -> (Int, String)
716 stoi cs =
717 let (as, cs') = span isDigit cs in
718 case as of
719 "" -> (0, cs')
720 _ -> (read as, cs')
721
722 -- Figure out the FormatAdjustment, given:
723 -- width, precision, left-adjust, zero-fill
724 adjustment :: Maybe Int -> Maybe a -> Bool -> Bool
725 -> Maybe FormatAdjustment
726 adjustment w p l z =
727 case w of
728 Just n | n < 0 -> adjl p True z
729 _ -> adjl p l z
730 where
731 adjl _ True _ = Just LeftAdjust
732 adjl _ False True = Just ZeroPad
733 adjl _ _ _ = Nothing
734
735 -- Parse the various format controls to get a format specification.
736 getSpecs :: Bool -> Bool -> Maybe FormatSign -> Bool -> String -> [UPrintf]
737 -> (FieldFormat, String, [UPrintf])
738 getSpecs _ z s a ('-' : cs0) us = getSpecs True z s a cs0 us
739 getSpecs l z _ a ('+' : cs0) us = getSpecs l z (Just SignPlus) a cs0 us
740 getSpecs l z s a (' ' : cs0) us =
741 getSpecs l z ss a cs0 us
742 where
743 ss = case s of
744 Just SignPlus -> Just SignPlus
745 _ -> Just SignSpace
746 getSpecs l _ s a ('0' : cs0) us = getSpecs l True s a cs0 us
747 getSpecs l z s _ ('#' : cs0) us = getSpecs l z s True cs0 us
748 getSpecs l z s a ('*' : cs0) us =
749 let (us', n) = getStar us
750 ((p, cs''), us'') = case cs0 of
751 '.':'*':r ->
752 let (us''', p') = getStar us' in ((Just p', r), us''')
753 '.':r ->
754 let (p', r') = stoi r in ((Just p', r'), us')
755 _ ->
756 ((Nothing, cs0), us')
757 FormatParse ms c cs =
758 case us'' of
759 (ufmt, _) : _ -> ufmt cs''
760 [] -> errorMissingArgument
761 in
762 (FieldFormat {
763 fmtWidth = Just (abs n),
764 fmtPrecision = p,
765 fmtAdjust = adjustment (Just n) p l z,
766 fmtSign = s,
767 fmtAlternate = a,
768 fmtModifiers = ms,
769 fmtChar = c}, cs, us'')
770 getSpecs l z s a ('.' : cs0) us =
771 let ((p, cs'), us') = case cs0 of
772 '*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')
773 _ -> (stoi cs0, us)
774 FormatParse ms c cs =
775 case us' of
776 (ufmt, _) : _ -> ufmt cs'
777 [] -> errorMissingArgument
778 in
779 (FieldFormat {
780 fmtWidth = Nothing,
781 fmtPrecision = Just p,
782 fmtAdjust = adjustment Nothing (Just p) l z,
783 fmtSign = s,
784 fmtAlternate = a,
785 fmtModifiers = ms,
786 fmtChar = c}, cs, us')
787 getSpecs l z s a cs0@(c0 : _) us | isDigit c0 =
788 let (n, cs') = stoi cs0
789 ((p, cs''), us') = case cs' of
790 '.' : '*' : r ->
791 let (us'', p') = getStar us in ((Just p', r), us'')
792 '.' : r ->
793 let (p', r') = stoi r in ((Just p', r'), us)
794 _ ->
795 ((Nothing, cs'), us)
796 FormatParse ms c cs =
797 case us' of
798 (ufmt, _) : _ -> ufmt cs''
799 [] -> errorMissingArgument
800 in
801 (FieldFormat {
802 fmtWidth = Just (abs n),
803 fmtPrecision = p,
804 fmtAdjust = adjustment (Just n) p l z,
805 fmtSign = s,
806 fmtAlternate = a,
807 fmtModifiers = ms,
808 fmtChar = c}, cs, us')
809 getSpecs l z s a cs0@(_ : _) us =
810 let FormatParse ms c cs =
811 case us of
812 (ufmt, _) : _ -> ufmt cs0
813 [] -> errorMissingArgument
814 in
815 (FieldFormat {
816 fmtWidth = Nothing,
817 fmtPrecision = Nothing,
818 fmtAdjust = adjustment Nothing Nothing l z,
819 fmtSign = s,
820 fmtAlternate = a,
821 fmtModifiers = ms,
822 fmtChar = c}, cs, us)
823 getSpecs _ _ _ _ "" _ =
824 errorShortFormat
825
826 -- Process a star argument in a format specification.
827 getStar :: [UPrintf] -> ([UPrintf], Int)
828 getStar us =
829 let ufmt = FieldFormat {
830 fmtWidth = Nothing,
831 fmtPrecision = Nothing,
832 fmtAdjust = Nothing,
833 fmtSign = Nothing,
834 fmtAlternate = False,
835 fmtModifiers = "",
836 fmtChar = 'd' } in
837 case us of
838 [] -> errorMissingArgument
839 (_, nu) : us' -> (us', read (nu ufmt ""))
840
841 -- Format a RealFloat value.
842 dfmt :: (RealFloat a) => Char -> Maybe Int -> Bool -> a -> (String, String)
843 dfmt c p a d =
844 let caseConvert = if isUpper c then map toUpper else id
845 showFunction = case toLower c of
846 'e' -> showEFloat
847 'f' -> if a then showFFloatAlt else showFFloat
848 'g' -> if a then showGFloatAlt else showGFloat
849 _ -> perror "internal error: impossible dfmt"
850 result = caseConvert $ showFunction p d ""
851 in
852 case result of
853 '-' : cs -> ("-", cs)
854 cs -> ("" , cs)
855
856
857 -- | Raises an 'error' with a printf-specific prefix on the
858 -- message string.
859 perror :: String -> a
860 perror s = error $ "printf: " ++ s
861
862 -- | Calls 'perror' to indicate an unknown format letter for
863 -- a given type.
864 errorBadFormat :: Char -> a
865 errorBadFormat c = perror $ "bad formatting char " ++ show c
866
867 errorShortFormat, errorMissingArgument, errorBadArgument :: a
868 -- | Calls 'perror' to indicate that the format string ended
869 -- early.
870 errorShortFormat = perror "formatting string ended prematurely"
871 -- | Calls 'perror' to indicate that there is a missing
872 -- argument in the argument list.
873 errorMissingArgument = perror "argument list ended prematurely"
874 -- | Calls 'perror' to indicate that there is a type
875 -- error or similar in the given argument.
876 errorBadArgument = perror "bad argument"