Bryan O'Sullivan avatar Bryan O'Sullivan committed 954a4f4

Massive edits

Comments (0)

Files changed (12)

Data/Text/Buildable.hs

+{-# LANGUAGE FlexibleInstances #-}
+
+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
+
+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

 {-# LANGUAGE OverloadedStrings #-}
 
 module Data.Text.Format
-    where
+    (
+      Fast(..)
+    , Only(..)
+    , format
+    , build
+    , print
+    , hprint
+    , left
+    , right
+    ) where
 
-import Data.Monoid
+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(..))
+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 as ST
-import Data.Text.Lazy.Builder
-import Data.Text.Format.Param
-import Data.Text.Format.Params
+import qualified Data.Text.Lazy.IO as LT
 
 build :: Params ps => ST.Text -> ps -> Builder
-build fmt ps
-    | null xs && not ("{}" `ST.isInfixOf` fmt) = fromText fmt
-    | otherwise = zipParams (map fromText . ST.splitOn "{}" $ fmt) xs
-  where xs = buildParams ps
-        zipParams (f:fs) (y:ys) = f `mappend` y `mappend` zipParams fs ys
-        zipParams [f] [] = f
-        zipParams _ _ = error "oops"
+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
 
 format :: Params ps => ST.Text -> ps -> LT.Text
 format fmt ps = toLazyText $ build fmt ps
+
+print :: Params ps => ST.Text -> ps -> IO ()
+print fmt ps = LT.putStr . toLazyText $ build fmt ps
+
+hprint :: Params ps => Handle -> ST.Text -> ps -> IO ()
+hprint h fmt ps = LT.hPutStr h . toLazyText $ build fmt ps
+
+left :: B.Buildable a => Int -> Char -> a -> Builder
+left k c =
+    fromLazyText . LT.justifyLeft (fromIntegral k) c . toLazyText . B.build
+
+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

+{-# LANGUAGE MagicHash #-}
+
+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#))
+
+(<>) :: Builder -> Builder -> Builder
+(<>) = mappend
+{-# INLINE (<>) #-}
+
+infixr 4 <>

Data/Text/Format/Int.hs

     , minus
     ) where
 
-import Data.Char (chr)
 import Data.Int (Int8, Int16, Int32, Int64)
-import Data.Monoid (mappend, mempty)
+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)
 {-# SPECIALIZE integral :: Word64 -> Builder #-}
 {-# RULES "integral/Integer" integral = integer :: Integer -> Builder #-}
 integral i
-    | i < 0     = minus `mappend` go (-i)
+    | i < 0     = minus <> go (-i)
     | otherwise = go i
   where
     go n | n < 10    = digit n
-         | otherwise = go (n `quot` 10) `mappend` digit (n `rem` 10)
+         | otherwise = go (n `quot` 10) <> digit (n `rem` 10)
 
 digit :: Integral a => a -> Builder
-digit n = singleton $! chr (fromIntegral n + 48)
+digit n = singleton $! i2d (fromIntegral n + 48)
 {-# INLINE digit #-}
 
 minus :: Builder
 integer :: Integer -> Builder
 integer (S# i#) = int (I# i#)
 integer i
-    | i < 0     = minus `mappend` go (-i)
+    | i < 0     = minus <> go (-i)
     | otherwise = go i
   where
     go n | n < maxInt = int (fromInteger n)
 putH :: [Integer] -> Builder
 putH (n:ns) = case n `quotRemInteger` maxInt of
                 PAIR(x,y)
-                    | q > 0     -> int q `mappend` pblock r `mappend` putB ns
-                    | otherwise -> int r `mappend` putB ns
+                    | 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 `mappend` pblock r `mappend` putB ns
+                PAIR(x,y) -> pblock q <> pblock r <> putB ns
                     where q = fromInteger x
                           r = fromInteger y
 putB _ = mempty
   where
     go !d !n
         | d == 1    = digit n
-        | otherwise = go (d-1) q `mappend` digit r
+        | otherwise = go (d-1) q <> digit r
         where q = n `quotInt` 10
               r = n `remInt` 10

Data/Text/Format/Param.hs

-{-# LANGUAGE FlexibleInstances #-}
-
-module Data.Text.Format.Param
-    (
-      Param(..)
-    ) where
-
-import Data.Text.Lazy.Builder
-import Data.Text.Format.Int
-import qualified Data.Text.Lazy as LT
-import Data.Int (Int8, Int16, Int32, Int64)
-import Data.Word (Word, Word8, Word16, Word32, Word64)
-import qualified Data.Text as ST
-
-class Param p where
-    buildParam :: p -> Builder
-
-instance Param LT.Text where
-    buildParam = fromLazyText
-
-instance Param ST.Text where
-    buildParam = fromText
-
-instance Param Char where
-    buildParam = singleton
-
-instance Param [Char] where
-    buildParam = fromText . ST.pack
-
-instance Param Int8 where
-    buildParam = integral
-    {-# INLINE buildParam #-}
-
-instance Param Int16 where
-    buildParam = integral
-    {-# INLINE buildParam #-}
-
-instance Param Int32 where
-    buildParam = integral
-    {-# INLINE buildParam #-}
-
-instance Param Int where
-    buildParam = integral
-    {-# INLINE buildParam #-}
-
-instance Param Int64 where
-    buildParam = integral
-    {-# INLINE buildParam #-}
-
-instance Param Integer where
-    buildParam = integral
-    {-# INLINE buildParam #-}
-
-instance Param Word8 where
-    buildParam = integral
-    {-# INLINE buildParam #-}
-
-instance Param Word16 where
-    buildParam = integral
-    {-# INLINE buildParam #-}
-
-instance Param Word32 where
-    buildParam = integral
-    {-# INLINE buildParam #-}
-
-instance Param Word where
-    buildParam = integral
-    {-# INLINE buildParam #-}
-
-instance Param Word64 where
-    buildParam = integral
-    {-# INLINE buildParam #-}

Data/Text/Format/Params.hs

       Params(..)
     ) where
 
-import Data.Text.Format.Param
+import Data.Text.Buildable
 import Data.Text.Format.Types
 import Data.Text.Lazy.Builder
 
 class Params ps where
     buildParams :: ps -> [Builder]
 
-instance (Param a) => Params (Only a) where
-    buildParams (Only a) = [buildParam a]
+instance (Buildable a) => Params (Only a) where
+    buildParams (Only a) = [build a]
 
-instance (Param a) => Params [a] where
-    buildParams = map buildParam
+instance (Buildable a) => Params [a] where
+    buildParams = map build
 
-instance (Param a, Param b) => Params (a,b) where
-    buildParams (a,b) = [buildParam a, buildParam b]
+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

+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module:    Data.Text.Format.RealFloat
+-- Copyright: (c) The University of Glasgow 1994-2002
+-- License:   see libraries/base/LICENSE
+
+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

+{-# 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

+{-# 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

+-- |
+-- 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

+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module Data.Text.Format.Types
     (
-      Only(..)
+      Format(..)
+    , Fast(..)
+    , Only(..)
+    , Shown(..)
     ) where
 
-newtype Only a = Only a
-    deriving (Eq, Ord, Read, Show)
+data Format = Exponent | Fixed | Generic
+
+newtype Fast a = Fast {
+      fromFast :: a
+    } deriving (Eq, Show, Read, Ord, Num, Fractional, Real, RealFrac,
+                Floating, RealFloat)
+
+newtype Only a = Only {
+      fromOnly :: a
+    } deriving (Eq, Show, Read, Ord, Num, Fractional, Real, RealFrac,
+                Floating, RealFloat, Enum, Integral, Bounded)
+
+newtype Shown a = Shown {
+      shown :: a
+    } deriving (Eq, Show, Read, Ord, Num, Fractional, Real, RealFrac,
+                Floating, RealFloat, Enum, Integral, Bounded)

text-format.cabal

 library
   exposed-modules:
     Data.Text.Format
-    Data.Text.Format.Param
+    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,
-    text >= 0.11.0.5
+    old-locale,
+    text >= 0.11.0.8,
+    time
 
   if flag(developer)
     ghc-options: -Werror
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.