text-format (empty) → 0.1.0.0
raw patch · 14 files changed
+1213/−0 lines, 14 filesdep +arraydep +basedep +ghc-primsetup-changed
Dependencies added: array, base, ghc-prim, integer, integer-gmp, old-locale, text, time
Files
- Data/Text/Buildable.hs +160/−0
- Data/Text/Format.hs +76/−0
- Data/Text/Format/Functions.hs +35/−0
- Data/Text/Format/Int.hs +128/−0
- Data/Text/Format/Params.hs +81/−0
- Data/Text/Format/RealFloat.hs +224/−0
- Data/Text/Format/RealFloat/Fast.hs +198/−0
- Data/Text/Format/RealFloat/Fast/Internal.hs +106/−0
- Data/Text/Format/RealFloat/Functions.hs +25/−0
- Data/Text/Format/Types.hs +53/−0
- LICENSE +26/−0
- README.markdown +28/−0
- Setup.lhs +3/−0
- text-format.cabal +70/−0
+ Data/Text/Buildable.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Data.Text.Buildable+-- Copyright : (c) 2011 MailRank, Inc.+--+-- License : BSD-style+-- Maintainer : bos@mailrank.com+-- Stability : experimental+-- Portability : GHC+--+-- Types that can be rendered to a 'Builder'.++module Data.Text.Buildable+ (+ Buildable(..)+ ) where++import Data.Int (Int8, Int16, Int32, Int64)+import Data.Ratio (Ratio, denominator, numerator)+import Data.Text.Format.Functions ((<>))+import Data.Text.Format.Int (integral)+import Data.Text.Format.RealFloat (showFloat)+import Data.Text.Format.RealFloat.Fast (fshowFloat)+import Data.Text.Format.Types (Fast(..), Shown(..))+import Data.Text.Lazy.Builder+import Data.Time.Calendar (Day, showGregorian)+import Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime, UniversalTime)+import Data.Time.Clock (getModJulianDate)+import Data.Time.LocalTime (LocalTime, TimeOfDay, TimeZone, ZonedTime)+import Data.Word (Word, Word8, Word16, Word32, Word64)+import qualified Data.Text as ST+import qualified Data.Text.Lazy as LT++-- | The class of types that can be rendered to a 'Builder'.+class Buildable p where+ build :: p -> Builder++instance Buildable Builder where+ build = id++instance Buildable LT.Text where+ build = fromLazyText+ {-# INLINE build #-}++instance Buildable ST.Text where+ build = fromText+ {-# INLINE build #-}++instance Buildable Char where+ build = singleton+ {-# INLINE build #-}++instance Buildable [Char] where+ build = fromString+ {-# INLINE build #-}++instance Buildable Int8 where+ build = integral+ {-# INLINE build #-}++instance Buildable Int16 where+ build = integral+ {-# INLINE build #-}++instance Buildable Int32 where+ build = integral+ {-# INLINE build #-}++instance Buildable Int where+ build = integral+ {-# INLINE build #-}++instance Buildable Int64 where+ build = integral+ {-# INLINE build #-}++instance Buildable Integer where+ build = integral+ {-# INLINE build #-}++instance Buildable Word8 where+ build = integral+ {-# INLINE build #-}++instance Buildable Word16 where+ build = integral+ {-# INLINE build #-}++instance Buildable Word32 where+ build = integral+ {-# INLINE build #-}++instance Buildable Word where+ build = integral+ {-# INLINE build #-}++instance Buildable Word64 where+ build = integral+ {-# INLINE build #-}++instance (Integral a, Buildable a) => Buildable (Ratio a) where+ {-# SPECIALIZE instance Buildable (Ratio Integer) #-}+ build a = build (numerator a) <> singleton '/' <> build (denominator a)++instance Buildable Float where+ build = showFloat+ {-# INLINE build #-}++instance Buildable Double where+ build = showFloat+ {-# INLINE build #-}++instance Buildable (Fast Float) where+ build = fshowFloat . fromFast+ {-# INLINE build #-}++instance Buildable (Fast Double) where+ build = fshowFloat . fromFast+ {-# INLINE build #-}++instance Buildable DiffTime where+ build = build . Shown+ {-# INLINE build #-}++instance Buildable NominalDiffTime where+ build = build . Shown+ {-# INLINE build #-}++instance Buildable UTCTime where+ build = build . Shown+ {-# INLINE build #-}++instance Buildable UniversalTime where+ build = build . Shown . getModJulianDate+ {-# INLINE build #-}++instance Buildable Day where+ build = fromString . showGregorian+ {-# INLINE build #-}++instance (Show a) => Buildable (Shown a) where+ build = fromString . show . shown+ {-# INLINE build #-}++instance Buildable TimeOfDay where+ build = build . Shown+ {-# INLINE build #-}++instance Buildable TimeZone where+ build = build . Shown+ {-# INLINE build #-}++instance Buildable LocalTime where+ build = build . Shown+ {-# INLINE build #-}++instance Buildable ZonedTime where+ build = build . Shown+ {-# INLINE build #-}
+ Data/Text/Format.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Data.Text.Format+-- Copyright : (c) 2011 MailRank, Inc.+--+-- License : BSD-style+-- Maintainer : bos@mailrank.com+-- Stability : experimental+-- Portability : GHC+--+-- Fast, efficient, flexible support for formatting text strings.++module Data.Text.Format+ (+ -- * Types+ Only(..)+ -- ** Types for format control+ , Fast(..)+ , Shown(..)+ -- * Functions+ -- ** Rendering+ , format+ , print+ , hprint+ , build+ -- ** Functions for format control+ , left+ , right+ ) where++import qualified Data.Text.Buildable as B+import Data.Text.Format.Params (Params(..))+import Data.Text.Format.Functions ((<>))+import Data.Text.Format.Types (Fast(..), Only(..), Shown(..))+import Data.Text.Lazy.Builder+import Prelude hiding (print)+import System.IO (Handle)+import qualified Data.Text as ST+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.IO as LT++-- | Render a format string and arguments to a 'Builder'.+build :: Params ps => ST.Text -> ps -> Builder+build fmt ps = zipParams (map fromText . ST.splitOn "{}" $ fmt) xs+ where zipParams (f:fs) (y:ys) = f <> y <> zipParams fs ys+ zipParams [f] [] = f+ zipParams _ _ = error . LT.unpack $ format+ "Data.Text.Format.build: {} sites, but {} parameters"+ (ST.count "{}" fmt, length xs)+ xs = buildParams ps++-- | Render a format string and arguments to a 'LT.Text'.+format :: Params ps => ST.Text -> ps -> LT.Text+format fmt ps = toLazyText $ build fmt ps++-- | Render a format string and arguments, then print the result.+print :: Params ps => ST.Text -> ps -> IO ()+print fmt ps = LT.putStr . toLazyText $ build fmt ps++-- | Render a format string and arguments, then print the result to+-- the given file handle.+hprint :: Params ps => Handle -> ST.Text -> ps -> IO ()+hprint h fmt ps = LT.hPutStr h . toLazyText $ build fmt ps++-- | Pad the left hand side of a string until it reaches @k@+-- characters wide, filling with character @c@.+left :: B.Buildable a => Int -> Char -> a -> Builder+left k c =+ fromLazyText . LT.justifyLeft (fromIntegral k) c . toLazyText . B.build++-- | Pad the right hand side of a string until it reaches @k@+-- characters wide, filling with character @c@.+right :: B.Buildable a => Int -> Char -> a -> Builder+right k c =+ fromLazyText . LT.justifyRight (fromIntegral k) c . toLazyText . B.build
+ Data/Text/Format/Functions.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE MagicHash #-}++-- |+-- Module : Data.Text.Format.Functions+-- Copyright : (c) 2011 MailRank, Inc.+--+-- License : BSD-style+-- Maintainer : bos@mailrank.com+-- Stability : experimental+-- Portability : GHC+--+-- Useful functions and combinators.++module Data.Text.Format.Functions+ (+ (<>)+ , i2d+ ) where++import Data.Monoid (mappend)+import Data.Text.Lazy.Builder (Builder)+import GHC.Base++-- | Unsafe conversion for decimal digits.+{-# INLINE i2d #-}+i2d :: Int -> Char+i2d (I# i#) = C# (chr# (ord# '0'# +# i#))++-- | The normal 'mappend' function with right associativity instead of+-- left.+(<>) :: Builder -> Builder -> Builder+(<>) = mappend+{-# INLINE (<>) #-}++infixr 4 <>
+ Data/Text/Format/Int.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}++-- Module: Data.Text.Format.Int+-- Copyright: (c) 2011 MailRank, Inc.+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@mailrank.com>+-- Stability: experimental+-- Portability: portable+--+-- Efficiently serialize an integral value to a 'Builder'.++module Data.Text.Format.Int+ (+ digit+ , integral+ , minus+ ) where++import Data.Int (Int8, Int16, Int32, Int64)+import Data.Monoid (mempty)+import Data.Text.Format.Functions ((<>), i2d)+import Data.Text.Lazy.Builder+import Data.Word (Word, Word8, Word16, Word32, Word64)+import GHC.Base (quotInt, remInt)+import GHC.Num (quotRemInteger)+import GHC.Types (Int(..))++#ifdef __GLASGOW_HASKELL__+# if __GLASGOW_HASKELL__ < 611+import GHC.Integer.Internals+# else+import GHC.Integer.GMP.Internals+# endif+#endif++#ifdef INTEGER_GMP+# define PAIR(a,b) (# a,b #)+#else+# define PAIR(a,b) (a,b)+#endif++integral :: Integral a => a -> Builder+{-# SPECIALIZE integral :: Int -> Builder #-}+{-# SPECIALIZE integral :: Int8 -> Builder #-}+{-# SPECIALIZE integral :: Int16 -> Builder #-}+{-# SPECIALIZE integral :: Int32 -> Builder #-}+{-# SPECIALIZE integral :: Int64 -> Builder #-}+{-# SPECIALIZE integral :: Word -> Builder #-}+{-# SPECIALIZE integral :: Word8 -> Builder #-}+{-# SPECIALIZE integral :: Word16 -> Builder #-}+{-# SPECIALIZE integral :: Word32 -> Builder #-}+{-# SPECIALIZE integral :: Word64 -> Builder #-}+{-# RULES "integral/Integer" integral = integer :: Integer -> Builder #-}+integral i+ | i < 0 = minus <> go (-i)+ | otherwise = go i+ where+ go n | n < 10 = digit n+ | otherwise = go (n `quot` 10) <> digit (n `rem` 10)++digit :: Integral a => a -> Builder+digit n = singleton $! i2d (fromIntegral n + 48)+{-# INLINE digit #-}++minus :: Builder+minus = singleton '-'++int :: Int -> Builder+int = integral+{-# INLINE int #-}++integer :: Integer -> Builder+integer (S# i#) = int (I# i#)+integer i+ | i < 0 = minus <> go (-i)+ | otherwise = go i+ where+ go n | n < maxInt = int (fromInteger n)+ | otherwise = putH (splitf (maxInt * maxInt) n)++ splitf p n+ | p > n = [n]+ | otherwise = splith p (splitf (p*p) n)++ splith p (n:ns) = case n `quotRemInteger` p of+ PAIR(q,r) | q > 0 -> q : r : splitb p ns+ | otherwise -> r : splitb p ns+ splith _ _ = error "splith: the impossible happened."++ splitb p (n:ns) = case n `quotRemInteger` p of+ PAIR(q,r) -> q : r : splitb p ns+ splitb _ _ = []++data T = T !Integer !Int++fstT :: T -> Integer+fstT (T a _) = a++maxInt :: Integer+maxDigits :: Int+T maxInt maxDigits =+ until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1)+ where mi = fromIntegral (maxBound :: Int)++putH :: [Integer] -> Builder+putH (n:ns) = case n `quotRemInteger` maxInt of+ PAIR(x,y)+ | q > 0 -> int q <> pblock r <> putB ns+ | otherwise -> int r <> putB ns+ where q = fromInteger x+ r = fromInteger y+putH _ = error "putH: the impossible happened"++putB :: [Integer] -> Builder+putB (n:ns) = case n `quotRemInteger` maxInt of+ PAIR(x,y) -> pblock q <> pblock r <> putB ns+ where q = fromInteger x+ r = fromInteger y+putB _ = mempty++pblock :: Int -> Builder+pblock = go maxDigits+ where+ go !d !n+ | d == 1 = digit n+ | otherwise = go (d-1) q <> digit r+ where q = n `quotInt` 10+ r = n `remInt` 10
+ Data/Text/Format/Params.hs view
@@ -0,0 +1,81 @@+-- |+-- Module : Data.Text.Format.Params+-- Copyright : (c) 2011 MailRank, Inc.+--+-- License : BSD-style+-- Maintainer : bos@mailrank.com+-- Stability : experimental+-- Portability : GHC+--+-- Types that can be used as a collection of arguments for formatting.++module Data.Text.Format.Params+ (+ Params(..)+ ) where++import Data.Text.Buildable+import Data.Text.Format.Types+import Data.Text.Lazy.Builder++-- | The class of types that can be used as a collection of arguments+-- for formatting.+class Params ps where+ buildParams :: ps -> [Builder]++instance (Buildable a) => Params (Only a) where+ buildParams (Only a) = [build a]++instance (Buildable a) => Params [a] where+ buildParams = map build++instance (Buildable a, Buildable b) => Params (a,b) where+ buildParams (a,b) = [build a, build b]++instance (Buildable a, Buildable b, Buildable c) => Params (a,b,c) where+ buildParams (a,b,c) = [build a, build b, build c]++instance (Buildable a, Buildable b, Buildable c, Buildable d)+ => Params (a,b,c,d) where+ buildParams (a,b,c,d) =+ [build a, build b, build c, build d]++instance (Buildable a, Buildable b, Buildable c, Buildable d, Buildable e)+ => Params (a,b,c,d,e) where+ buildParams (a,b,c,d,e) =+ [build a, build b, build c, build d, build e]++instance (Buildable a, Buildable b, Buildable c, Buildable d, Buildable e,+ Buildable f)+ => Params (a,b,c,d,e,f) where+ buildParams (a,b,c,d,e,f) =+ [build a, build b, build c, build d, build e,+ build f]++instance (Buildable a, Buildable b, Buildable c, Buildable d, Buildable e,+ Buildable f, Buildable g)+ => Params (a,b,c,d,e,f,g) where+ buildParams (a,b,c,d,e,f,g) =+ [build a, build b, build c, build d, build e,+ build f, build g]++instance (Buildable a, Buildable b, Buildable c, Buildable d, Buildable e,+ Buildable f, Buildable g, Buildable h)+ => Params (a,b,c,d,e,f,g,h) where+ buildParams (a,b,c,d,e,f,g,h) =+ [build a, build b, build c, build d, build e,+ build f, build g, build h]++instance (Buildable a, Buildable b, Buildable c, Buildable d, Buildable e,+ Buildable f, Buildable g, Buildable h, Buildable i)+ => Params (a,b,c,d,e,f,g,h,i) where+ buildParams (a,b,c,d,e,f,g,h,i) =+ [build a, build b, build c, build d, build e,+ build f, build g, build h, build i]++instance (Buildable a, Buildable b, Buildable c, Buildable d, Buildable e,+ Buildable f, Buildable g, Buildable h, Buildable i, Buildable j)+ => Params (a,b,c,d,e,f,g,h,i,j) where+ buildParams (a,b,c,d,e,f,g,h,i,j) =+ [build a, build b, build c, build d, build e,+ build f, build g, build h, build i, build j]
+ Data/Text/Format/RealFloat.hs view
@@ -0,0 +1,224 @@+{-# 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+ (+ showFloat+ ) where++import Data.Text.Format.Functions ((<>), i2d)+import Data.Text.Format.RealFloat.Functions (roundTo)+import Data.Text.Format.Int (integral)+import Data.Text.Format.Types (Format(..))+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) => Format -> Maybe Int -> a -> Builder+{-# SPECIALIZE formatRealFloat :: Format -> Maybe Int -> Float -> Builder #-}+{-# SPECIALIZE formatRealFloat :: Format -> 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' = integral (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' <> integral (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]]
+ Data/Text/Format/RealFloat/Fast.hs view
@@ -0,0 +1,198 @@+{-# 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+ ) where++import Data.Text.Format.Functions ((<>), i2d)+import Data.Text.Format.Int (integral)+import Data.Text.Format.RealFloat.Fast.Internal (posToDigits)+import Data.Text.Format.RealFloat.Functions (roundTo)+import Data.Text.Format.Types (Format(..))+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 => Format -> Maybe Int -> a -> Builder+{-# SPECIALIZE formatFloat :: Format -> Maybe Int -> Float -> Builder #-}+{-# SPECIALIZE formatFloat :: Format -> 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' = integral $ 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' <> integral (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
+ Data/Text/Format/RealFloat/Fast/Internal.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples #-}+-- |+-- Module: Data.Text.Format.RealFloat.Fast.Internal+-- Copyright: (c) 2011 Daniel Fischer+-- Licence: BSD3+-- Maintainer: Daniel Fischer <daniel.is.fischer@googlemail.com>+-- 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
+ Data/Text/Format/RealFloat/Functions.hs view
@@ -0,0 +1,25 @@+-- |+-- 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
+ Data/Text/Format/Types.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module : Data.Text.Format.Types+-- Copyright : (c) 2011 MailRank, Inc.+--+-- License : BSD-style+-- Maintainer : bos@mailrank.com+-- Stability : experimental+-- Portability : GHC+--+-- Types for text mangling.++module Data.Text.Format.Types+ (+ Format(..)+ , Fast(..)+ , Only(..)+ , Shown(..)+ ) where++-- | Control the rendering of floating point numbers.+data Format = 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)++-- | 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.+newtype Only a = Only {+ fromOnly :: a+ } deriving (Eq, Show, Read, Ord, Num, Fractional, Real, RealFrac,+ Floating, RealFloat, Enum, Integral, Bounded)++-- | Render a value using its 'Show' instance.+newtype Shown a = Shown {+ shown :: a+ } deriving (Eq, Show, Read, Ord, Num, Fractional, Real, RealFrac,+ Floating, RealFloat, Enum, Integral, Bounded)
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2011 MailRank, Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,28 @@+# Welcome to text-format++text-format is a fast and easy-to-use Haskell library for formatting+text strings.++# Join in!++We are happy to receive bug reports, fixes, documentation enhancements,+and other improvements.++Please report bugs via the+[github issue tracker](https://github.com/mailrank/text-format/issues).++Master [git repository](https://github.com/mailrank/text-format):++* `git clone git://github.com/mailrank/text-format.git`++There's also a [Mercurial mirror](https://bitbucket.org/bos/text-format):++* `hg clone https://bitbucket.org/bos/text-format`++(You can create and contribute changes using either git or Mercurial.)++Authors+-------++This library is written and maintained by Bryan O'Sullivan,+<bos@mailrank.com>.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ text-format.cabal view
@@ -0,0 +1,70 @@+name: text-format+version: 0.1.0.0+license: BSD3+license-file: LICENSE+homepage: https://github.com/mailrank/text-format+bug-reports: https://github.com/mailrank/text-format/issues+category: Text+author: Bryan O'Sullivan <bos@mailrank.com>+maintainer: Bryan O'Sullivan <bos@mailrank.com>+stability: experimental+tested-with: GHC == 7.0.3+synopsis: Text formatting+cabal-version: >= 1.8+build-type: Simple+description:+ A text formatting library optimized for ease of use and high+ performance.++extra-source-files:+ README.markdown++flag developer+ description: operate in developer mode+ default: False++library+ exposed-modules:+ Data.Text.Format+ Data.Text.Buildable+ Data.Text.Format.Params+ Data.Text.Format.Types++ 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++ build-depends:+ array,+ base == 4.*,+ ghc-prim,+ integer-gmp,+ old-locale,+ text >= 0.11.0.8,+ time++ if flag(developer)+ ghc-options: -Werror+ ghc-prof-options: -auto-all++ ghc-options: -Wall++ cpp-options: -DINTEGER_GMP++ if impl(ghc >= 6.11)+ build-depends: integer-gmp >= 0.2 && < 0.3++ if impl(ghc >= 6.9) && impl(ghc < 6.11)+ build-depends: integer >= 0.1 && < 0.2++source-repository head+ type: git+ location: http://github.com/mailrank/aeson++source-repository head+ type: mercurial+ location: http://bitbucket.org/bos/aeson