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