Replaced Text.Printf with extensible printf, and made comcommitant changes

Signed-off-by: Joachim Breitner <mail@joachim-breitner.de>

1 files changed, 741 insertions, 192 deletions

diff --git a/libraries/base/Text/Printf.hs b/libraries/base/Text/Printf.hs
index 1766f9ba23..84ecd89c9c 100644
--- a/libraries/base/Text/Printf.hs
+++ b/libraries/base/Text/Printf.hs
@@ -1,73 +1,254 @@
 {-# LANGUAGE Safe #-}
+{-# LANGUAGE CPP #-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >=  700
+{-# LANGUAGE GADTs #-}
+#endif
 
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Text.Printf
--- Copyright   :  (c) Lennart Augustsson, 2004-2008
--- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- Copyright   :  (c) Lennart Augustsson and Bart Massey 2013
+-- License     :  BSD-style (see the file LICENSE in this distribution)
 --
--- Maintainer  :  lennart@augustsson.net
+-- Maintainer  :  Bart Massey <bart@cs.pdx.edu>
 -- Stability   :  provisional
 -- Portability :  portable
 --
--- A C printf like formatter.
---
+-- A C @printf(3)@-like formatter. This version has been
+-- extended by Bart Massey as per the recommendations of
+-- John Meacham and Simon Marlow
+-- \<<http://comments.gmane.org/gmane.comp.lang.haskell.libraries/4726>\>
+-- to support extensible formatting for new datatypes.  It
+-- has also been extended to support almost all C
+-- @printf(3)@ syntax.
 -----------------------------------------------------------------------------
 
-{-# Language CPP #-}
-
 module Text.Printf(
+-- * Printing Functions
    printf, hPrintf,
-   PrintfType, HPrintfType, PrintfArg, IsChar
+-- * Extending To New Types
+--
+-- | This 'printf' can be extended to format types
+-- other than those provided for by default. This
+-- is done by instancing 'PrintfArg' and providing
+-- a 'formatArg' for the type. It is possible to
+-- provide a 'parseFormat' to process type-specific
+-- modifiers, but the default instance is usually
+-- the best choice.
+--
+-- For example:
+--
+-- > instance PrintfArg () where
+-- >   formatArg x fmt | fmtChar (vFmt 'U' fmt) == 'U' =
+-- >     formatString "()" (fmt { fmtChar = 's', fmtPrecision = Nothing })
+-- >   formatArg _ fmt = errorBadFormat $ fmtChar fmt
+-- >
+-- > main :: IO ()
+-- > main = printf "[%-3.1U]\n" ()
+--
+-- prints \"@[() ]@\". Note the use of 'formatString' to
+-- take care of field formatting specifications in a convenient
+-- way.
+   PrintfArg(..),
+   FieldFormatter,
+   FieldFormat(..),
+   FormatAdjustment(..), FormatSign(..),
+   vFmt,
+-- ** Handling Type-specific Modifiers
+--
+-- | In the unlikely case that modifier characters of
+-- some kind are desirable for a user-provided type,
+-- a 'ModifierParser' can be provided to process these
+-- characters. The resulting modifiers will appear in
+-- the 'FieldFormat' for use by the type-specific formatter.
+   ModifierParser, FormatParse(..),
+-- ** Standard Formatters
+--
+-- | These formatters for standard types are provided for
+-- convenience in writting new type-specific formatters:
+-- a common pattern is to throw to 'formatString' or
+-- 'formatInteger' to do most of the format handling for
+-- a new type.
+   formatString, formatChar, formatInt,
+   formatInteger, formatRealFloat,
+-- ** Raising Errors
+--
+-- | These functions are used internally to raise various
+-- errors, and are exported for use by new type-specific
+-- formatters.
+  errorBadFormat, errorShortFormat, errorMissingArgument,
+  errorBadArgument,
+  perror,
+-- * Implementation Internals
+-- | These types are needed for implementing processing
+-- variable numbers of arguments to 'printf' and 'hPrintf'.
+-- Their implementation is intentionally not visible from
+-- this module. If you attempt to pass an argument of a type
+-- which is not an instance of the appropriate class to
+-- 'printf' or 'hPrintf', then the compiler will report it
+-- as a missing instance of 'PrintfArg'.  (All 'PrintfArg'
+-- instances are 'PrintfType' instances.)
+  PrintfType, HPrintfType,
+-- | This class is needed as a Haskell98 compatibility
+-- workaround for the lack of FlexibleInstances.
+  IsChar(..)
 ) where
 
 import Prelude
 import Data.Char
 import Data.Int
+import Data.List
 import Data.Word
-import Numeric(showEFloat, showFFloat, showGFloat)
+import Numeric
 import System.IO
 
 -------------------
 
 -- | Format a variable number of arguments with the C-style formatting string.
--- The return value is either 'String' or @('IO' a)@.
+-- The return value is either 'String' or @('IO' a)@ (which
+-- should be @('IO' '()')@, but Haskell's type system
+-- makes this hard).
+--
+-- 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
+-- format specification is introduced by the @%@ character;
+-- this character can be self-escaped into the format string
+-- using @%%@. A format specification ends with a /format
+-- character/ that provides the primary information about
+-- how to format the value. The rest of the conversion
+-- specification is optional.  In order, one may have flag
+-- characters, a width specifier, a precision specifier, and
+-- type-specific modifier characters.
+--
+-- Unlike C @printf(3)@, the formatting of this 'printf'
+-- is driven by the argument type; formatting is type specific. The
+-- types formatted by 'printf' \"out of the box\" are:
+--
+--   * 'Integral' types, including 'Char'
 --
--- 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:
+--   * 'String'
+--
+--   * 'RealFloat' types
+--
+-- 'printf' is also extensible to support other types: see below.
+--
+-- A conversion specification begins with the
+-- character @%@, followed by zero or more of the following flags:
 --
 -- >    -      left adjust (default is right adjust)
 -- >    +      always use a sign (+ or -) for signed conversions
--- >    0      pad with zeroes rather than spaces
+-- >    space  leading space for positive numbers in signed conversions
+-- >    0      pad with zeros rather than spaces
+-- >    #      use an \"alternate form\": see below
+--
+-- When both flags are given, @-@ overrides @0@ and @+@ overrides space.
+-- A negative width specifier in a @*@ conversion is treated as
+-- positive but implies the left adjust flag.
+--
+-- The \"alternate form\" for unsigned radix conversions is
+-- as in C @printf(3)@:
+--
+-- >    %o           prefix with a leading 0 if needed
+-- >    %x           prefix with a leading 0x if nonzero
+-- >    %X           prefix with a leading 0X if nonzero
+-- >    %b           prefix with a leading 0b if nonzero
+-- >    %[eEfFgG]    ensure that the number contains a decimal point
 --
--- followed optionally by a field width:
+-- Any flags are followed optionally by a field width:
 --
 -- >    num    field width
 -- >    *      as num, but taken from argument list
 --
--- followed optionally by a precision:
+-- The field width is a minimum, not a maximum: it will be
+-- expanded as needed to avoid mutilating a value.
+--
+-- Any field width is followed optionally by a precision:
+--
+-- >    .num   precision
+-- >    .      same as .0
+-- >    .*     as num, but taken from argument list
+--
+-- Negative precision is taken as 0. The meaning of the
+-- precision depends on the conversion type.
+--
+-- >    Integral    minimum number of digits to show
+-- >    RealFloat   number of digits after the decimal point
+-- >    String      maximum number of characters
+--
+-- The precision for Integral types is accomplished by zero-padding.
+-- If both precision and zero-pad are given for an Integral field,
+-- the zero-pad is ignored.
+--
+-- Any precision is followed optionally for Integral types
+-- by a width modifier; the only use of this modifier being
+-- to set the implicit size of the operand for conversion of
+-- a negative operand to unsigned:
 --
--- >    .num   precision (number of decimal places)
+-- >    hh     Int8
+-- >    h      Int16
+-- >    l      Int32
+-- >    ll     Int64
+-- >    L      Int64
 --
--- and finally, a format character:
+-- The specification ends with a format character:
 --
--- >    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, ...
--- >    f      floating point          Float, Double
--- >    g      general format float    Float, Double
--- >    G      general format float    Float, Double
--- >    e      exponent format float   Float, Double
--- >    E      exponent format float   Float, Double
+-- >    c      character               Integral
+-- >    d      decimal                 Integral
+-- >    o      octal                   Integral
+-- >    x      hexadecimal             Integral
+-- >    X      hexadecimal             Integral
+-- >    b      binary                  Integral
+-- >    u      unsigned decimal        Integral
+-- >    f      floating point          RealFloat
+-- >    F      floating point          RealFloat
+-- >    g      general format float    RealFloat
+-- >    G      general format float    RealFloat
+-- >    e      exponent format float   RealFloat
+-- >    E      exponent format float   RealFloat
 -- >    s      string                  String
+-- >    v      default format          any type
 --
--- Mismatch between the argument types and the format string will cause
--- an exception to be thrown at runtime.
+-- The \"%v\" specifier is provided for all built-in types,
+-- and should be provided for user-defined type formatters
+-- as well. It picks a \"best\" representation for the given
+-- type. For the built-in types the \"%v\" specifier is
+-- converted as follows:
+--
+-- >    c      Char
+-- >    u      other unsigned Integral
+-- >    d      other signed Integral
+-- >    g      RealFloat
+-- >    s      String
+--
+-- Mismatch between the argument types and the format
+-- string, as well as any other syntactic or semantic errors
+-- in the format string, will cause an exception to be
+-- thrown at runtime.
+--
+-- Note that the formatting for 'RealFloat' types is
+-- currently a bit different from that of C @printf(3)@,
+-- conforming instead to 'Numeric.showEFloat',
+-- 'Numeric.showFFloat' and 'Numeric.showGFloat' (and their
+-- alternate versions 'Numeric.showFFloatAlt' and
+-- 'Numeric.showGFloatAlt'). This is hard to fix: the fixed
+-- versions would format in a backward-incompatible way.
+-- In any case the Haskell behavior is generally more
+-- sensible than the C behavior.  A brief summary of some
+-- key differences:
+--
+-- * Haskell 'printf' never uses the default \"6-digit\" precision
+--   used by C printf.
+--
+-- * Haskell 'printf' treats the \"precision\" specifier as
+--   indicating the number of digits after the decimal point.
+--
+-- * Haskell 'printf' prints the exponent of e-format
+--   numbers without a gratuitous plus sign, and with the
+--   minimum possible number of digits.
+--
+-- * Haskell 'printf' will place a zero after a decimal point when
+--   possible.
 --
 -- Examples:
 --
@@ -107,9 +288,25 @@ instance PrintfType String where
 instance (IsChar c) => PrintfType [c] where
     spr fmts args = map fromChar (uprintf fmts (reverse args))
 
+-- Note that this should really be (IO ()), but GHC's
+-- type system won't readily let us say that without
+-- bringing the GADTs. So we go conditional for these defs.
+
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >=  700
+
+instance (a ~ ()) => PrintfType (IO a) where
+    spr fmts args =
+        putStr $ map fromChar $ uprintf fmts $ reverse args
+
+instance (a ~ ()) => HPrintfType (IO a) where
+    hspr hdl fmts args = do
+        hPutStr hdl (uprintf fmts (reverse args))
+
+#else
+
 instance PrintfType (IO a) where
     spr fmts args = do
-        putStr (uprintf fmts (reverse args))
+        putStr $ map fromChar $ uprintf fmts $ reverse args
         return (error "PrintfType (IO a): result should not be used.")
 
 instance HPrintfType (IO a) where
@@ -117,67 +314,89 @@ instance HPrintfType (IO a) where
         hPutStr hdl (uprintf fmts (reverse args))
         return (error "HPrintfType (IO a): result should not be used.")
 
+#endif
+
+
 instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
-    spr fmts args = \ a -> spr fmts (toUPrintf a : args)
+    spr fmts args = \ a -> spr fmts
+                             ((parseFormat a, formatArg a) : args)
 
 instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
-    hspr hdl fmts args = \ a -> hspr hdl fmts (toUPrintf a : args)
-
+    hspr hdl fmts args = \ a -> hspr hdl fmts
+                                  ((parseFormat a, formatArg a) : args)
+
+-- | Typeclass of 'printf'-formattable values. The 'formatArg' method
+-- takes a value and a field format descriptor and either fails due
+-- to a bad descriptor or produces a 'ShowS' as the result. The
+-- default 'parseFormat' expects no modifiers: this is the normal
+-- case. Minimal instance: 'formatArg'.
 class PrintfArg a where
-    toUPrintf :: a -> UPrintf
+    formatArg :: a -> FieldFormatter
+    parseFormat :: a -> ModifierParser
+    parseFormat _ (c : cs) = FormatParse "" c cs
+    parseFormat _ "" = errorShortFormat
 
 instance PrintfArg Char where
-    toUPrintf c = UChar c
+    formatArg = formatChar
+    parseFormat _ cf = parseIntFormat (undefined :: Int) cf
 
-{- not allowed in Haskell 2010
-instance PrintfArg String where
-    toUPrintf s = UString s
--}
 instance (IsChar c) => PrintfArg [c] where
-    toUPrintf = UString . map toChar
+    formatArg = formatString
 
 instance PrintfArg Int where
-    toUPrintf = uInteger
+    formatArg = formatInt
+    parseFormat = parseIntFormat
 
 instance PrintfArg Int8 where
-    toUPrintf = uInteger
+    formatArg = formatInt
+    parseFormat = parseIntFormat
 
 instance PrintfArg Int16 where
-    toUPrintf = uInteger
+    formatArg = formatInt
+    parseFormat = parseIntFormat
 
 instance PrintfArg Int32 where
-    toUPrintf = uInteger
+    formatArg = formatInt
+    parseFormat = parseIntFormat
 
 instance PrintfArg Int64 where
-    toUPrintf = uInteger
+    formatArg = formatInt
+    parseFormat = parseIntFormat
 
 instance PrintfArg Word where
-    toUPrintf = uInteger
+    formatArg = formatInt
+    parseFormat = parseIntFormat
 
 instance PrintfArg Word8 where
-    toUPrintf = uInteger
+    formatArg = formatInt
+    parseFormat = parseIntFormat
 
 instance PrintfArg Word16 where
-    toUPrintf = uInteger
+    formatArg = formatInt
+    parseFormat = parseIntFormat
 
 instance PrintfArg Word32 where
-    toUPrintf = uInteger
+    formatArg = formatInt
+    parseFormat = parseIntFormat
 
 instance PrintfArg Word64 where
-    toUPrintf = uInteger
+    formatArg = formatInt
+    parseFormat = parseIntFormat
 
 instance PrintfArg Integer where
-    toUPrintf = UInteger 0
+    formatArg = formatInteger
+    parseFormat = parseIntFormat
 
 instance PrintfArg Float where
-    toUPrintf = UFloat
+    formatArg = formatRealFloat
 
 instance PrintfArg Double where
-    toUPrintf = UDouble
-
-uInteger :: (Integral a, Bounded a) => a -> UPrintf
-uInteger x = UInteger (toInteger $ minBound `asTypeOf` x) (toInteger x)
+    formatArg = formatRealFloat
 
+-- | This class, with only the one instance, is used as
+-- a workaround for the fact that 'String', as a concrete
+-- type, is not allowable as a typeclass instance. 'IsChar'
+-- is exported for backward-compatibility.
 class IsChar c where
     toChar :: c -> Char
     fromChar :: Char -> c
@@ -188,140 +407,470 @@ instance IsChar Char where
 
 -------------------
 
-data UPrintf = UChar Char | UString String | UInteger Integer Integer | UFloat Float | UDouble Double
-
+-- | Whether to left-adjust or zero-pad a field. These are
+-- mutually exclusive, with 'LeftAdjust' taking precedence.
+data FormatAdjustment = LeftAdjust | ZeroPad
+
+-- | How to handle the sign of a numeric field.  These are
+-- mutually exclusive, with 'SignPlus' taking precedence.
+data FormatSign = SignPlus | SignSpace
+
+-- | Description of field formatting for 'formatArg'. See UNIX `printf`(3)
+-- for a description of how field formatting works.
+data FieldFormat = FieldFormat {
+  fmtWidth :: Maybe Int,       -- ^ Total width of the field.
+  fmtPrecision :: Maybe Int,   -- ^ Secondary field width specifier.
+  fmtAdjust :: Maybe FormatAdjustment,  -- ^ Kind of filling or padding
+                                        --   to be done.
+  fmtSign :: Maybe FormatSign, -- ^ Whether to insist on a
+                               -- plus sign for positive
+                               -- numbers.
+  fmtAlternate :: Bool,        -- ^ Indicates an "alternate
+                               -- format".  See printf(3)
+                               -- for the details, which
+                               -- vary by argument spec.
+  fmtModifiers :: String,      -- ^ Characters that appeared
+                               -- immediately to the left of
+                               -- 'fmtChar' in the format
+                               -- and were accepted by the
+                               -- type's 'parseFormat'.
+                               -- Normally the empty string.
+  fmtChar :: Char              -- ^ The format character
+                               -- 'printf' was invoked
+                               -- with. 'formatArg' should
+                               -- fail unless this character
+                               -- matches the type. It is
+                               -- normal to handle many
+                               -- different format
+                               -- characters for a single
+                               -- type.
+  }
+
+-- | The \"format parser\" walks over argument-type-specific
+-- modifier characters to find the primary format character.
+-- This is the type of its result.
+data FormatParse = FormatParse {
+  fpModifiers :: String,   -- ^ Any modifiers found.
+  fpChar :: Char,          -- ^ Primary format character.
+  fpRest :: String         -- ^ Rest of the format string.
+  }
+
+-- Contains the "modifier letters" that can precede an
+-- integer type.
+intModifierMap :: [(String, Integer)]
+intModifierMap = [
+  ("hh", toInteger (minBound :: Int8)),
+  ("h", toInteger (minBound :: Int16)),
+  ("l", toInteger (minBound :: Int32)),
+  ("ll", toInteger (minBound :: Int64)),
+  ("L", toInteger (minBound :: Int64)) ]
+
+parseIntFormat :: Integral a => a -> String -> FormatParse
+parseIntFormat _ s =
+  case foldr matchPrefix Nothing intModifierMap of
+    Just m -> m
+    Nothing ->
+      case s of
+        c : cs -> FormatParse "" c cs
+        "" -> errorShortFormat
+  where
+    matchPrefix (p, _) m@(Just (FormatParse p0 _ _))
+      | length p0 >= length p = m
+      | otherwise = case getFormat p of
+          Nothing -> m
+          Just fp -> Just fp
+    matchPrefix (p, _) Nothing =
+      getFormat p
+    getFormat p =
+      stripPrefix p s >>= fp
+      where
+        fp (c : cs) = Just $ FormatParse p c cs
+        fp "" = errorShortFormat
+
+-- | This is the type of a field formatter reified over its
+-- argument.
+type FieldFormatter = FieldFormat -> ShowS
+
+-- | Type of a function that will parse modifier characters
+-- from the format string.
+type ModifierParser = String -> FormatParse
+
+-- | Substitute a \'v\' format character with the given
+-- default format character in the 'FieldFormat'. A
+-- convenience for user-implemented types, which should
+-- support \"%v\".
+vFmt :: Char -> FieldFormat -> FieldFormat
+vFmt c ufmt@(FieldFormat {fmtChar = 'v'}) = ufmt {fmtChar = c}
+vFmt _ ufmt = ufmt
+
+-- | Formatter for 'Char' values.
+formatChar :: Char -> FieldFormatter
+formatChar x ufmt =
+  formatIntegral (Just 0) (toInteger $ ord x) $ vFmt 'c' ufmt
+
+-- | Formatter for 'String' values.
+formatString :: IsChar a => [a] -> FieldFormatter
+formatString x ufmt =
+  case fmtChar $ vFmt 's' ufmt of
+    's' -> map toChar . (adjust ufmt ("", ts) ++)
+           where
+             ts = map toChar $ trunc $ fmtPrecision ufmt
+               where
+                 trunc Nothing = x
+                 trunc (Just n) = take n x
+    c   -> errorBadFormat c
+
+-- Possibly apply the int modifiers to get a new
+-- int width for conversion.
+fixupMods :: FieldFormat -> Maybe Integer -> Maybe Integer
+fixupMods ufmt m =
+  let mods = fmtModifiers ufmt in
+  case mods of
+    "" -> m
+    _ -> case lookup mods intModifierMap of
+      Just m0 -> Just m0
+      Nothing -> perror "unknown format modifier"
+
+-- | Formatter for 'Int' values.
+formatInt :: (Integral a, Bounded a) => a -> FieldFormatter
+formatInt x ufmt =
+  let lb = toInteger $ minBound `asTypeOf` x
+      m = fixupMods ufmt (Just lb)
+      ufmt' = case lb of
+        0 -> vFmt 'u' ufmt
+        _ -> ufmt
+  in
+  formatIntegral m (toInteger x) ufmt'
+
+-- | Formatter for 'Integer' values.
+formatInteger :: Integer -> FieldFormatter
+formatInteger x ufmt =
+  let m = fixupMods ufmt Nothing in
+  formatIntegral m x ufmt
+
+-- All formatting for integral types is handled
+-- consistently.  The only difference is between Integer and
+-- bounded types; this difference is handled by the 'm'
+-- argument containing the lower bound.
+formatIntegral :: Maybe Integer -> Integer -> FieldFormatter
+formatIntegral m x ufmt0 =
+  let prec = fmtPrecision ufmt0 in
+  case fmtChar ufmt of
+    'd' -> (adjustSigned ufmt (fmti prec x) ++)
+    'i' -> (adjustSigned ufmt (fmti prec x) ++)
+    'x' -> (adjust ufmt (fmtu 16 (alt "0x" x) prec m x) ++)
+    'X' -> (adjust ufmt (upcase $ fmtu 16 (alt "0X" x) prec m x) ++)
+    'b' -> (adjust ufmt (fmtu 2 (alt "0b" x) prec m x) ++)
+    'o' -> (adjust ufmt (fmtu 8 (alt "0" x) prec m x) ++)
+    'u' -> (adjust ufmt (fmtu 10 Nothing prec m x) ++)
+    'c' | x >= fromIntegral (ord (minBound :: Char)) &&
+          x <= fromIntegral (ord (maxBound :: Char)) &&
+          fmtPrecision ufmt == Nothing &&
+          fmtModifiers ufmt == "" ->
+            formatString [chr $ fromIntegral x] (ufmt { fmtChar = 's' })
+    'c' -> perror "illegal char conversion"
+    c   -> errorBadFormat c
+  where
+    ufmt = vFmt 'd' $ case ufmt0 of
+      FieldFormat { fmtPrecision = Just _, fmtAdjust = Just ZeroPad } ->
+        ufmt0 { fmtAdjust = Nothing }
+      _ -> ufmt0
+    alt _ 0 = Nothing
+    alt p _ = case fmtAlternate ufmt of
+      True -> Just p
+      False -> Nothing
+    upcase (s1, s2) = (s1, map toUpper s2)
+
+-- | Formatter for 'RealFloat' values.
+formatRealFloat :: RealFloat a => a -> FieldFormatter
+formatRealFloat x ufmt =
+  let c = fmtChar $ vFmt 'g' ufmt
+      prec = fmtPrecision ufmt
+      alt = fmtAlternate ufmt
+  in
+   case c of
+     'e' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
+     'E' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
+     'f' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
+     'F' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
+     'g' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
+     'G' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
+     _   -> errorBadFormat c
+
+-- This is the type carried around for arguments in
+-- the varargs code.
+type UPrintf = (ModifierParser, FieldFormatter)
+
+-- Given a format string and a list of formatting functions
+-- (the actual argument value having already been baked into
+-- each of these functions before delivery), return the
+-- actual formatted text string.
 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 =
-        let (width, prec, ladj, zero, plus, cs', us') = getSpecs False False False cs us
-            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
-            adjust' ("", str) | plus = adjust ("+", str)
-            adjust' ps = adjust ps
-        in
-        case cs' of
-        []     -> fmterr
-        c:cs'' ->
-            case us' of
-            []     -> argerr
-            u:us'' ->
-                (case c of
-                'c' -> adjust  ("", [toEnum (toint u)])
-                '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)
-                '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)
-                's' -> adjust  ("", tostr prec u)
-                _   -> perror ("bad formatting char " ++ [c])
-                 ) ++ uprintf cs'' us''
-
-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
-
-integral_prec :: Int -> String -> String
-integral_prec prec integral = (replicate (prec - (length integral)) '0') ++ integral
-
-toint :: UPrintf -> Int
-toint (UInteger _ i) = fromInteger i
-toint (UChar c)      = fromEnum c
-toint _              = baderr
-
-tostr :: Int -> UPrintf -> String
-tostr n (UString s) = if n >= 0 then take n s else s
-tostr _ _                 = baderr
-
-itosb :: Integer -> Integer -> String
-itosb b n =
-        if n < b then
-            [intToDigit $ fromInteger n]
-        else
-            let (q, r) = quotRem n b in
-            itosb b q ++ [intToDigit $ fromInteger r]
-
-stoi :: Int -> String -> (Int, String)
-stoi a (c:cs) | isDigit c = stoi (a*10 + digitToInt c) cs
-stoi a cs                 = (a, cs)
-
-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
-getSpecs l z s ('*':cs) us =
-        let (us', n) = getStar us
-            ((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  (abs n, p, if n < 0 then not l else l, z, s, cs'', us'')
-getSpecs l z s ('.':cs) us =
-        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')
-getSpecs l z s cs@(c:_) us | isDigit c =
-        let (n, cs') = stoi 0 cs
-            ((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')
-getSpecs l z s cs       us = (0, -1, l, z, s, cs, us)
-
+uprintf s us = uprintfs s us ""
+
+-- This function does the actual work, producing a ShowS
+-- instead of a string, for future expansion and for
+-- misguided efficiency.
+uprintfs :: String -> [UPrintf] -> ShowS
+uprintfs ""       []       = id
+uprintfs ""       (_:_)    = errorShortFormat
+uprintfs ('%':'%':cs) us   = ('%' :) . uprintfs cs us
+uprintfs ('%':_)  []       = errorMissingArgument
+uprintfs ('%':cs) us@(_:_) = fmt cs us
+uprintfs (c:cs)   us       = (c :) . uprintfs cs us
+
+-- Given a suffix of the format string starting just after
+-- the percent sign, and the list of remaining unprocessed
+-- arguments in the form described above, format the portion
+-- of the output described by this field description, and
+-- then continue with 'uprintfs'.
+fmt :: String -> [UPrintf] -> ShowS
+fmt cs0 us0 =
+  case getSpecs False False Nothing False cs0 us0 of
+    (_, _, []) -> errorMissingArgument
+    (ufmt, cs, (_, u) : us) -> u ufmt . uprintfs cs us
+
+-- Given field formatting information, and a tuple
+-- consisting of a prefix (for example, a minus sign) that
+-- is supposed to go before the argument value and a string
+-- representing the value, return the properly padded and
+-- formatted result.
+adjust :: FieldFormat -> (String, String) -> String
+adjust ufmt (pre, str) =
+  let naturalWidth = length pre + length str
+      zero = case fmtAdjust ufmt of
+        Just ZeroPad -> True
+        _ -> False
+      left = case fmtAdjust ufmt of
+        Just LeftAdjust -> True
+        _ -> False
+      fill = case fmtWidth ufmt of
+        Just width | naturalWidth < width ->
+          let fillchar = if zero then '0' else ' ' in
+          replicate (width - naturalWidth) fillchar
+        _ -> ""
+  in
+   if left
+   then pre ++ str ++ fill
+   else if zero
+        then pre ++ fill ++ str
+        else fill ++ pre ++ str
+
+-- For positive numbers with an explicit sign field ("+" or
+-- " "), adjust accordingly.
+adjustSigned :: FieldFormat -> (String, String) -> String
+adjustSigned ufmt@(FieldFormat {fmtSign = Just SignPlus}) ("", str) =
+  adjust ufmt ("+", str)
+adjustSigned ufmt@(FieldFormat {fmtSign = Just SignSpace}) ("", str) =
+  adjust ufmt (" ", str)
+adjustSigned ufmt ps =
+  adjust ufmt ps
+
+-- Format a signed integer in the "default" fashion.
+-- This will be subjected to adjust subsequently.
+fmti :: Maybe Int -> Integer -> (String, String)
+fmti prec i
+  | i < 0 = ("-", integral_prec prec (show (-i)))
+  | otherwise = ("", integral_prec prec (show i))
+
+-- Format an unsigned integer in the "default" fashion.
+-- This will be subjected to adjust subsequently.  The 'b'
+-- argument is the base, the 'pre' argument is the prefix,
+-- and the '(Just m)' argument is the implicit lower-bound
+-- size of the operand for conversion from signed to
+-- unsigned. Thus, this function will refuse to convert an
+-- unbounded negative integer to an unsigned string.
+fmtu :: Integer -> Maybe String -> Maybe Int -> Maybe Integer -> Integer
+     -> (String, String)
+fmtu b (Just pre) prec m i =
+  let ("", s) = fmtu b Nothing prec m i in
+  case pre of
+    "0" -> case s of
+      '0' : _ -> ("", s)
+      _ -> (pre, s)
+    _ -> (pre, s)
+fmtu b Nothing prec0 m0 i0 =
+  case fmtu' prec0 m0 i0 of
+    Just s -> ("", s)
+    Nothing -> errorBadArgument
+  where
+    fmtu' :: Maybe Int -> Maybe Integer -> Integer -> Maybe String
+    fmtu' prec (Just m) i | i < 0 =
+      fmtu' prec Nothing (-2 * m + i)
+    fmtu' (Just prec) _ i | i >= 0 =
+      fmap (integral_prec (Just prec)) $ fmtu' Nothing Nothing i
+    fmtu' Nothing _ i | i >= 0 =
+      Just $ showIntAtBase b intToDigit i ""
+    fmtu' _ _ _ = Nothing
+
+
+-- This is used by 'fmtu' and 'fmti' to zero-pad an
+-- int-string to a required precision.
+integral_prec :: Maybe Int -> String -> String
+integral_prec Nothing integral = integral
+integral_prec (Just 0) "0" = ""
+integral_prec (Just prec) integral =
+  replicate (prec - length integral) '0' ++ integral
+
+stoi :: String -> (Int, String)
+stoi cs =
+  let (as, cs') = span isDigit cs in
+  case as of
+    "" -> (0, cs')
+    _ -> (read as, cs')
+
+-- Figure out the FormatAdjustment, given:
+--   width, precision, left-adjust, zero-fill
+adjustment :: Maybe Int -> Maybe a -> Bool -> Bool
+           -> Maybe FormatAdjustment
+adjustment w p l z =
+  case w of
+    Just n | n < 0 -> adjl p True z
+    _ -> adjl p l z
+  where
+    adjl _ True _ = Just LeftAdjust
+    adjl _ False True = Just ZeroPad
+    adjl _ _ _ = Nothing
+
+-- Parse the various format controls to get a format specification.
+getSpecs :: Bool -> Bool -> Maybe FormatSign -> Bool -> String -> [UPrintf]
+         -> (FieldFormat, String, [UPrintf])
+getSpecs _ z s a ('-' : cs0) us = getSpecs True z s a cs0 us
+getSpecs l z _ a ('+' : cs0) us = getSpecs l z (Just SignPlus) a cs0 us
+getSpecs l z s a (' ' : cs0) us =
+  getSpecs l z ss a cs0 us
+  where
+    ss = case s of
+      Just SignPlus -> Just SignPlus
+      _ -> Just SignSpace
+getSpecs l _ s a ('0' : cs0) us = getSpecs l True s a cs0 us
+getSpecs l z s _ ('#' : cs0) us = getSpecs l z s True cs0 us
+getSpecs l z s a ('*' : cs0) us =
+  let (us', n) = getStar us
+      ((p, cs''), us'') = case cs0 of
+        '.':'*':r ->
+          let (us''', p') = getStar us' in ((Just p', r), us''')
+        '.':r ->
+          let (p', r') = stoi r in ((Just p', r'), us')
+        _ ->
+          ((Nothing, cs0), us')
+      FormatParse ms c cs =
+        case us'' of
+          (ufmt, _) : _ -> ufmt cs''
+          [] -> errorMissingArgument
+  in
+   (FieldFormat {
+       fmtWidth = Just (abs n),
+       fmtPrecision = p,
+       fmtAdjust = adjustment (Just n) p l z,
+       fmtSign = s,
+       fmtAlternate = a,
+       fmtModifiers = ms,
+       fmtChar = c}, cs, us'')
+getSpecs l z s a ('.' : cs0) us =
+  let ((p, cs'), us') = case cs0 of
+        '*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')
+        _ ->        (stoi cs0, us)
+      FormatParse ms c cs =
+        case us' of
+          (ufmt, _) : _ -> ufmt cs'
+          [] -> errorMissingArgument
+  in
+   (FieldFormat {
+       fmtWidth = Nothing,
+       fmtPrecision = Just p,
+       fmtAdjust = adjustment Nothing (Just p) l z,
+       fmtSign = s,
+       fmtAlternate = a,
+       fmtModifiers = ms,
+       fmtChar = c}, cs, us')
+getSpecs l z s a cs0@(c0 : _) us | isDigit c0 =
+  let (n, cs') = stoi cs0
+      ((p, cs''), us') = case cs' of
+        '.' : '*' : r ->
+          let (us'', p') = getStar us in ((Just p', r), us'')
+        '.' : r ->
+          let (p', r') = stoi r in ((Just p', r'), us)
+        _ ->
+          ((Nothing, cs'), us)
+      FormatParse ms c cs =
+        case us' of
+          (ufmt, _) : _ -> ufmt cs''
+          [] -> errorMissingArgument
+  in
+   (FieldFormat {
+       fmtWidth = Just (abs n),
+       fmtPrecision = p,
+       fmtAdjust = adjustment (Just n) p l z,
+       fmtSign = s,
+       fmtAlternate = a,
+       fmtModifiers = ms,
+       fmtChar = c}, cs, us')
+getSpecs l z s a cs0@(_ : _) us =
+  let FormatParse ms c cs =
+        case us of
+          (ufmt, _) : _ -> ufmt cs0
+          [] -> errorMissingArgument
+  in
+   (FieldFormat {
+       fmtWidth = Nothing,
+       fmtPrecision = Nothing,
+       fmtAdjust = adjustment Nothing Nothing l z,
+       fmtSign = s,
+       fmtAlternate = a,
+       fmtModifiers = ms,
+       fmtChar = c}, cs, us)
+getSpecs _ _ _ _ ""       _  =
+  errorShortFormat
+
+-- Process a star argument in a format specification.
 getStar :: [UPrintf] -> ([UPrintf], Int)
 getStar us =
-    case us of
-    [] -> argerr
-    nu : us' -> (us', toint nu)
-
-
-dfmt' :: Char -> Int -> UPrintf -> (String, String)
-dfmt' c p (UDouble d) = dfmt c p d
-dfmt' c p (UFloat f)  = dfmt c p f
-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"
-             )
-               (if p < 0 then Nothing else Just p) d "" of
-        '-':cs -> ("-", cs)
-        cs     -> ("" , cs)
-
+  let ufmt = FieldFormat {
+        fmtWidth = Nothing,
+        fmtPrecision = Nothing,
+        fmtAdjust = Nothing,
+        fmtSign = Nothing,
+        fmtAlternate = False,
+        fmtModifiers = "",
+        fmtChar = 'd' } in
+  case us of
+    [] -> errorMissingArgument
+    (_, nu) : us' -> (us', read (nu ufmt ""))
+
+-- Format a RealFloat value.
+dfmt :: (RealFloat a) => Char -> Maybe Int -> Bool -> a -> (String, String)
+dfmt c p a d =
+  let caseConvert = if isUpper c then map toUpper else id
+      showFunction = case toLower c of
+        'e' -> showEFloat
+        'f' -> if a then showFFloatAlt else showFFloat
+        'g' -> if a then showGFloatAlt else showGFloat
+        _   -> perror "internal error: impossible dfmt"
+      result = caseConvert $ showFunction p d ""
+  in
+   case result of
+     '-' : cs -> ("-", cs)
+     cs       -> ("" , cs)
+
+
+-- | Raises an 'error' with a printf-specific prefix on the
+-- message string.
 perror :: String -> a
-perror s = error ("Printf.printf: "++s)
-fmterr, argerr, baderr :: a
-fmterr = perror "formatting string ended prematurely"
-argerr = perror "argument list ended prematurely"
-baderr = perror "bad argument"
+perror s = error $ "printf: " ++ s
+
+-- | Calls 'perror' to indicate an unknown format letter for
+-- a given type.
+errorBadFormat :: Char -> a
+errorBadFormat c = perror $ "bad formatting char " ++ show c
+
+errorShortFormat, errorMissingArgument, errorBadArgument :: a
+-- | Calls 'perror' to indicate that the format string ended
+-- early.
+errorShortFormat = perror "formatting string ended prematurely"
+-- | Calls 'perror' to indicate that there is a missing
+-- argument in the argument list.
+errorMissingArgument = perror "argument list ended prematurely"
+-- | Calls 'perror' to indicate that there is a type
+-- error or similar in the given argument.
+errorBadArgument = perror "bad argument"