scientific-0.3.0.0: src/Data/Scientific.hs
{-# LANGUAGE DeriveDataTypeable, BangPatterns, ScopedTypeVariables #-}
-- |
-- Module : Data.Scientific
-- Copyright : Bas van Dijk 2013
-- License : BSD3
-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
--
-- @Data.Scientific@ provides a space efficient and arbitrary precision
-- scientific number type.
--
-- 'Scientific' numbers are represented using
-- <http://en.wikipedia.org/wiki/Scientific_notation scientific notation>. It
-- uses an 'Integer' 'coefficient' @c@ and an 'Int' 'base10Exponent' @e@ (do
-- note that since we're using an 'Int' to represent the exponent these numbers
-- aren't truly arbitrary precision). A scientific number corresponds to the
-- 'Fractional' number: @'fromInteger' c * 10 '^^' e@.
--
-- The main application of 'Scientific' is to be used as the target of parsing
-- arbitrary precision numbers coming from an untrusted source. The advantages
-- over using 'Rational' for this are that:
--
-- * A 'Scientific' is more efficient to construct. Rational numbers need to be
-- constructed using '%' which has to compute the 'gcd' of the 'numerator' and
-- 'denominator'. Scientific numbers only need to be normalized, i.e. @10000000@
-- to @1e7@.
--
-- * 'Scientific' is safe against numbers with huge exponents. For example:
-- @1e1000000000 :: 'Rational'@ will fill up all space and crash your
-- program. Scientific works as expected:
--
-- > > read "1e1000000000" :: Scientific
-- > 1.0e1000000000
--
-- * Also, the space usage of converting scientific numbers with huge exponents
-- to @'Integral's@ (like: 'Int') or @'RealFloat's@ (like: 'Double' or 'Float')
-- will always be bounded by the target type.
--
-- This module is designed to be imported qualified:
--
-- @import Data.Scientific as Scientific@
module Data.Scientific
( Scientific
-- * Construction
, scientific
-- * Projections
, coefficient
, base10Exponent
-- * Conversions
, fromFloatDigits
, toRealFloat
-- * Pretty printing
, formatScientific
, FPFormat(..)
, toDecimalDigits
) where
----------------------------------------------------------------------
-- Imports
----------------------------------------------------------------------
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(..))
----------------------------------------------------------------------
-- Type
----------------------------------------------------------------------
-- | An arbitrary-precision number represented using
-- <http://en.wikipedia.org/wiki/Scientific_notation scientific notation>.
--
-- This type describes the set of all @'Real's@ which have a finite
-- decimal expansion.
--
-- A scientific number with 'coefficient' @c@ and 'base10Exponent' @e@
-- corresponds to the 'Fractional' number: @'fromInteger' c * 10 '^^' e@
data Scientific = Scientific
{ coefficient :: !Integer
-- ^ The coefficient of a scientific number.
, base10Exponent :: {-# UNPACK #-} !Int
-- ^ The base-10 exponent of a scientific number.
} deriving (Typeable, Data)
-- | @scientific c e@ constructs a scientific number which corresponds
-- to the 'Fractional' number: @'fromInteger' c * 10 '^^' e@.
--
-- Note that this function performs normalization, i.e. it divides out powers of
-- 10 from @c@ and adds them to @e@.
scientific :: Integer -> Int -> Scientific
scientific c !e
| c > 0 = normalize c e
| c == 0 = Scientific 0 0
| otherwise = -(normalize (-c) e)
{-# INLINE scientific #-}
normalize :: Integer -> Int -> Scientific
normalize c !e = case quotRem c 10 of
(q, 0) -> normalize q (e+1)
_ -> Scientific c e
----------------------------------------------------------------------
-- Instances
----------------------------------------------------------------------
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 #-}
-- | /WARNING:/ 'toRational' needs to compute the 'Integer' magnitude:
-- @10^e@. If applied to a huge exponent this could fill up all space
-- and crash your program!
--
-- Avoid applying 'toRational' (or 'realToFrac') to scientific numbers
-- coming from an untrusted source and use 'toRealFloat' instead. The
-- latter guards against excessive space usage.
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 #-}
-- | /WARNING:/ 'recip' and '/' will diverge when their outputs have
-- an infinite decimal expansion. 'fromRational' will diverge when the
-- input 'Rational' has an infinite decimal expansion.
instance Fractional Scientific where
recip = fromRational . recip . toRational
{-# INLINE recip #-}
fromRational rational = positivize (longDiv 0 0) (numerator rational)
where
-- Divide the numerator by the denominator using long division.
longDiv :: Integer -> Int -> (Integer -> Scientific)
longDiv !c !e 0 = scientific c e
longDiv !c !e !n
-- TODO: Use a logarithm here!
| 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
-- | The function 'properFraction' takes a Scientific number @s@
-- and returns a pair @(n,f)@ such that @s = n+f@, and:
--
-- * @n@ is an integral number with the same sign as @s@; and
--
-- * @f@ is a fraction with the same type and sign as @s@,
-- and with absolute value less than @1@.
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 = (fromInteger c * magnitude e, 0)
{-# INLINE properFraction #-}
-- | @'truncate' s@ returns the integer nearest @s@
-- between zero and @s@
truncate = whenFloating $ \c e ->
if dangerouslySmall c e
then 0
else fromInteger $ c `quot` magnitude (-e)
{-# INLINE truncate #-}
-- | @'round' s@ returns the nearest integer to @s@;
-- the even integer if @s@ is equidistant between two integers
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' s@ returns the least integer not less than @s@
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' s@ returns the greatest integer not greater than @s@
floor = whenFloating $ \c e ->
if dangerouslySmall c e
then if c < 0
then -1
else 0
else fromInteger (c `div` magnitude (-e))
{-# INLINE floor #-}
----------------------------------------------------------------------
-- Internal utilities
----------------------------------------------------------------------
-- | This function is used in the 'RealFrac' methods to guard against
-- computing a huge magnitude (-e) which could take up all space.
--
-- Think about parsing a scientific number from an untrusted
-- string. An attacker could supply 1e-1000000000. Lets say we want to
-- 'floor' that number to an 'Int'. When we naively try to floor it
-- using:
--
-- @
-- floor = whenFloating $ \c e ->
-- fromInteger (c `div` magnitude (-e))
-- @
--
-- We will compute the huge Integer: @magnitude 1000000000@. This
-- computation will quickly fill up all space and crash the program.
--
-- Note that for large /positive/ exponents there is no risk of a
-- space-leak since 'whenFloating' will compute:
--
-- @fromInteger c * magnitude e :: a@
--
-- where @a@ is the target type (Int in this example). So here the
-- space usage is bounded by the target type.
--
-- For large negative exponents we check if the exponent is smaller
-- than some limit (currently -20). In that case we know that the
-- scientific number is really small (unless the coefficient has many
-- digits) so we can immediately return -1 for negative scientific
-- numbers or 0 for positive numbers.
--
-- More precisely if @dangerouslySmall c e@ returns 'True' the
-- scientific number @s@ is guaranteed to be between:
-- @-0.1 > s < 0.1@.
--
-- Note that we avoid computing the number of decimal digits in c
-- (log10 c) if the exponent is not below the limit.
dangerouslySmall :: Integer -> Int -> Bool
dangerouslySmall c e = e < (-limit) && e < (-integerLog10' (abs c)) - 1
where
limit :: Int
limit = 20
{-# INLINE dangerouslySmall #-}
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 (Scientific c e)
| e < 0 = f c e
| otherwise = fromInteger c * magnitude e
{-# INLINE whenFloating #-}
----------------------------------------------------------------------
-- Exponentiation with a cache for the most common numbers.
----------------------------------------------------------------------
maxExpt :: Int
maxExpt = 1100
expts10 :: Array Int Integer
expts10 = listArray (0, maxExpt) $ iterate (*10) 1
-- | @magnitude e == 10 ^ e@
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 #-}
----------------------------------------------------------------------
-- Conversions
----------------------------------------------------------------------
-- | Convert a 'RealFloat' (like a 'Double' or 'Float') into a 'Scientific'
-- number.
--
-- Note that this function uses 'Numeric.floatToDigits' to compute the digits
-- and exponent of the 'RealFloat' number. Be aware that the algorithm used in
-- 'Numeric.floatToDigits' doesn't work as expected for some numbers, e.g. as
-- the 'Double' @1e23@ is converted to @9.9999999999999991611392e22@, and that
-- value is shown as @9.999999999999999e22@ rather than the shorter @1e23@; the
-- algorithm doesn't take the rounding direction for values exactly half-way
-- between two adjacent representable values into account, so if you have a
-- value with a short decimal representation exactly half-way between two
-- adjacent representable values, like @5^23*2^e@ for @e@ close to 23, the
-- algorithm doesn't know in which direction the short decimal representation
-- would be rounded and computes more digits
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)
-- | Convert a 'Scientific' number into a 'RealFloat' (like a 'Double'
-- or a 'Float').
--
-- Note that this function uses 'realToFrac'
-- (@'fromRational' . 'toRational'@) internally but it guards against
-- computing huge Integer magnitudes (@10^e@) that could fill up all
-- space and crash your program.
--
-- Always prefer 'toRealFloat' over 'realToFrac' when converting from
-- scientific numbers coming from an untrusted source.
toRealFloat :: forall a. (RealFloat a) => Scientific -> a
toRealFloat s@(Scientific c e)
| e > hiLimit = sign (1/0) -- Infinity
| e < loLimit && e + d < loLimit = sign 0
| otherwise = realToFrac s
where
hiLimit = ceiling (fromIntegral hi * log10Radix)
loLimit = floor (fromIntegral lo * log10Radix) -
ceiling (fromIntegral digits * log10Radix)
log10Radix :: Double
log10Radix = logBase 10 $ fromInteger radix
radix = floatRadix (undefined :: a)
digits = floatDigits (undefined :: a)
(lo, hi) = floatRange (undefined :: a)
d = integerLog10' (abs c)
sign x | c < 0 = -x
| otherwise = x
----------------------------------------------------------------------
-- Parsing
----------------------------------------------------------------------
instance Read Scientific where
readPrec = ReadPrec.lift scientificP
-- A strict pair
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 #-}
----------------------------------------------------------------------
-- Pretty Printing
----------------------------------------------------------------------
instance Show Scientific where
show = formatScientific Generic Nothing
-- | Like 'show' but provides rendering options.
formatScientific :: FPFormat
-> Maybe Int -- ^ Number of decimal places to render.
-> 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, []) -- Round to even when at exactly half the base
| 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
----------------------------------------------------------------------
-- | Similar to 'floatToDigits', @toDecimalDigits@ takes a
-- non-negative 'Scientific' number, and returns a list of digits and
-- a base-10 exponent. In particular, if @x>=0@, and
--
-- > toDecimalDigits x = ([d1,d2,...,dn], e)
--
-- then
--
-- (1) @n >= 1@
--
-- (2) @x = 0.d1d2...dn * (10^^e)@
--
-- (3) @0 <= di <= 9@
toDecimalDigits :: Scientific -> ([Int], Int)
toDecimalDigits (Scientific 0 _) = ([0], 0)
toDecimalDigits (Scientific c e) = (is, n + e)
where
(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)