{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Scientific
( Scientific
, scientific
, coefficient
, base10Exponent
, fromFloatDigits
, toRealFloat
, floatingOrInteger
, formatScientific
, FPFormat(..)
, toDecimalDigits
, normalize
) where
import Control.Monad (mplus)
import Control.DeepSeq (NFData)
import Data.Array (Array, listArray, (!))
import Data.Char (intToDigit, ord)
import Data.Data (Data)
import Data.Function (on)
import Data.Functor ((<$>))
import Data.Hashable (Hashable(..))
import Data.Ratio ((%), numerator, denominator)
import Data.Typeable (Typeable)
import Math.NumberTheory.Logarithms (integerLog10')
import qualified Numeric (floatToDigits)
import Text.Read (readPrec)
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import qualified Text.ParserCombinators.ReadP as ReadP
import Text.ParserCombinators.ReadP ( ReadP )
import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))
#if MIN_VERSION_base(4,5,0)
import Data.Bits (unsafeShiftR)
#else
import Data.Bits (shiftR)
#endif
data Scientific = Scientific
{ coefficient :: !Integer
, base10Exponent :: {-# UNPACK #-} !Int
} deriving (Typeable, Data)
scientific :: Integer -> Int -> Scientific
scientific = Scientific
instance NFData Scientific
instance Hashable Scientific where
hashWithSalt salt = hashWithSalt salt . toRational
instance Eq Scientific where
(==) = (==) `on` toRational
{-# INLINE (==) #-}
(/=) = (/=) `on` toRational
{-# INLINE (/=) #-}
instance Ord Scientific where
(<) = (<) `on` toRational
{-# INLINE (<) #-}
(<=) = (<=) `on` toRational
{-# INLINE (<=) #-}
(>) = (>) `on` toRational
{-# INLINE (>) #-}
(>=) = (>=) `on` toRational
{-# INLINE (>=) #-}
compare = compare `on` toRational
{-# INLINE compare #-}
instance Num Scientific where
Scientific c1 e1 + Scientific c2 e2
| e1 < e2 = scientific (c1 + c2*l) e1
| otherwise = scientific (c1*r + c2 ) e2
where
l = magnitude (e2 - e1)
r = magnitude (e1 - e2)
{-# INLINE (+) #-}
Scientific c1 e1 - Scientific c2 e2
| e1 < e2 = scientific (c1 - c2*l) e1
| otherwise = scientific (c1*r - c2 ) e2
where
l = magnitude (e2 - e1)
r = magnitude (e1 - e2)
{-# INLINE (-) #-}
Scientific c1 e1 * Scientific c2 e2 =
scientific (c1 * c2) (e1 + e2)
{-# INLINE (*) #-}
abs (Scientific c e) = Scientific (abs c) e
{-# INLINE abs #-}
negate (Scientific c e) = Scientific (negate c) e
{-# INLINE negate #-}
signum (Scientific c _) = Scientific (signum c) 0
{-# INLINE signum #-}
fromInteger i = scientific i 0
{-# INLINE fromInteger #-}
instance Real Scientific where
toRational (Scientific c e)
| e < 0 = c % magnitude (-e)
| otherwise = (c * magnitude e) % 1
{-# INLINE toRational #-}
{-# RULES
"realToFrac_toRealFloat_Double"
realToFrac = toRealFloat :: Scientific -> Double #-}
{-# RULES
"realToFrac_toRealFloat_Float"
realToFrac = toRealFloat :: Scientific -> Float #-}
instance Fractional Scientific where
recip = fromRational . recip . toRational
{-# INLINE recip #-}
fromRational rational = positivize (longDiv 0 0) (numerator rational)
where
longDiv :: Integer -> Int -> (Integer -> Scientific)
longDiv !c !e 0 = scientific c e
longDiv !c !e !n
| n < d = longDiv (c * 10) (e - 1) (n * 10)
| otherwise = longDiv (c + q) e r
where
(q, r) = n `quotRem` d
d = denominator rational
instance RealFrac Scientific where
properFraction s@(Scientific c e)
| e < 0 = if dangerouslySmall c e
then (0, s)
else let (q, r) = c `quotRem` magnitude (-e)
in (fromInteger q, scientific r e)
| otherwise = (toIntegral s, 0)
{-# INLINE properFraction #-}
truncate = whenFloating $ \c e ->
if dangerouslySmall c e
then 0
else fromInteger $ c `quot` magnitude (-e)
{-# INLINE truncate #-}
round = whenFloating $ \c e ->
if dangerouslySmall c e
then 0
else let (q, r) = c `quotRem` magnitude (-e)
n = fromInteger q
m = if r < 0 then n - 1 else n + 1
f = scientific r e
in case signum $ coefficient $ abs f - 0.5 of
-1 -> n
0 -> if even n then n else m
1 -> m
_ -> error "round default defn: Bad value"
{-# INLINE round #-}
ceiling = whenFloating $ \c e ->
if dangerouslySmall c e
then if c <= 0
then 0
else 1
else let (q, r) = c `quotRem` magnitude (-e)
in fromInteger $! if r <= 0 then q else q + 1
{-# INLINE ceiling #-}
floor = whenFloating $ \c e ->
if dangerouslySmall c e
then if c < 0
then -1
else 0
else fromInteger (c `div` magnitude (-e))
{-# INLINE floor #-}
dangerouslySmall :: Integer -> Int -> Bool
dangerouslySmall c e = e < (-limit) && e < (-integerLog10' (abs c)) - 1
{-# INLINE dangerouslySmall #-}
limit :: Int
limit = maxExpt
positivize :: (Ord a, Num a, Num b) => (a -> b) -> (a -> b)
positivize f x | x < 0 = -(f (-x))
| otherwise = f x
{-# INLINE positivize #-}
whenFloating :: (Num a) => (Integer -> Int -> a) -> Scientific -> a
whenFloating f s@(Scientific c e)
| e < 0 = f c e
| otherwise = toIntegral s
{-# INLINE whenFloating #-}
toIntegral :: (Num a) => Scientific -> a
toIntegral (Scientific c e) = fromInteger c * magnitude e
{-# INLINE toIntegral #-}
maxExpt :: Int
maxExpt = 324
expts10 :: Array Int Integer
expts10 = listArray (0, maxExpt) $ 1 : 10 : go 2
where
go :: Int -> [Integer]
go !ix = xx : 10*xx : go (ix+2)
where
xx = x * x
x = expts10 ! half
#if MIN_VERSION_base(4,5,0)
half = ix `unsafeShiftR` 1
#else
half = ix `shiftR` 1
#endif
magnitude :: (Num a) => Int -> a
magnitude e | e <= maxExpt = cachedPow10 e
| otherwise = cachedPow10 maxExpt * 10 ^ (e - maxExpt)
where
cachedPow10 p = fromInteger (expts10 ! p)
{-# INLINE magnitude #-}
fromFloatDigits :: (RealFloat a) => a -> Scientific
fromFloatDigits = positivize fromNonNegRealFloat
where
fromNonNegRealFloat r = go digits 0 0
where
(digits, e) = Numeric.floatToDigits 10 r
go [] !c !n = Scientific c (e - n)
go (d:ds) !c !n = go ds (c * 10 + fromIntegral d) (n + 1)
toRealFloat :: forall a. (RealFloat a) => Scientific -> a
toRealFloat s@(Scientific c e)
| e > limit && e > hiLimit = sign (1/0)
| e < -limit && e < loLimit && e + d < loLimit = sign 0
| otherwise = realToFrac s
where
(loLimit, hiLimit) = exponentLimits (undefined :: a)
d = integerLog10' (abs c)
sign x | c < 0 = -x
| otherwise = x
exponentLimits :: forall a. (RealFloat a) => a -> (Int, Int)
exponentLimits _ = (loLimit, hiLimit)
where
loLimit = floor (fromIntegral lo * log10Radix) -
ceiling (fromIntegral digits * log10Radix)
hiLimit = ceiling (fromIntegral hi * log10Radix)
log10Radix :: Double
log10Radix = logBase 10 $ fromInteger radix
radix = floatRadix (undefined :: a)
digits = floatDigits (undefined :: a)
(lo, hi) = floatRange (undefined :: a)
floatingOrInteger :: (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger s
| base10Exponent s >= 0 = Right (toIntegral s)
| base10Exponent s' >= 0 = Right (toIntegral s')
| otherwise = Left (toRealFloat s')
where
s' = normalize s
instance Read Scientific where
readPrec = ReadPrec.lift scientificP
data SP = SP !Integer {-# UNPACK #-}!Int
scientificP :: ReadP Scientific
scientificP = do
let positive = (('+' ==) <$> ReadP.satisfy isSign) `mplus` return True
pos <- positive
let step :: Num a => a -> Int -> a
step a digit = a * 10 + fromIntegral digit
{-# INLINE step #-}
n <- foldDigits step 0
let s = SP n 0
fractional = foldDigits (\(SP a e) digit ->
SP (step a digit) (e-1)) s
SP coeff expnt <- (ReadP.satisfy (== '.') >> fractional)
`mplus` return s
let signedCoeff | pos = coeff
| otherwise = (-coeff)
eP = do posE <- positive
e <- foldDigits step 0
if posE
then return e
else return (-e)
(ReadP.satisfy isE >>
((scientific signedCoeff . (expnt +)) <$> eP)) `mplus`
return (scientific signedCoeff expnt)
foldDigits :: (a -> Int -> a) -> a -> ReadP a
foldDigits f z = ReadP.look >>= go z
where
go !a [] = return a
go !a (c:cs)
| isDecimal c = do
_ <- ReadP.get
let digit = ord c - 48
go (f a digit) cs
| otherwise = return a
isDecimal :: Char -> Bool
isDecimal c = c >= '0' && c <= '9'
{-# INLINE isDecimal #-}
isSign :: Char -> Bool
isSign c = c == '-' || c == '+'
{-# INLINE isSign #-}
isE :: Char -> Bool
isE c = c == 'e' || c == 'E'
{-# INLINE isE #-}
instance Show Scientific where
show = formatScientific Generic Nothing
formatScientific :: FPFormat
-> Maybe Int
-> Scientific
-> String
formatScientific fmt decs scntfc@(Scientific c _)
| c < 0 = '-':doFmt fmt (toDecimalDigits (-scntfc))
| otherwise = doFmt fmt (toDecimalDigits scntfc )
where
doFmt :: FPFormat -> ([Int], Int) -> String
doFmt format (is, e) =
let ds = map intToDigit 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' = show (e-1) in
case ds of
"0" -> "0.0e0"
[d] -> d : ".0e" ++ show_e'
(d:ds') -> d : '.' : ds' ++ "e" ++ show_e'
[] -> error "formatScientific/doFmt/FFExponent: []"
Just dec ->
let dec' = max dec 1 in
case is of
[0] -> '0' :'.' : take dec' (repeat '0') ++ "e0"
_ ->
let
(ei,is') = roundTo (dec'+1) is
(d:ds') = map intToDigit (if ei > 0 then init is' else is')
in
d:'.':ds' ++ 'e':show (e-1+ei)
Fixed ->
let
mk0 ls = case ls of { "" -> "0" ; _ -> ls}
in
case decs of
Nothing
| e <= 0 -> "0." ++ replicate (-e) '0' ++ ds
| otherwise ->
let
f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs
f n s "" = f (n-1) ('0':s) ""
f n s (r:rs) = f (n-1) (r:s) 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 intToDigit is')
in
mk0 ls ++ (if null rs then "" else '.':rs)
else
let
(ei,is') = roundTo dec' (replicate (-e) 0 ++ is)
d:ds' = map intToDigit (if ei > 0 then is' else 0:is')
in
d : (if null ds' then "" else '.':ds')
roundTo :: Int -> [Int] -> (Int,[Int])
roundTo d is =
case f d True is of
x@(0,_) -> x
(1,xs) -> (1, 1:xs)
_ -> error "roundTo: bad Value"
where
base = 10
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 (n-1) (even i) xs
i' = c + i
toDecimalDigits :: Scientific -> ([Int], Int)
toDecimalDigits (Scientific 0 _) = ([0], 0)
toDecimalDigits (Scientific c' e') = (is, n + e)
where
Scientific c e = normalizePositive c' e'
(is, n) = reverseAndLength $ digits c
digits :: Integer -> [Int]
digits 0 = []
digits i = fromIntegral r : digits q
where
(q, r) = i `quotRem` 10
reverseAndLength :: [a] -> ([a], Int)
reverseAndLength l = rev l [] 0
where
rev [] a !m = (a, m)
rev (x:xs) a !m = rev xs (x:a) (m+1)
normalize :: Scientific -> Scientific
normalize (Scientific c e)
| c < 0 = -(normalizePositive (-c) e)
| c > 0 = normalizePositive c e
| otherwise = Scientific 0 0
normalizePositive :: Integer -> Int -> Scientific
normalizePositive c !e = case quotRem c 10 of
(q, 0) -> normalizePositive q (e+1)
_ -> Scientific c e