@@ -1,4 +1,30 @@
1−module Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) where
1+{-# LANGUAGE CPP, OverloadedStrings #-}
2+#if __GLASGOW_HASKELL__ >= 702
3+{-# LANGUAGE Trustworthy #-}
4+#endif
5+
6+-- |
7+-- Module: Data.Text.Lazy.Builder.RealFloat
8+-- Copyright: (c) The University of Glasgow 1994-2002
9+-- License: see libraries/base/LICENSE
10+--
11+-- Write a floating point value to a 'Builder'.
12+
13+module Data.Text.Lazy.Builder.RealFloat
14+ (
15+ FPFormat(..)
16+ , realFloat
17+ , formatRealFloat
18+ ) where
19+
20+-- import Data.Array.Base (unsafeAt)
21+-- import Data.Array.IArray
22+import Data.Text.Internal.Builder.Functions ((<>), i2d)
23+import Data.Text.Lazy.Builder.Int (decimal)
24+import Data.Text.Internal.Builder.RealFloat.Functions (roundTo)
25+import Data.Text.Lazy.Builder
26+import qualified Data.Text as T
27+
228
329-- | Control the rendering of floating point numbers.
430data FPFormat = Exponent
@@ -9,3 +35,210 @@ data FPFormat = Exponent
935 -- ^ Use decimal notation for values between @0.1@ and
1036 -- @9,999,999@, and scientific notation otherwise.
1137 deriving (Enum, Read, Show)
38+
39+-- | Show a signed 'RealFloat' value to full precision,
40+-- using standard decimal notation for arguments whose absolute value lies
41+-- between @0.1@ and @9,999,999@, and scientific notation otherwise.
42+realFloat :: (RealFloat a) => a -> Builder
43+{-# SPECIALIZE realFloat :: Float -> Builder #-}
44+{-# SPECIALIZE realFloat :: Double -> Builder #-}
45+realFloat x = formatRealFloat Generic Nothing x
46+
47+formatRealFloat :: (RealFloat a) =>
48+ FPFormat
49+ -> Maybe Int -- ^ Number of decimal places to render.
50+ -> a
51+ -> Builder
52+{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Float -> Builder #-}
53+{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Double -> Builder #-}
54+formatRealFloat fmt decs x
55+ | isNaN x = "NaN"
56+ | isInfinite x = if x < 0 then "-Infinity" else "Infinity"
57+ | x < 0 || isNegativeZero x = singleton '-' <> doFmt fmt (floatToDigits (-x))
58+ | otherwise = doFmt fmt (floatToDigits x)
59+ where
60+ doFmt format (is, e) =
61+ let ds = map i2d is in
62+ case format of
63+ Generic ->
64+ doFmt (if e < 0 || e > 7 then Exponent else Fixed)
65+ (is,e)
66+ Exponent ->
67+ case decs of
68+ Nothing ->
69+ let show_e' = decimal (e-1) in
70+ case ds of
71+ "0" -> "0.0e0"
72+ [d] -> singleton d <> ".0e" <> show_e'
73+ (d:ds') -> singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> show_e'
74+ [] -> error "formatRealFloat/doFmt/Exponent: []"
75+ Just dec ->
76+ let dec' = max dec 1 in
77+ case is of
78+ [0] -> "0." <> fromText (T.replicate dec' "0") <> "e0"
79+ _ ->
80+ let
81+ (ei,is') = roundTo (dec'+1) is
82+ (d:ds') = map i2d (if ei > 0 then init is' else is')
83+ in
84+ singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> decimal (e-1+ei)
85+ Fixed ->
86+ let
87+ mk0 ls = case ls of { "" -> "0" ; _ -> fromString ls}
88+ in
89+ case decs of
90+ Nothing
91+ | e <= 0 -> "0." <> fromText (T.replicate (-e) "0") <> fromString ds
92+ | otherwise ->
93+ let
94+ f 0 s rs = mk0 (reverse s) <> singleton '.' <> mk0 rs
95+ f n s "" = f (n-1) ('0':s) ""
96+ f n s (r:rs) = f (n-1) (r:s) rs
97+ in
98+ f e "" ds
99+ Just dec ->
100+ let dec' = max dec 0 in
101+ if e >= 0 then
102+ let
103+ (ei,is') = roundTo (dec' + e) is
104+ (ls,rs) = splitAt (e+ei) (map i2d is')
105+ in
106+ mk0 ls <> (if null rs then "" else singleton '.' <> fromString rs)
107+ else
108+ let
109+ (ei,is') = roundTo dec' (replicate (-e) 0 ++ is)
110+ d:ds' = map i2d (if ei > 0 then is' else 0:is')
111+ in
112+ singleton d <> (if null ds' then "" else singleton '.' <> fromString ds')
113+
114+
115+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
116+-- by R.G. Burger and R.K. Dybvig in PLDI 96.
117+-- This version uses a much slower logarithm estimator. It should be improved.
118+
119+-- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number,
120+-- and returns a list of digits and an exponent.
121+-- In particular, if @x>=0@, and
122+--
123+-- > floatToDigits base x = ([d1,d2,...,dn], e)
124+--
125+-- then
126+--
127+-- (1) @n >= 1@
128+--
129+-- (2) @x = 0.d1d2...dn * (base**e)@
130+--
131+-- (3) @0 <= di <= base-1@
132+
133+floatToDigits :: (RealFloat a) => a -> ([Int], Int)
134+{-# SPECIALIZE floatToDigits :: Float -> ([Int], Int) #-}
135+{-# SPECIALIZE floatToDigits :: Double -> ([Int], Int) #-}
136+floatToDigits 0 = ([0], 0)
137+floatToDigits x =
138+ let
139+ (f0, e0) = decodeFloat x
140+ (minExp0, _) = floatRange x
141+ p = floatDigits x
142+ b = floatRadix x
143+ minExp = minExp0 - p -- the real minimum exponent
144+ -- Haskell requires that f be adjusted so denormalized numbers
145+ -- will have an impossibly low exponent. Adjust for this.
146+ (f, e) =
147+ let n = minExp - e0 in
148+ if n > 0 then (f0 `quot` (expt b n), e0+n) else (f0, e0)
149+ (r, s, mUp, mDn) =
150+ if e >= 0 then
151+ let be = expt b e in
152+ if f == expt b (p-1) then
153+ (f*be*b*2, 2*b, be*b, be) -- according to Burger and Dybvig
154+ else
155+ (f*be*2, 2, be, be)
156+ else
157+ if e > minExp && f == expt b (p-1) then
158+ (f*b*2, expt b (-e+1)*2, b, 1)
159+ else
160+ (f*2, expt b (-e)*2, 1, 1)
161+ k :: Int
162+ k =
163+ let
164+ k0 :: Int
165+ k0 =
166+ if b == 2 then
167+ -- logBase 10 2 is very slightly larger than 8651/28738
168+ -- (about 5.3558e-10), so if log x >= 0, the approximation
169+ -- k1 is too small, hence we add one and need one fixup step less.
170+ -- If log x < 0, the approximation errs rather on the high side.
171+ -- That is usually more than compensated for by ignoring the
172+ -- fractional part of logBase 2 x, but when x is a power of 1/2
173+ -- or slightly larger and the exponent is a multiple of the
174+ -- denominator of the rational approximation to logBase 10 2,
175+ -- k1 is larger than logBase 10 x. If k1 > 1 + logBase 10 x,
176+ -- we get a leading zero-digit we don't want.
177+ -- With the approximation 3/10, this happened for
178+ -- 0.5^1030, 0.5^1040, ..., 0.5^1070 and values close above.
179+ -- The approximation 8651/28738 guarantees k1 < 1 + logBase 10 x
180+ -- for IEEE-ish floating point types with exponent fields
181+ -- <= 17 bits and mantissae of several thousand bits, earlier
182+ -- convergents to logBase 10 2 would fail for long double.
183+ -- Using quot instead of div is a little faster and requires
184+ -- fewer fixup steps for negative lx.
185+ let lx = p - 1 + e0
186+ k1 = (lx * 8651) `quot` 28738
187+ in if lx >= 0 then k1 + 1 else k1
188+ else
189+ -- f :: Integer, log :: Float -> Float,
190+ -- ceiling :: Float -> Int
191+ ceiling ((log (fromInteger (f+1) :: Float) +
192+ fromIntegral e * log (fromInteger b)) /
193+ log 10)
194+--WAS: fromInt e * log (fromInteger b))
195+
196+ fixup n =
197+ if n >= 0 then
198+ if r + mUp <= expt 10 n * s then n else fixup (n+1)
199+ else
200+ if expt 10 (-n) * (r + mUp) <= s then n else fixup (n+1)
201+ in
202+ fixup k0
203+
204+ gen ds rn sN mUpN mDnN =
205+ let
206+ (dn, rn') = (rn * 10) `quotRem` sN
207+ mUpN' = mUpN * 10
208+ mDnN' = mDnN * 10
209+ in
210+ case (rn' < mDnN', rn' + mUpN' > sN) of
211+ (True, False) -> dn : ds
212+ (False, True) -> dn+1 : ds
213+ (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
214+ (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
215+
216+ rds =
217+ if k >= 0 then
218+ gen [] r (s * expt 10 k) mUp mDn
219+ else
220+ let bk = expt 10 (-k) in
221+ gen [] (r * bk) s (mUp * bk) (mDn * bk)
222+ in
223+ (map fromIntegral (reverse rds), k)
224+
225+-- Exponentiation with a cache for the most common numbers.
226+minExpt, maxExpt :: Int
227+minExpt = 0
228+maxExpt = 1100
229+
230+expt :: Integer -> Int -> Integer
231+expt base n
232+ | base == 2 && n >= minExpt && n <= maxExpt = expts !! n
233+ | base == 10 && n <= maxExpt10 = expts10 !! n
234+ | otherwise = base^n
235+
236+expts :: [Integer]
237+expts = [2^n | n <- [minExpt .. maxExpt]]
238+
239+maxExpt10 :: Int
240+maxExpt10 = 324
241+
242+expts10 :: [Integer]
243+expts10 = [10^n | n <- [minExpt .. maxExpt10]]
244+