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