Bryan O'Sullivan avatar Bryan O'Sullivan committed 1882815

Add support for rendering of integral and floating point values.

Comments (0)

Files changed (5)

Data/Text/Lazy/Builder/Functions.hs

+{-# LANGUAGE MagicHash #-}
+
+-- |
+-- Module      : Data.Text.Lazy.Builder.Functions
+-- Copyright   : (c) 2011 MailRank, Inc.
+--
+-- License     : BSD-style
+-- Maintainer  : bos@serpentine.com
+-- Stability   : experimental
+-- Portability : GHC
+--
+-- Useful functions and combinators.
+
+module Data.Text.Lazy.Builder.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/Lazy/Builder/Int.hs

+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}
+
+-- Module:      Data.Text.Lazy.Builder.Int
+-- Copyright:   (c) 2011 MailRank, Inc.
+-- License:     BSD3
+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
+-- Stability:   experimental
+-- Portability: portable
+--
+-- Efficiently write an integral value to a 'Builder'.
+
+module Data.Text.Lazy.Builder.Int
+    (
+      decimal
+    , hexadecimal
+    ) where
+
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.Monoid (mempty)
+import Data.Text.Lazy.Builder.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
+
+decimal :: Integral a => a -> Builder
+{-# SPECIALIZE decimal :: Int -> Builder #-}
+{-# SPECIALIZE decimal :: Int8 -> Builder #-}
+{-# SPECIALIZE decimal :: Int16 -> Builder #-}
+{-# SPECIALIZE decimal :: Int32 -> Builder #-}
+{-# SPECIALIZE decimal :: Int64 -> Builder #-}
+{-# SPECIALIZE decimal :: Word -> Builder #-}
+{-# SPECIALIZE decimal :: Word8 -> Builder #-}
+{-# SPECIALIZE decimal :: Word16 -> Builder #-}
+{-# SPECIALIZE decimal :: Word32 -> Builder #-}
+{-# SPECIALIZE decimal :: Word64 -> Builder #-}
+{-# RULES "decimal/Integer" decimal = integer 10 :: Integer -> Builder #-}
+decimal i
+    | i < 0     = singleton '-' <> go (-i)
+    | otherwise = go i
+  where
+    go n | n < 10    = digit n
+         | otherwise = go (n `quot` 10) <> digit (n `rem` 10)
+
+hexadecimal :: Integral a => a -> Builder
+{-# SPECIALIZE hexadecimal :: Int -> Builder #-}
+{-# SPECIALIZE hexadecimal :: Int8 -> Builder #-}
+{-# SPECIALIZE hexadecimal :: Int16 -> Builder #-}
+{-# SPECIALIZE hexadecimal :: Int32 -> Builder #-}
+{-# SPECIALIZE hexadecimal :: Int64 -> Builder #-}
+{-# SPECIALIZE hexadecimal :: Word -> Builder #-}
+{-# SPECIALIZE hexadecimal :: Word8 -> Builder #-}
+{-# SPECIALIZE hexadecimal :: Word16 -> Builder #-}
+{-# SPECIALIZE hexadecimal :: Word32 -> Builder #-}
+{-# SPECIALIZE hexadecimal :: Word64 -> Builder #-}
+{-# RULES "hexadecimal/Integer" hexadecimal = integer 16 :: Integer -> Builder #-}
+hexadecimal i
+    | i < 0     = singleton '-' <> go (-i)
+    | otherwise = go i
+  where
+    go n | n < 16    = hexDigit n
+         | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16)
+
+digit :: Integral a => a -> Builder
+digit n = singleton $! i2d (fromIntegral n)
+{-# INLINE digit #-}
+
+hexDigit :: Integral a => a -> Builder
+hexDigit n
+    | n <= 9    = singleton $! i2d (fromIntegral n)
+    | otherwise = singleton $! toEnum (fromIntegral n + 87)
+{-# INLINE hexDigit #-}
+
+int :: Int -> Builder
+int = decimal
+{-# INLINE int #-}
+
+data T = T !Integer !Int
+
+integer :: Int -> Integer -> Builder
+integer 10 (S# i#) = decimal (I# i#)
+integer 16 (S# i#) = hexadecimal (I# i#)
+integer base i
+    | i < 0     = singleton '-' <> 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 _ _      = []
+
+    T maxInt10 maxDigits10 =
+        until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1)
+      where mi = fromIntegral (maxBound :: Int)
+    T maxInt16 maxDigits16 =
+        until ((>mi) . (*16) . fstT) (\(T n d) -> T (n*16) (d+1)) (T 16 1)
+      where mi = fromIntegral (maxBound :: Int)
+
+    fstT (T a _) = a
+
+    maxInt | base == 10 = maxInt10
+           | otherwise  = maxInt16
+    maxDigits | base == 10 = maxDigits10
+              | otherwise  = maxDigits16
+
+    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 (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 = loop maxDigits
+      where
+        loop !d !n
+            | d == 1    = digit n
+            | otherwise = loop (d-1) q <> digit r
+            where q = n `quotInt` base
+                  r = n `remInt` base

Data/Text/Lazy/Builder/RealFloat.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module:    Data.Text.Lazy.Builder.RealFloat
+-- Copyright: (c) The University of Glasgow 1994-2002
+-- License:   see libraries/base/LICENSE
+--
+-- Write a floating point value to a 'Builder'.
+
+module Data.Text.Lazy.Builder.RealFloat
+    (
+      FPFormat(..)
+    , realFloat
+    , formatRealFloat
+    ) where
+
+import Data.Array.Base (unsafeAt)
+import Data.Array.IArray
+import Data.Text.Lazy.Builder.Functions ((<>), i2d)
+import Data.Text.Lazy.Builder.Int (decimal)
+import Data.Text.Lazy.Builder.RealFloat.Functions (roundTo)
+import Data.Text.Lazy.Builder
+import qualified Data.Text as T
+
+-- | 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)
+
+-- | 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.
+realFloat :: (RealFloat a) => a -> Builder
+{-# SPECIALIZE realFloat :: Float -> Builder #-}
+{-# SPECIALIZE realFloat :: Double -> Builder #-}
+realFloat x = formatRealFloat Generic Nothing x
+
+formatRealFloat :: (RealFloat a) =>
+                   FPFormat
+                -> Maybe Int  -- ^ Number of decimal places to render.
+                -> 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]]

Data/Text/Lazy/Builder/RealFloat/Functions.hs

+-- |
+-- Module:    Data.Text.Lazy.Builder.RealFloat.Functions
+-- Copyright: (c) The University of Glasgow 1994-2002
+-- License:   see libraries/base/LICENSE
+
+module Data.Text.Lazy.Builder.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
 name:           text
-version:        0.11.0.9
+version:        0.12.0.0
 homepage:       https://bitbucket.org/bos/text
 bug-reports:    https://bitbucket.org/bos/text/issues
 synopsis:       An efficient packed Unicode text type.
     Data.Text.Internal
     Data.Text.Lazy
     Data.Text.Lazy.Builder
+    Data.Text.Lazy.Builder.Int
+    Data.Text.Lazy.Builder.RealFloat
     Data.Text.Lazy.Encoding
     Data.Text.Lazy.IO
     Data.Text.Lazy.Internal
     Data.Text.Fusion.Internal
     Data.Text.Fusion.Size
     Data.Text.IO.Internal
+    Data.Text.Lazy.Builder.Functions
     Data.Text.Lazy.Encoding.Fusion
     Data.Text.Lazy.Fusion
     Data.Text.Lazy.Search
     Data.Text.Util
 
   build-depends:
+    array,
     base       < 5,
     bytestring >= 0.9 && < 1.0
   if impl(ghc >= 6.10)
     ghc-options: -Werror
     cpp-options: -DASSERTS
 
+  if impl(ghc >= 6.11)
+    cpp-options: -DINTEGER_GMP
+    build-depends: integer-gmp >= 0.2 && < 0.3
+
+  if impl(ghc >= 6.9) && impl(ghc < 6.11)
+    cpp-options: -DINTEGER_GMP
+    build-depends: integer >= 0.1 && < 0.2
+
 source-repository head
   type:     mercurial
   location: https://bitbucket.org/bos/text
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.