diff --git a/Data/Text/Buildable.hs b/Data/Text/Buildable.hs --- a/Data/Text/Buildable.hs +++ b/Data/Text/Buildable.hs @@ -20,10 +20,7 @@ import Data.Ratio (Ratio, denominator, numerator) import Data.Text.Format.Functions ((<>)) import Data.Text.Format.Int (decimal, hexadecimal) -import Data.Text.Format.RealFloat (formatRealFloat, showFloat) -import Data.Text.Format.RealFloat.Fast (DispFloat, formatFloat, fshowFloat) -import Data.Text.Format.Types (Fast(..), Hex(..), Shown(..)) -import Data.Text.Format.Types.Internal (FPControl(..)) +import Data.Text.Format.Types (Hex(..), Shown(..)) import Data.Text.Lazy.Builder import Data.Time.Calendar (Day, showGregorian) import Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime, UniversalTime) @@ -31,6 +28,7 @@ import Data.Time.LocalTime (LocalTime, TimeOfDay, TimeZone, ZonedTime) import Data.Word (Word, Word8, Word16, Word32, Word64) import Foreign.Ptr (IntPtr, WordPtr, Ptr, ptrToWordPtr) +import qualified Data.Double.Conversion as C import qualified Data.Text as ST import qualified Data.Text.Lazy as LT @@ -110,23 +108,11 @@ build a = build (numerator a) <> singleton '/' <> build (denominator a) instance Buildable Float where - build = showFloat + build = fromText . C.toShortest . realToFrac {-# INLINE build #-} instance Buildable Double where - build = showFloat - {-# INLINE build #-} - -instance (RealFloat a) => Buildable (FPControl a) where - build (FPControl fmt decs x) = formatRealFloat fmt decs x - {-# INLINE build #-} - -instance (RealFloat a, DispFloat a) => Buildable (Fast a) where - build = fshowFloat . fromFast - {-# INLINE build #-} - -instance (RealFloat a, DispFloat a) => Buildable (Fast (FPControl a)) where - build (Fast (FPControl fmt decs x)) = formatFloat fmt decs x + build = fromText . C.toShortest {-# INLINE build #-} instance Buildable DiffTime where diff --git a/Data/Text/Format.hs b/Data/Text/Format.hs --- a/Data/Text/Format.hs +++ b/Data/Text/Format.hs @@ -17,7 +17,6 @@ Format , Only(..) -- ** Types for format control - , Fast(..) , Shown(..) -- * Rendering , format @@ -31,19 +30,19 @@ , hex -- ** Floating point numbers , expt - , expt_ , fixed - , fixed_ + , prec ) where import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.Text.Format.Functions ((<>)) import Data.Text.Format.Params (Params(..)) -import Data.Text.Format.Types.Internal (FPControl(..), FPFormat(..), Fast(..)) -import Data.Text.Format.Types.Internal (Format(..), Hex(..), Only(..), Shown(..)) +import Data.Text.Format.Types.Internal (Format(..), Only(..), Shown(..)) +import Data.Text.Format.Types.Internal (Hex(..)) import Data.Text.Lazy.Builder import Prelude hiding (exp, print) import System.IO (Handle) +import qualified Data.Double.Conversion as C import qualified Data.Text as ST import qualified Data.Text.Buildable as B import qualified Data.Text.Lazy as LT @@ -86,30 +85,36 @@ right k c = fromLazyText . LT.justifyLeft (fromIntegral k) c . toLazyText . B.build +-- ^ Render a floating point number, with the given number of digits +-- of precision. Uses decimal notation for values between @0.1@ and +-- @9,999,999@, and scientific notation otherwise. +prec :: (Real a) => + Int + -- ^ Number of digits of precision. + -> a -> Builder +{-# RULES "prec/Double" + forall d x. prec d (x::Double) = B.build (C.toPrecision d x) #-} +prec digits = B.build . C.toPrecision digits . realToFrac + -- ^ Render a floating point number using normal notation, with the -- given number of decimal places. -fixed :: (B.Buildable a, RealFloat a) => +fixed :: (Real a) => Int -- ^ Number of digits of precision after the decimal. -> a -> Builder -fixed decs = B.build . FPControl Fixed (Just decs) - --- ^ Render a floating point number using normal notation. -fixed_ :: (B.Buildable a, RealFloat a) => a -> Builder -fixed_ = B.build . FPControl Fixed Nothing +fixed decs = B.build . C.toFixed decs . realToFrac +{-# RULES "fixed/Double" + forall d x. fixed d (x::Double) = B.build (C.toFixed d x) #-} -- ^ Render a floating point number using scientific/engineering -- notation (e.g. @2.3e123@), with the given number of decimal places. -expt :: (B.Buildable a, RealFloat a) => +expt :: (Real a) => Int -- ^ Number of digits of precision after the decimal. -> a -> Builder -expt decs = B.build . FPControl Exponent (Just decs) - --- ^ Render a floating point number using scientific/engineering --- notation (e.g. @2.3e123@). -expt_ :: (B.Buildable a, RealFloat a) => a -> Builder -expt_ = B.build . FPControl Exponent Nothing +expt decs = B.build . C.toExponential decs . realToFrac +{-# RULES "expt/Double" + forall d x. expt d (x::Double) = B.build (C.toExponential d x) #-} -- ^ Render an integer using hexadecimal notation. (No leading "0x" -- is added.) diff --git a/Data/Text/Format/RealFloat.hs b/Data/Text/Format/RealFloat.hs deleted file mode 100644 --- a/Data/Text/Format/RealFloat.hs +++ /dev/null @@ -1,225 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module: Data.Text.Format.RealFloat --- Copyright: (c) The University of Glasgow 1994-2002 --- License: see libraries/base/LICENSE --- --- Serialize a floating point value to a 'Builder'. - -module Data.Text.Format.RealFloat - ( - formatRealFloat - , showFloat - ) where - -import Data.Text.Format.Functions ((<>), i2d) -import Data.Text.Format.RealFloat.Functions (roundTo) -import Data.Text.Format.Int (decimal) -import Data.Text.Format.Types.Internal (FPFormat(..)) -import qualified Data.Text as T -import Data.Array.Base (unsafeAt) -import Data.Text.Lazy.Builder -import Data.Array.IArray - --- | Show a signed 'RealFloat' value to full precision --- using standard decimal notation for arguments whose absolute value lies --- between @0.1@ and @9,999,999@, and scientific notation otherwise. -showFloat :: (RealFloat a) => a -> Builder -{-# SPECIALIZE showFloat :: Float -> Builder #-} -{-# SPECIALIZE showFloat :: Double -> Builder #-} -showFloat x = formatRealFloat Generic Nothing x - -formatRealFloat :: (RealFloat a) => FPFormat -> Maybe Int -> a -> Builder -{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Float -> Builder #-} -{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Double -> Builder #-} -formatRealFloat fmt decs x - | isNaN x = "NaN" - | isInfinite x = if x < 0 then "-Infinity" else "Infinity" - | x < 0 || isNegativeZero x = singleton '-' <> doFmt fmt (floatToDigits (-x)) - | otherwise = doFmt fmt (floatToDigits x) - where - doFmt format (is, e) = - let ds = map i2d is in - case format of - Generic -> - doFmt (if e < 0 || e > 7 then Exponent else Fixed) - (is,e) - Exponent -> - case decs of - Nothing -> - let show_e' = decimal (e-1) in - case ds of - "0" -> "0.0e0" - [d] -> singleton d <> ".0e" <> show_e' - (d:ds') -> singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> show_e' - [] -> error "formatRealFloat/doFmt/Exponent: []" - Just dec -> - let dec' = max dec 1 in - case is of - [0] -> "0." <> fromText (T.replicate dec' "0") <> "e0" - _ -> - let - (ei,is') = roundTo (dec'+1) is - (d:ds') = map i2d (if ei > 0 then init is' else is') - in - singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> decimal (e-1+ei) - Fixed -> - let - mk0 ls = case ls of { "" -> "0" ; _ -> fromString ls} - in - case decs of - Nothing - | e <= 0 -> "0." <> fromText (T.replicate (-e) "0") <> fromString ds - | otherwise -> - let - f 0 s rs = mk0 (reverse s) <> singleton '.' <> mk0 rs - f n s "" = f (n-1) ('0':s) "" - f n s (r:rs) = f (n-1) (r:s) rs - in - f e "" ds - Just dec -> - let dec' = max dec 0 in - if e >= 0 then - let - (ei,is') = roundTo (dec' + e) is - (ls,rs) = splitAt (e+ei) (map i2d is') - in - mk0 ls <> (if null rs then "" else singleton '.' <> fromString rs) - else - let - (ei,is') = roundTo dec' (replicate (-e) 0 ++ is) - d:ds' = map i2d (if ei > 0 then is' else 0:is') - in - singleton d <> (if null ds' then "" else singleton '.' <> fromString ds') - - --- Based on "Printing Floating-Point Numbers Quickly and Accurately" --- by R.G. Burger and R.K. Dybvig in PLDI 96. --- This version uses a much slower logarithm estimator. It should be improved. - --- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number, --- and returns a list of digits and an exponent. --- In particular, if @x>=0@, and --- --- > floatToDigits base x = ([d1,d2,...,dn], e) --- --- then --- --- (1) @n >= 1@ --- --- (2) @x = 0.d1d2...dn * (base**e)@ --- --- (3) @0 <= di <= base-1@ - -floatToDigits :: (RealFloat a) => a -> ([Int], Int) -{-# SPECIALIZE floatToDigits :: Float -> ([Int], Int) #-} -{-# SPECIALIZE floatToDigits :: Double -> ([Int], Int) #-} -floatToDigits 0 = ([0], 0) -floatToDigits x = - let - (f0, e0) = decodeFloat x - (minExp0, _) = floatRange x - p = floatDigits x - b = floatRadix x - minExp = minExp0 - p -- the real minimum exponent - -- Haskell requires that f be adjusted so denormalized numbers - -- will have an impossibly low exponent. Adjust for this. - (f, e) = - let n = minExp - e0 in - if n > 0 then (f0 `quot` (expt b n), e0+n) else (f0, e0) - (r, s, mUp, mDn) = - if e >= 0 then - let be = expt b e in - if f == expt b (p-1) then - (f*be*b*2, 2*b, be*b, be) -- according to Burger and Dybvig - else - (f*be*2, 2, be, be) - else - if e > minExp && f == expt b (p-1) then - (f*b*2, expt b (-e+1)*2, b, 1) - else - (f*2, expt b (-e)*2, 1, 1) - k :: Int - k = - let - k0 :: Int - k0 = - if b == 2 then - -- logBase 10 2 is very slightly larger than 8651/28738 - -- (about 5.3558e-10), so if log x >= 0, the approximation - -- k1 is too small, hence we add one and need one fixup step less. - -- If log x < 0, the approximation errs rather on the high side. - -- That is usually more than compensated for by ignoring the - -- fractional part of logBase 2 x, but when x is a power of 1/2 - -- or slightly larger and the exponent is a multiple of the - -- denominator of the rational approximation to logBase 10 2, - -- k1 is larger than logBase 10 x. If k1 > 1 + logBase 10 x, - -- we get a leading zero-digit we don't want. - -- With the approximation 3/10, this happened for - -- 0.5^1030, 0.5^1040, ..., 0.5^1070 and values close above. - -- The approximation 8651/28738 guarantees k1 < 1 + logBase 10 x - -- for IEEE-ish floating point types with exponent fields - -- <= 17 bits and mantissae of several thousand bits, earlier - -- convergents to logBase 10 2 would fail for long double. - -- Using quot instead of div is a little faster and requires - -- fewer fixup steps for negative lx. - let lx = p - 1 + e0 - k1 = (lx * 8651) `quot` 28738 - in if lx >= 0 then k1 + 1 else k1 - else - -- f :: Integer, log :: Float -> Float, - -- ceiling :: Float -> Int - ceiling ((log (fromInteger (f+1) :: Float) + - fromIntegral e * log (fromInteger b)) / - log 10) ---WAS: fromInt e * log (fromInteger b)) - - fixup n = - if n >= 0 then - if r + mUp <= expt 10 n * s then n else fixup (n+1) - else - if expt 10 (-n) * (r + mUp) <= s then n else fixup (n+1) - in - fixup k0 - - gen ds rn sN mUpN mDnN = - let - (dn, rn') = (rn * 10) `quotRem` sN - mUpN' = mUpN * 10 - mDnN' = mDnN * 10 - in - case (rn' < mDnN', rn' + mUpN' > sN) of - (True, False) -> dn : ds - (False, True) -> dn+1 : ds - (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds - (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN' - - rds = - if k >= 0 then - gen [] r (s * expt 10 k) mUp mDn - else - let bk = expt 10 (-k) in - gen [] (r * bk) s (mUp * bk) (mDn * bk) - in - (map fromIntegral (reverse rds), k) - --- Exponentiation with a cache for the most common numbers. -minExpt, maxExpt :: Int -minExpt = 0 -maxExpt = 1100 - -expt :: Integer -> Int -> Integer -expt base n - | base == 2 && n >= minExpt && n <= maxExpt = expts `unsafeAt` n - | base == 10 && n <= maxExpt10 = expts10 `unsafeAt` n - | otherwise = base^n - -expts :: Array Int Integer -expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] - -maxExpt10 :: Int -maxExpt10 = 324 - -expts10 :: Array Int Integer -expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]] diff --git a/Data/Text/Format/RealFloat/Fast.hs b/Data/Text/Format/RealFloat/Fast.hs deleted file mode 100644 --- a/Data/Text/Format/RealFloat/Fast.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | --- Module: Data.Text.Format.RealFloat.Fast --- Copyright: (c) 2011 Daniel Fischer --- Licence: BSD3 --- Maintainer: Daniel Fischer --- Stability: experimental --- Portability: non-portable (GHC extensions) --- --- Fast 'Builder' representations for floating point types. The code --- is largely taken from code in "GHC.Float" and the 'Show' instance --- of 'Integer' in "GHC.Num" to get the sequence of digits. -module Data.Text.Format.RealFloat.Fast - ( DispFloat(..) - , fshowFloat - , fshowEFloat - , fshowFFloat - , fshowGFloat - , formatFloat - ) where - -import Data.Text.Format.Functions ((<>), i2d) -import Data.Text.Format.Int (decimal) -import Data.Text.Format.RealFloat.Fast.Internal (posToDigits) -import Data.Text.Format.RealFloat.Functions (roundTo) -import Data.Text.Format.Types.Internal (FPFormat(..)) -import Data.Text.Lazy.Builder -import qualified Data.Text as T - --- | Class for specifying display parameters. The type @a@ --- is supposed to be an IEEE-ish (real) floating-point --- type with floating-point radix 2, such that the mantissa --- returned by 'decodeFloat' satisfies --- --- @ --- 2^('binExp' x) <= 'fst' ('decodeFloat' x) < 2^('binExp' x + 1) --- @ --- --- for @x > 0@, so @'binExp' x = 'floatDigits' x - 1@. --- The number of decimal digits that may be required is calculated --- with the formula --- --- @ --- 'decDigits' x = 2 + 'floor' ('floatDigits' x * 'logBase' 10 2). --- @ --- --- The default implementation uses an approximation of --- @'logBase' 10 2@ sufficient for mantissae of up to --- several thousand bits. Nevertheless, hardcoding --- the values in instance declarations may yield --- better performance. -class (RealFloat a) => DispFloat a where - -- | The number of decimal digits that may be needed to - -- uniquely determine a value of type @a@. - -- For faster conversions which need not satisfy - -- - -- @ - -- x == 'read' ('fshow' x) - -- @ - -- - -- a smaller value can be given. - decDigits :: a -> Int - decDigits x = 2 + (8651*(floatDigits x)) `quot` 28738 - -- | The base 2 logarithm of the mantissa returned by - -- @'decodeFloat' x@ for @x > 0@. - binExp :: a -> Int - binExp x = floatDigits x - 1 - -instance DispFloat Double where - decDigits _ = 17 - binExp _ = 52 - -instance DispFloat Float where - decDigits _ = 9 - binExp _ = 23 - --- | Show a signed 'DispFloat' value to full precision --- using standard decimal notation for arguments whose absolute value lies --- between @0.1@ and @9,999,999@, and scientific notation otherwise. --- Analogous to @'showFloat'@ from "GHC.Float". -fshowFloat :: (DispFloat a) => a -> Builder -{-# SPECIALIZE fshowFloat :: Float -> Builder #-} -{-# SPECIALIZE fshowFloat :: Double -> Builder #-} -fshowFloat x = formatFloat Generic Nothing x - --- | Show a signed 'DispFloat' value --- using scientific (exponential) notation (e.g. @2.45e2@, @1.5e-3@). --- --- In the call @'fshowEFloat' digs val@, if @digs@ is 'Nothing', --- the value is shown to full precision; if @digs@ is @'Just' d@, --- then @'max' 1 d@ digits after the decimal point are shown. --- Analogous to @'showEFloat'@ from "Numeric". -fshowEFloat :: (DispFloat a) => Maybe Int -> a -> Builder -{-# SPECIALIZE fshowEFloat :: Maybe Int -> Float -> Builder #-} -{-# SPECIALIZE fshowEFloat :: Maybe Int -> Double -> Builder #-} -fshowEFloat d x = formatFloat Exponent d x - --- | Show a signed 'DispFloat' value --- using standard decimal notation (e.g. @245000@, @0.0015@). --- --- In the call @'fshowFFloat' digs val@, if @digs@ is 'Nothing', --- the value is shown to full precision; if @digs@ is @'Just' d@, --- then @'max' 0 d@ digits after the decimal point are shown. --- Analogous to @'showFFloat'@ from "Numeric". -fshowFFloat :: (DispFloat a) => Maybe Int -> a -> Builder -{-# SPECIALIZE fshowFFloat :: Maybe Int -> Float -> Builder #-} -{-# SPECIALIZE fshowFFloat :: Maybe Int -> Double -> Builder #-} -fshowFFloat d x = formatFloat Fixed d x - --- | Show a signed 'DispFloat' value --- using standard decimal notation for arguments whose absolute value lies --- between @0.1@ and @9,999,999@, and scientific notation otherwise. --- --- In the call @'fshowGFloat' digs val@, if @digs@ is 'Nothing', --- the value is shown to full precision; if @digs@ is @'Just' d@, --- then @'max' 1 d@ digits after the decimal point are shown. --- Analogous to @'showGFloat'@ from "Numeric". -fshowGFloat :: (DispFloat a) => Maybe Int -> a -> Builder -{-# SPECIALIZE fshowGFloat :: Maybe Int -> Float -> Builder #-} -{-# SPECIALIZE fshowGFloat :: Maybe Int -> Double -> Builder #-} -fshowGFloat d x = formatFloat Generic d x - -formatFloat :: DispFloat a => FPFormat -> Maybe Int -> a -> Builder -{-# SPECIALIZE formatFloat :: FPFormat -> Maybe Int -> Float -> Builder #-} -{-# SPECIALIZE formatFloat :: FPFormat -> Maybe Int -> Double -> Builder #-} -formatFloat fmt decs x - | isNaN x = "NaN" - | isInfinite x = if x < 0 then "-Infinity" else "Infinity" - | x < 0 || isNegativeZero x = singleton '-' <> doFmt fmt (fltDigs (-x)) - | otherwise = doFmt fmt (fltDigs x) - where - fltDigs 0 = ([0],0) - fltDigs y = uncurry (posToDigits (decDigits y) (binExp y)) (decodeFloat y) - fluff :: [Int] -> [Int] - fluff [] = [0] - fluff xs = xs - - doFmt format (is, e) = - case format of - Generic -> - doFmt (if e < 0 || e > 7 then Exponent else Fixed) (is,e) - Exponent -> - case decs of - Nothing -> - let show_e' = decimal $ if ei == 0 then (e-1) else e - (ei,(d:ds)) = roundToS (decDigits x) is - in case is of - [0] -> "0.0e0" - _ -> singleton (i2d d) <> singleton '.' <> fromString (map i2d (fluff ds)) <> singleton 'e' <> show_e' - Just dec -> - let dec' = max dec 1 in - case is of - [0] -> fromText "0." <> fromText (T.replicate dec' "0") <> "e0" - _ -> let (ei,is') = roundTo (dec'+1) is - (d:ds') = map i2d (if ei > 0 then init is' else is') - in singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> decimal (e-1+ei) - Fixed -> - let mk0 ls = case ls of { "" -> "0" ; _ -> fromString ls} in - case decs of - Nothing -> - let (ei, is') = roundToS (decDigits x) is - e' = e+ei - ds = map i2d is' - in case is of - [0] -> "0.0" - _ | e' <= 0 -> "0." <> fromText (T.replicate (-e') "0") <> fromString (map i2d is') - | otherwise -> - let f 0 s rs = mk0 (reverse s) <> singleton '.' <> mk0 rs - f n s "" = f (n-1) ('0':s) "" - f n s (r:rs) = f (n-1) (r:s) rs - in f e' "" ds - Just dec -> - let dec' = max dec 0 in - if e >= 0 then - let (ei,is') = roundTo (dec' + e) is - (ls,rs) = splitAt (e+ei) (map i2d is') - in mk0 ls <> (if null rs then "" else singleton '.' <> fromString rs) - else - let (ei,is') = roundTo dec' (replicate (-e) 0 ++ is) - d:ds' = map i2d (if ei > 0 then is' else 0:is') - in singleton d <> (if null ds' then "" else singleton '.' <> fromString ds') - -roundToS :: Int -> [Int] -> (Int,[Int]) -roundToS d is = - case f d is of - x@(0,_) -> x - (1,xs) -> (1, 1:xs) - _ -> error "roundToS: bad Value" - where - f _ [] = (0, []) - f 0 (x:_) = (if x >= 5 then 1 else 0, []) - f n (i:xs) - | i' == 10 = (1,prep 0 ds) - | otherwise = (0,prep i' ds) - where - prep 0 [] = [] - prep a bs = a:bs - (c,ds) = f (n-1) xs - i' = c + i diff --git a/Data/Text/Format/RealFloat/Fast/Internal.hs b/Data/Text/Format/RealFloat/Fast/Internal.hs deleted file mode 100644 --- a/Data/Text/Format/RealFloat/Fast/Internal.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples #-} --- | --- Module: Data.Text.Format.RealFloat.Fast.Internal --- Copyright: (c) 2011 Daniel Fischer --- Licence: BSD3 --- Maintainer: Daniel Fischer --- Stability: experimental --- Portability: non-portable (GHC extensions) --- --- Faster digit string generation for floating point numbers. --- Uses a modification of the Integer showing code from "GHC.Num". -module Data.Text.Format.RealFloat.Fast.Internal - ( - posToDigits - ) where - -#include "MachDeps.h" - -import Data.Array.Base (unsafeAt) -import Data.Array.IArray -import GHC.Base -import GHC.Integer -import GHC.Num (quotRemInt) - -#if WORD_SIZE_IN_BITS == 32 -#define DIGITS 9 -#define BASE 1000000000 -#else -#define DIGITS 18 -#define BASE 1000000000000000000 -#endif - --- digits and exponent for a floating point number. --- floatRadix is assumed to be 2, decodeFloat to return --- a mantissa 2^(floatDigits-1) <= mantissa < 2^floatDigits -posToDigits :: Int -> Int -> Integer -> Int -> ([Int],Int) -posToDigits showDigs mantExp mant scaleExp@(I# e#) = (integerToDigits decMant, e10) - where - !rex = mantExp + scaleExp - !l0 = (8651*rex) `quot` 28738 - !l10 = if rex < 0 then l0-1 else l0 - -- 10^l10 <= x < 10^(l10+2) - !decshift@(I# d#) = showDigs - l10 - !binshift = e# +# d# - !decMant - | d# <# 0# = - (if binshift <# 0# - then shiftRInteger mant (negateInt# binshift) - else shiftLInteger mant binshift) `quot` expt5 (I# (negateInt# d#)) - | binshift <# 0# = - shiftRInteger (mant * expt5 decshift) (negateInt# binshift) - | otherwise = shiftLInteger (mant * expt5 decshift) binshift - !e10 = if decMant < expt10 (showDigs+1) then l10+1 else l10+2 - -expt5 :: Int -> Integer -expt5 k = if k <= maxEx5 && k >= 0 then unsafeAt expts5 k else 5^k - -expt10 :: Int -> Integer -expt10 k = if k <= maxEx10 && k >= 0 then unsafeAt expts10 k else 10^k - -maxEx5 :: Int -maxEx5 = 349 - -maxEx10 :: Int -maxEx10 = 25 - -expts5 :: Array Int Integer -expts5 = array (0, maxEx5) [(k,5^k) | k <- [0 .. maxEx5]] - -expts10 :: Array Int Integer -expts10 = array (0,maxEx10) [(k,10^k) | k <- [0 .. maxEx10]] - ------------------------------------------------------------------------------- --- The code to show Integers, modified to produce [Int] instead of [Char] --- Taken from GHC.Num and modified to suit our needs --- The GHC Licence is reproduced in the package root - --- Divide and conquer implementation --- generate the sequence of digits of a positive Integer -integerToDigits :: Integer -> [Int] -integerToDigits nm = integerToDigits' nm [] - -integerToDigits' :: Integer -> [Int] -> [Int] -integerToDigits' nm ds - | nm < BASE = jhead (fromInteger nm) ds - | otherwise = case nm `quotRemInteger` BASE of - (# q, r #) -> integerToDigits' q (jblock (fromInteger r) ds) - where - -- Convert an integer that fits into a machine word. Again, we have two - -- functions, one that drops leading zeros (jhead) and one that doesn't - -- (jblock) - jhead :: Int -> [Int] -> [Int] - jhead n cs - | n < 10 = n:cs - | otherwise = jhead q (r : cs) - where - (q, r) = n `quotRemInt` 10 - - jblock = jblock' {- ' -} DIGITS -- bloody CPP - - jblock' :: Int -> Int -> [Int] -> [Int] - jblock' d n cs - | d == 1 = n : cs - | otherwise = jblock' (d - 1) q (r : cs) - where - (q, r) = n `quotRemInt` 10 diff --git a/Data/Text/Format/RealFloat/Functions.hs b/Data/Text/Format/RealFloat/Functions.hs deleted file mode 100644 --- a/Data/Text/Format/RealFloat/Functions.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | --- Module: Data.Text.Format.RealFloat.Functions --- Copyright: (c) The University of Glasgow 1994-2002 --- License: see libraries/base/LICENSE - -module Data.Text.Format.RealFloat.Functions - ( - roundTo - ) where - -roundTo :: Int -> [Int] -> (Int,[Int]) -roundTo d is = - case f d is of - x@(0,_) -> x - (1,xs) -> (1, 1:xs) - _ -> error "roundTo: bad Value" - where - f n [] = (0, replicate n 0) - f 0 (x:_) = (if x >= 5 then 1 else 0, []) - f n (i:xs) - | i' == 10 = (1,0:ds) - | otherwise = (0,i':ds) - where - (c,ds) = f (n-1) xs - i' = c + i diff --git a/Data/Text/Format/Types.hs b/Data/Text/Format/Types.hs --- a/Data/Text/Format/Types.hs +++ b/Data/Text/Format/Types.hs @@ -18,11 +18,6 @@ , Shown(..) -- * Integer format control , Hex(..) - -- * Floating point format control - , FPControl - , Fast(..) - , DispFloat ) where import Data.Text.Format.Types.Internal -import Data.Text.Format.RealFloat.Fast (DispFloat) diff --git a/Data/Text/Format/Types/Internal.hs b/Data/Text/Format/Types/Internal.hs --- a/Data/Text/Format/Types/Internal.hs +++ b/Data/Text/Format/Types/Internal.hs @@ -18,10 +18,6 @@ , Shown(..) -- * Integer format control , Hex(..) - -- * Floating point format control - , Fast(..) - , FPControl(..) - , FPFormat(..) ) where import Data.Monoid (Monoid(..)) @@ -60,29 +56,6 @@ -- | Render an integral type in hexadecimal. newtype Hex a = Hex a deriving (Eq, Ord, Read, Show, Num, Real, Enum, Integral) - --- | Control the rendering of floating point numbers. -data FPFormat = Exponent - -- ^ Scientific notation (e.g. @2.3e123@). - | Fixed - -- ^ Standard decimal notation. - | Generic - -- ^ Use decimal notation for values between @0.1@ and - -- @9,999,999@, and scientific notation otherwise. - deriving (Enum, Read, Show) - --- | A floating point number, complete with rendering instructions. -data FPControl a = FPControl FPFormat (Maybe Int) a - --- | Render a floating point number using a much faster algorithm than --- the default (up to 10x faster). This performance comes with a --- potential cost in readability, as the faster algorithm can produce --- strings that are longer than the default algorithm --- (e.g. \"@1.3300000000000001@\" instead of \"@1.33@\"). -newtype Fast a = Fast { - fromFast :: a - } deriving (Eq, Show, Read, Ord, Num, Fractional, Real, RealFrac, - Floating, RealFloat) -- | Use this @newtype@ wrapper for your single parameter if you are -- formatting a string containing exactly one substitution site. diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Benchmarks.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Criterion.Main +import Data.Text.Format +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Text.Printf as P + +printf1 :: (P.PrintfArg a) => String -> a -> String +printf1 f a = P.printf f a + +printf2 :: (P.PrintfArg a, P.PrintfArg b) => String -> (a,b) -> String +printf2 f (a,b) = P.printf f a b + +main = defaultMain [ + bgroup "arity" [ + bench "0" $ nf (format "hi") () + , bench "1" $ nf (format "hi {}") (Only $ T.pack "mom") + , bench "2" $ nf (format "hi {}, how are {}") + (T.pack "mom", T.pack "you") + , bench "3" $ nf (format "hi {}, how are {} keeping {}") + (T.pack "mom", T.pack "you", T.pack "now") + , bench "4" $ nf (format "hi {}, {} - how are {} keeping {}") + (T.pack "mom", T.pack "hey", T.pack "you", T.pack "now") + ] + , bgroup "comparison" [ + bench "format1" $ nf (format "hi mom {}\n") (Only (pi::Double)) + , bench "printf1" $ nf (printf1 "hi mom %f\n") (pi::Double) + , bench "format2" $ nf (format "hi mom {} {}\n") (pi::Double, "yeah"::T.Text) + , bench "printf2" $ nf (printf2 "hi mom %f %s\n") (pi::Double, "yeah"::String) + ] + , bgroup "types" [ + bench "unit" $ nf (format "hi") () + , bgroup "int" [ + bench "small" $ nf (format "hi {}") (Only (1::Int)) + , bench "medium" $ nf (format "hi {}") (Only (1234::Int)) + , bench "large" $ nf (format "hi {}") (Only (0x7fffffff::Int)) + ] + , bgroup "float" [ + bench "small" $ nf (format "hi {}") (Only (1::Float)) + , bench "medium" $ nf (format "hi {}") (Only (pi::Float)) + , bench "large" $ nf (format "hi {}") (Only (pi*1e37::Float)) + ] + , bgroup "double" [ + bench "small" $ nf (format "hi {}") (Only (1::Double)) + , bench "medium" $ nf (format "hi {}") (Only (pi::Double)) + , bench "large" $ nf (format "hi {}") (Only (pi*1e37::Double)) + ] + , bgroup "string" [ + bench "small" $ nf (format "hi {}") (Only ("mom" :: String)) + , bench "medium" $ nf (format "hi {}") + (Only . concat . replicate 64 $ ("mom" :: String)) + , bench "large" $ nf (format "hi {}") + (Only . concat . replicate 1024 $ ("mom" :: String)) + ] + , bgroup "text" [ + bench "small" $ nf (format "hi {}") (Only (T.pack "mom")) + , bench "medium" $ nf (format "hi {}") (Only (T.replicate 64 "mom")) + , bench "large" $ nf (format "hi {}") (Only (T.replicate 1024 "mom")) + ] + , bgroup "lazytext" [ + bench "small" $ nf (format "hi {}") (Only (L.pack "mom")) + , bench "medium" $ nf (format "hi {}") + (Only . L.fromChunks . replicate 64 $ "mom") + , bench "large" $ nf (format "hi {}") + (Only . L.fromChunks . replicate 1024 $ "mom") + ] + ] + ] diff --git a/benchmarks/Makefile b/benchmarks/Makefile new file mode 100644 --- /dev/null +++ b/benchmarks/Makefile @@ -0,0 +1,20 @@ +ghc := ghc + +programs := bm simple c-printf c-wprintf + +all: $(programs) + +bm: Benchmarks.hs + $(ghc) -rtsopts -O -o $@ $< + +simple: Simple.hs + $(ghc) -rtsopts -O -o $@ $< + +c-printf: printf.c + $(CC) -O2 -o $@ $< + +c-wprintf: wprintf.c + $(CC) -O2 -o $@ $< + +clean: + -rm -f $(programs) *.hi *.o *.hp diff --git a/benchmarks/Simple.hs b/benchmarks/Simple.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Simple.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +--module Main (main) where + +import Control.Monad +import Data.Bits +import System.Environment +import Data.Text.Format as T +import Data.Time.Clock +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Lazy.Encoding +import qualified Data.ByteString.Lazy as L +import System.IO + +counting :: Int -> (Int -> () -> IO ()) -> IO () +counting count act = loop 0 + where loop !i | i < count = act i () >> loop (i+1) + | otherwise = return () +{-# NOINLINE counting #-} + +idle count = counting count $ \_ x -> return () + +plain count = counting count $ \_ x -> do + L.putStr . encodeUtf8 $ "hi mom\n" + +unit count = counting count $ \_ x -> do + let t = T.format "hi mom\n" x + L.putStr . encodeUtf8 $ t + +int count = counting count $ \i x -> do + let t = T.format "hi mom {}\n" (Only i) + L.putStr . encodeUtf8 $ t + +double count = counting count $ \i x -> do + let t = T.format "hi mom {}\n" (Only (fromIntegral i * dpi)) + L.putStr . encodeUtf8 $ t + +p6 count = counting count $ \i x -> do + let t = T.format "hi mom {}\n" (Only (prec 6 $! fromIntegral i * dpi)) + L.putStr . encodeUtf8 $ t + +arg :: Int -> Text +arg i = T.replicate (i.&.4) "fnord" +{-# NOINLINE arg #-} + +one count = counting count $ \i x -> do + let t = T.format "hi mom {}\n" (Only (arg i)) + L.putStr . encodeUtf8 $ t + +two count = counting count $ \i x -> do + let t = T.format "hi mom {} {}\n" (arg i,arg (i+1)) + L.putStr . encodeUtf8 $ t + +three count = counting count $ \i x -> do + let t = T.format "hi mom {} {} {}\n" (arg i,arg (i+1),arg (i+2)) + L.putStr . encodeUtf8 $ t + +four count = counting count $ \i x -> do + let t = T.format "hi mom {} {} {} {}\n" (arg i,arg (i+1),arg (i+2),arg (i+3)) + L.putStr . encodeUtf8 $ t + +five count = counting count $ \i x -> do + let t = T.format "hi mom {} {} {} {} {}\n" + (arg i,arg (i+1),arg (i+2),arg (i+3),arg (i+4)) + L.putStr . encodeUtf8 $ t + +dpi :: Double +dpi = pi + +main = do + args <- getArgs + let count = case args of + (_:x:_) -> read x + _ -> 100000 + let bm = case args of + ("idle":_) -> idle + ("plain":_) -> plain + ("unit":_) -> unit + ("double":_) -> double + ("p6":_) -> p6 + ("int":_) -> int + ("one":_) -> one + ("two":_) -> two + ("three":_) -> three + ("four":_) -> four + ("five":_) -> five + _ -> error "wut?" + start <- getCurrentTime + bm count + elapsed <- (`diffUTCTime` start) `fmap` getCurrentTime + T.hprint stderr "{} iterations in {} secs ({} thousand/sec)\n" + (count, elapsed, + fromRational (toRational count / toRational elapsed / 1e3) :: Double) diff --git a/benchmarks/printf.c b/benchmarks/printf.c new file mode 100644 --- /dev/null +++ b/benchmarks/printf.c @@ -0,0 +1,38 @@ +#include +#include +#include +#include + +double gettime(void) +{ + struct timeval tv; + + gettimeofday(&tv, NULL); + + return tv.tv_sec + (tv.tv_usec / 1e6); +} + +void loop(int count) +{ + int i; + + for (i = 0; i < count; i++) + printf("hi mom %g\n", (double) i * M_PI); +} + +int main(int argc, char **argv) +{ + double start, elapsed; + int i, count; + + count = argc == 2 ? atoi(argv[1]) : 1600000; + + start = gettime(); + + loop(count); + + elapsed = gettime() - start; + + fprintf(stderr, "%d iterations in %g secs (%g thousand/sec)\n", + count, elapsed, count / elapsed / 1e3); +} diff --git a/benchmarks/wprintf.c b/benchmarks/wprintf.c new file mode 100644 --- /dev/null +++ b/benchmarks/wprintf.c @@ -0,0 +1,39 @@ +#include +#include +#include +#include +#include + +double gettime(void) +{ + struct timeval tv; + + gettimeofday(&tv, NULL); + + return tv.tv_sec + (tv.tv_usec / 1e6); +} + +void loop(int count) +{ + int i; + + for (i = 0; i < count; i++) + wprintf(L"hi mom %g\n", (double) i * M_PI); +} + +int main(int argc, char **argv) +{ + double start, elapsed; + int i, count; + + count = argc == 2 ? atoi(argv[1]) : 1600000; + + start = gettime(); + + loop(count); + + elapsed = gettime() - start; + + fprintf(stderr, "%d iterations in %g secs (%g thousand/sec)\n", + count, elapsed, count / elapsed / 1e3); +} diff --git a/tests/Benchmarks.hs b/tests/Benchmarks.hs deleted file mode 100644 --- a/tests/Benchmarks.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Criterion.Main -import Data.Text.Format -import qualified Data.Text as T -import qualified Data.Text.Lazy as L - -main = defaultMain [ - bgroup "arity" [ - bench "0" $ nf (format "hi") () - , bench "1" $ nf (format "hi {}") (Only $ T.pack "mom") - , bench "2" $ nf (format "hi {}, how are {}") - (T.pack "mom", T.pack "you") - , bench "3" $ nf (format "hi {}, how are {} keeping {}") - (T.pack "mom", T.pack "you", T.pack "now") - , bench "4" $ nf (format "hi {}, {} - how are {} keeping {}") - (T.pack "mom", T.pack "hey", T.pack "you", T.pack "now") - ] - , bgroup "types" [ - bench "unit" $ nf (format "hi") () - , bgroup "int" [ - bench "small" $ nf (format "hi {}") (Only (1::Int)) - , bench "medium" $ nf (format "hi {}") (Only (1234::Int)) - , bench "large" $ nf (format "hi {}") (Only (0x7fffffff::Int)) - ] - , bgroup "float" [ - bgroup "slow" [ - bench "small" $ nf (format "hi {}") (Only (1::Float)) - , bench "medium" $ nf (format "hi {}") (Only (pi::Float)) - , bench "large" $ nf (format "hi {}") (Only (pi*1e37::Float)) - ] - , bgroup "fast" [ - bench "small" $ nf (format "hi {}") (Only (1::Fast Float)) - , bench "medium" $ nf (format "hi {}") (Only (pi::Fast Float)) - , bench "large" $ nf (format "hi {}") (Only (pi*1e37::Fast Float)) - ] - ] - , bgroup "double" [ - bgroup "slow" [ - bench "small" $ nf (format "hi {}") (Only (1::Double)) - , bench "medium" $ nf (format "hi {}") (Only (pi::Double)) - , bench "large" $ nf (format "hi {}") (Only (pi*1e37::Double)) - ] - , bgroup "fast" [ - bench "small" $ nf (format "hi {}") (Only (1::Fast Double)) - , bench "medium" $ nf (format "hi {}") (Only (pi::Fast Double)) - , bench "large" $ nf (format "hi {}") (Only (pi*1e37::Fast Double)) - ] - ] - , bgroup "string" [ - bench "small" $ nf (format "hi {}") (Only ("mom" :: String)) - , bench "medium" $ nf (format "hi {}") - (Only . concat . replicate 64 $ ("mom" :: String)) - , bench "large" $ nf (format "hi {}") - (Only . concat . replicate 1024 $ ("mom" :: String)) - ] - , bgroup "text" [ - bench "small" $ nf (format "hi {}") (Only (T.pack "mom")) - , bench "medium" $ nf (format "hi {}") (Only (T.replicate 64 "mom")) - , bench "large" $ nf (format "hi {}") (Only (T.replicate 1024 "mom")) - ] - , bgroup "lazytext" [ - bench "small" $ nf (format "hi {}") (Only (L.pack "mom")) - , bench "medium" $ nf (format "hi {}") - (Only . L.fromChunks . replicate 64 $ "mom") - , bench "large" $ nf (format "hi {}") - (Only . L.fromChunks . replicate 1024 $ "mom") - ] - ] - ] diff --git a/text-format.cabal b/text-format.cabal --- a/text-format.cabal +++ b/text-format.cabal @@ -1,5 +1,5 @@ name: text-format -version: 0.2.1.0 +version: 0.3.0.0 license: BSD3 license-file: LICENSE homepage: https://github.com/mailrank/text-format @@ -18,7 +18,9 @@ extra-source-files: README.markdown - tests/Benchmarks.hs + benchmarks/Makefile + benchmarks/*.c + benchmarks/*.hs flag developer description: operate in developer mode @@ -34,15 +36,12 @@ other-modules: Data.Text.Format.Functions Data.Text.Format.Int - Data.Text.Format.RealFloat - Data.Text.Format.RealFloat.Fast - Data.Text.Format.RealFloat.Fast.Internal - Data.Text.Format.RealFloat.Functions Data.Text.Format.Types.Internal build-depends: array, base == 4.*, + double-conversion, ghc-prim, integer-gmp, old-locale,