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