ref: 6b9c2f0d8700d470d6b596469f0b2d5c4a585067
parent: 41c2cd888668f697dbcae2b031c7afacde168987
author: Lennart Augustsson <lennart@augustsson.net>
date: Wed Apr 3 05:39:21 EDT 2024
Add Text.Printf
--- a/lib/AllOfLib.hs
+++ b/lib/AllOfLib.hs
@@ -98,6 +98,7 @@
import System.Process
import Text.PrettyPrint.HughesPJ
import Text.PrettyPrint.HughesPJClass
+import Text.Printf
import Text.Read
import Text.Show
import Unsafe.Coerce
--- /dev/null
+++ b/lib/Text/Printf.hs
@@ -1,0 +1,921 @@
+{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Printf
+-- Copyright : (c) Lennart Augustsson and Bart Massey 2013
+-- License : BSD-style (see the file LICENSE in this distribution)
+--
+-- Maintainer : Bart Massey <bart@cs.pdx.edu>
+-- Stability : provisional
+-- Portability : portable
+--
+-- 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.
+-----------------------------------------------------------------------------
+
+module Text.Printf(
+-- * Printing Functions
+ printf, hPrintf,
+-- * Extending To New Types
+--
+-- | This 'printf' can be extended to format types
+-- other than those provided for by default. This
+-- is done by instantiating '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 writing 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 Data.Char
+import Data.Int
+import Data.List (stripPrefix)
+import Data.Word
+import Numeric
+import Numeric.FormatFloat(showEFloat, showFFloat, showGFloat, showFFloatAlt, showGFloatAlt)
+import Numeric.Natural
+import System.IO
+
+-- $setup
+-- >>> import Prelude
+
+-------------------
+
+-- | Format a variable number of arguments with the C-style formatting string.
+--
+-- >>> printf "%s, %d, %.4f" "hello" 123 pi
+-- hello, 123, 3.1416
+--
+-- 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'
+--
+-- * '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
+-- > 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
+--
+-- Any flags are followed optionally by a field width:
+--
+-- > num field width
+-- > * as num, but taken from argument list
+--
+-- 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:
+--
+-- > hh Int8
+-- > h Int16
+-- > l Int32
+-- > ll Int64
+-- > L Int64
+--
+-- The specification ends with a format character:
+--
+-- > 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
+--
+-- 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.
+printf :: (PrintfType r) => String -> r
+printf fmts = spr fmts []
+
+-- | Similar to 'printf', except that output is via the specified
+-- 'Handle'. The return type is restricted to @('IO' a)@.+hPrintf :: (HPrintfType r) => Handle -> String -> r
+hPrintf hdl fmts = hspr hdl fmts []
+
+-- |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'.
+class PrintfType t where
+ spr :: String -> [UPrintf] -> t
+
+-- | The 'HPrintfType' class provides the variable argument magic for
+-- 'hPrintf'. Its implementation is intentionally not visible from
+-- this module.
+class HPrintfType t where
+ hspr :: Handle -> String -> [UPrintf] -> t
+
+{- not allowed in Haskell 2010+instance PrintfType String where
+ spr fmt args = uprintf fmt (reverse args)
+-}
+-- | @since 2.01
+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.
+
+-- | @since 4.7.0.0
+instance (a ~ ()) => PrintfType (IO a) where
+ spr fmts args =
+ putStr $ map fromChar $ uprintf fmts $ reverse args
+
+-- | @since 4.7.0.0
+instance (a ~ ()) => HPrintfType (IO a) where
+ hspr hdl fmts args =
+ hPutStr hdl (uprintf fmts (reverse args))
+
+-- | @since 2.01
+instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
+ spr fmts args = \ a -> spr fmts
+ ((parseFormat a, formatArg a) : args)
+
+-- | @since 2.01
+instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
+ 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
+ -- | @since 4.7.0.0
+ formatArg :: a -> FieldFormatter
+ -- | @since 4.7.0.0
+ parseFormat :: a -> ModifierParser
+ parseFormat _ (c : cs) = FormatParse "" c cs
+ parseFormat _ "" = errorShortFormat
+
+-- | @since 2.01
+instance PrintfArg Char where
+ formatArg = formatChar
+ parseFormat _ cf = parseIntFormat (undefined :: Int) cf
+
+-- | @since 2.01
+instance (IsChar c) => PrintfArg [c] where
+ formatArg = formatString
+
+-- | @since 2.01
+instance PrintfArg Int where
+ formatArg = formatInt
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Int8 where
+ formatArg = formatInt
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Int16 where
+ formatArg = formatInt
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Int32 where
+ formatArg = formatInt
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Int64 where
+ formatArg = formatInt
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Word where
+ formatArg = formatInt
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Word8 where
+ formatArg = formatInt
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Word16 where
+ formatArg = formatInt
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Word32 where
+ formatArg = formatInt
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Word64 where
+ formatArg = formatInt
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Integer where
+ formatArg = formatInteger
+ parseFormat = parseIntFormat
+
+-- | @since 4.8.0.0
+instance PrintfArg Natural where
+ formatArg = formatInteger . toInteger
+ parseFormat = parseIntFormat
+
+-- | @since 2.01
+instance PrintfArg Float where
+ formatArg = formatRealFloat
+
+{- Double=Float+-- | @since 2.01
+instance PrintfArg Double where
+ 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
+ -- | @since 4.7.0.0
+ toChar :: c -> Char
+ -- | @since 4.7.0.0
+ fromChar :: Char -> c
+
+-- | @since 2.01
+instance IsChar Char where
+ toChar c = c
+ fromChar c = c
+
+-------------------
+
+-- | Whether to left-adjust or zero-pad a field. These are
+-- mutually exclusive, with 'LeftAdjust' taking precedence.
+--
+-- @since 4.7.0.0
+data FormatAdjustment = LeftAdjust | ZeroPad
+
+-- | How to handle the sign of a numeric field. These are
+-- mutually exclusive, with 'SignPlus' taking precedence.
+--
+-- @since 4.7.0.0
+data FormatSign = SignPlus | SignSpace
+
+-- | Description of field formatting for 'formatArg'. See UNIX @printf(3)@
+-- for a description of how field formatting works.
+--
+-- @since 4.7.0.0
+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.
+--
+-- @since 4.7.0.0
+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 :: 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.
+--
+-- @since 4.7.0.0
+type FieldFormatter = FieldFormat -> ShowS
+
+-- | Type of a function that will parse modifier characters
+-- from the format string.
+--
+-- @since 4.7.0.0
+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\".
+--
+-- @since 4.7.0.0
+vFmt :: Char -> FieldFormat -> FieldFormat
+vFmt c ufmt@(FieldFormat {fmtChar = 'v'}) = ufmt {fmtChar = c}+vFmt _ ufmt = ufmt
+
+-- | Formatter for 'Char' values.
+--
+-- @since 4.7.0.0
+formatChar :: Char -> FieldFormatter
+formatChar x ufmt =
+ formatIntegral (Just 0) (toInteger $ ord x) $ vFmt 'c' ufmt
+
+-- | Formatter for 'String' values.
+--
+-- @since 4.7.0.0
+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.
+--
+-- @since 4.7.0.0
+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.
+--
+-- @since 4.7.0.0
+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.
+--
+-- @since 4.7.0.0
+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 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 =
+ 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.
+--
+-- @since 4.7.0.0
+perror :: String -> a
+perror s = error $ "printf: " ++ s
+
+-- | Calls 'perror' to indicate an unknown format letter for
+-- a given type.
+--
+-- @since 4.7.0.0
+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.
+--
+-- @since 4.7.0.0
+errorShortFormat = perror "formatting string ended prematurely"
+-- | Calls 'perror' to indicate that there is a missing
+-- argument in the argument list.
+--
+-- @since 4.7.0.0
+errorMissingArgument = perror "argument list ended prematurely"
+-- | Calls 'perror' to indicate that there is a type
+-- error or similar in the given argument.
+--
+-- @since 4.7.0.0
+errorBadArgument = perror "bad argument"
--
⑨