module TextShow.Data.Floating (
showbRealFloatPrec
, showbFloatPrec
, showbDoublePrec
, showbEFloat
, showbFFloat
, showbGFloat
, showbFFloatAlt
, showbGFloatAlt
, showbFPFormat
, FPFormat(..)
, formatRealFloatB
, formatRealFloatAltB
) where
import Data.Array.Base (unsafeAt)
import Data.Array.IArray (Array, array)
import Data.Monoid.Compat ((<>))
import qualified Data.Text as T (replicate)
import Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton)
import Data.Text.Lazy.Builder.Int (decimal)
import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))
import TextShow.Classes (TextShow(showb, showbPrec), showbParen)
import TextShow.TH.Internal (deriveTextShow)
import TextShow.Utils (i2d)
#include "inline.h"
showbRealFloatPrec :: RealFloat a => Int -> a -> Builder
showbRealFloatPrec p x
| x < 0 || isNegativeZero x = showbParen (p > 6) $ singleton '-' <> showbGFloat Nothing (x)
| otherwise = showbGFloat Nothing x
showbFloatPrec :: Int -> Float -> Builder
showbFloatPrec = showbRealFloatPrec
showbDoublePrec :: Int -> Double -> Builder
showbDoublePrec = showbRealFloatPrec
showbEFloat :: RealFloat a => Maybe Int -> a -> Builder
showbEFloat = formatRealFloatB Exponent
showbFFloat :: RealFloat a => Maybe Int -> a -> Builder
showbFFloat = formatRealFloatB Fixed
showbGFloat :: RealFloat a => Maybe Int -> a -> Builder
showbGFloat = formatRealFloatB Generic
showbFFloatAlt :: RealFloat a => Maybe Int -> a -> Builder
showbFFloatAlt d = formatRealFloatAltB Fixed d True
showbGFloatAlt :: RealFloat a => Maybe Int -> a -> Builder
showbGFloatAlt d = formatRealFloatAltB Generic d True
showbFPFormat :: FPFormat -> Builder
showbFPFormat = showb
formatRealFloatB :: RealFloat a
=> FPFormat
-> Maybe Int
-> a
-> Builder
formatRealFloatB fmt decs = formatRealFloatAltB fmt decs False
formatRealFloatAltB :: RealFloat a
=> FPFormat
-> Maybe Int
-> Bool
-> a
-> Builder
formatRealFloatAltB fmt decs alt 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' = decimal (e1) 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' <> decimal (e1+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 str rs = mk0 (reverse str) <> singleton '.' <> mk0 rs
f n str "" = f (n1) ('0':str) ""
f n str (r:rs) = f (n1) (r:str) 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 && not alt 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' && not alt then "" else singleton '.' <> fromString ds')
floatToDigits :: (RealFloat a) => a -> ([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
(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 (p1) then
(f*be*b*2, 2*b, be*b, be)
else
(f*be*2, 2, be, be)
else
if e > minExp && f == expt b (p1) 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
let lx = p 1 + e0
k1 = (lx * 8651) `quot` 28738
in if lx >= 0 then k1 + 1 else k1
else
ceiling ((log (fromInteger (f+1) :: Float) +
fromIntegral e * log (fromInteger b)) /
log 10)
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)
roundTo :: Int -> [Int] -> (Int,[Int])
#if MIN_VERSION_base(4,6,0)
roundTo d is =
case f d True is of
x@(0,_) -> x
(1,xs) -> (1, 1:xs)
_ -> error "roundTo: bad Value"
where
b2 = base `quot` 2
f n _ [] = (0, replicate n 0)
f 0 e (x:xs) | x == b2 && e && all (== 0) xs = (0, [])
| otherwise = (if x >= b2 then 1 else 0, [])
f n _ (i:xs)
| i' == base = (1,0:ds)
| otherwise = (0,i':ds)
where
(c,ds) = f (n1) (even i) xs
i' = c + i
base = 10
#else
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 (n1) xs
i' = c + i
#endif
minExpt :: Int
minExpt = 0
maxExpt :: Int
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]]
instance TextShow Float where
showbPrec = showbFloatPrec
INLINE_INST_FUN(showbPrec)
instance TextShow Double where
showbPrec = showbDoublePrec
INLINE_INST_FUN(showbPrec)
$(deriveTextShow ''FPFormat)