diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,70 @@ +0.3.2.0 + + * Add the floatingOrInteger function + * Fix build on GHC-7.0.4 + * More efficient and better behaving magnitude computation + * Lower the number of cached magnitudes to 324 (same as GHC.Float) + +0.3.1.0 + + * Don't normalize on construction but do it when pretty-printing + instead. Also provide a manual normalize function. + * Improve efficiency of toRealFloat + * Added note about caching magnitudes + * Dropped dependency on arithmoi + * Make benchmark easier to build + * Add junit XML output support (for Jenkins) + +0.3.0.2 + + * Lower the minimal QuickCheck version. + * Make sure sized exponents are generated in the QuickCheck tests. + +0.3.0.1 + + * Fix build for bytestring-0.10.0.* + +0.3.0.0 + + * Fix a DoS vulnerability that allowed an attacker to crash the + process by sending a scientific with a huge exponent like + 1e1000000000. + * Fix various RealFrac methods. + * Cache some powers of 10 to speed up the magnitude computation. + * Normalize scientific numbers on construction. + * Move the Text Builder to its own module & + provide a ByteString builder + * Added more documentation + +0.2.0.2 + + * Widen the dreaded pointlessly tight upper bounds + +0.2.0.1 + + * Support the latest versions of smallcheck and tasty + +0.2.0.0 + + * added deriving data + +0.1.0.1 + + * Loosen upper bounds on package versions + +0.1.0.0 + + * Fixed bugs & Changed API + +0.0.0.2 + + * Support building the library on GHC >= 7.0.1 + +0.0.0.1 + + * Simplification in the Show instance + * Optimization in fromRealFloat + +0.0.0.0 + + * Initial commit diff --git a/scientific.cabal b/scientific.cabal --- a/scientific.cabal +++ b/scientific.cabal @@ -1,5 +1,5 @@ name: scientific -version: 0.3.1.0 +version: 0.3.2.0 synopsis: Numbers represented using scientific notation description: @Data.Scientific@ provides a space efficient and arbitrary precision @@ -40,6 +40,9 @@ category: Data build-type: Simple cabal-version: >=1.10 + +extra-source-files: + changelog source-repository head type: git diff --git a/src/Data/Scientific.hs b/src/Data/Scientific.hs --- a/src/Data/Scientific.hs +++ b/src/Data/Scientific.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable, BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Scientific @@ -35,11 +38,6 @@ -- to @'Integral's@ (like: 'Int') or @'RealFloat's@ (like: 'Double' or 'Float') -- will always be bounded by the target type. -- --- Note that, in order to do fast magnitude computations (@10^e@), this module --- computes the first 1100 powers of 10 and stores them in a top-level --- array. This means that the first magnitude computation (used in 'realToFrac' --- among others) is slower but subsequent computations should be O(1). --- -- This module is designed to be imported qualified: -- -- @import Data.Scientific as Scientific@ @@ -56,6 +54,7 @@ -- * Conversions , fromFloatDigits , toRealFloat + , floatingOrInteger -- * Pretty printing , formatScientific @@ -90,7 +89,13 @@ 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 + ---------------------------------------------------------------------- -- Type ---------------------------------------------------------------------- @@ -245,7 +250,7 @@ then (0, s) else let (q, r) = c `quotRem` magnitude (-e) in (fromInteger q, scientific r e) - | otherwise = (fromInteger c * magnitude e, 0) + | otherwise = (toIntegral s, 0) {-# INLINE properFraction #-} -- | @'truncate' s@ returns the integer nearest @s@ @@ -345,22 +350,41 @@ {-# INLINE positivize #-} whenFloating :: (Num a) => (Integer -> Int -> a) -> Scientific -> a -whenFloating f (Scientific c e) +whenFloating f s@(Scientific c e) | e < 0 = f c e - | otherwise = fromInteger c * magnitude e + | otherwise = toIntegral s {-# INLINE whenFloating #-} +-- | Precondition: the 'Scientific' @s@ needs to be an integer: +-- @base10Exponent (normalize s) >= 0@ +toIntegral :: (Num a) => Scientific -> a +toIntegral (Scientific c e) = fromInteger c * magnitude e +{-# INLINE toIntegral #-} + ---------------------------------------------------------------------- -- Exponentiation with a cache for the most common numbers. ---------------------------------------------------------------------- +-- | The same limit as in GHC.Float. maxExpt :: Int -maxExpt = 1100 +maxExpt = 324 expts10 :: Array Int Integer -expts10 = listArray (0, maxExpt) $ iterate (*10) 1 +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 e == 10 ^ e@ magnitude :: (Num a) => Int -> a magnitude e | e <= maxExpt = cachedPow10 e @@ -434,6 +458,17 @@ radix = floatRadix (undefined :: a) digits = floatDigits (undefined :: a) (lo, hi) = floatRange (undefined :: a) + +-- | @floatingOrInteger@ determines if the scientific is floating point +-- or integer. In case it's floating-point the scientific is converted +-- to the desired 'RealFloat' using 'toRealFloat'. +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 ---------------------------------------------------------------------- diff --git a/src/Math/NumberTheory/Logarithms.hs b/src/Math/NumberTheory/Logarithms.hs --- a/src/Math/NumberTheory/Logarithms.hs +++ b/src/Math/NumberTheory/Logarithms.hs @@ -1,13 +1,115 @@ -{-# LANGUAGE CPP, MagicHash #-} +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} --- | Integer logarithm, copied from @arithmoi@ +-- | Integer logarithm, copied from Daniel Fischer's @arithmoi@ module Math.NumberTheory.Logarithms ( integerLog10' ) where import GHC.Base -#if __GLASGOW_HASKELL__ < 705 -import GHC.Word -#endif + +#if __GLASGOW_HASKELL__ >= 702 import GHC.Integer.Logarithms +#else +#include "MachDeps.h" + +import GHC.Integer.GMP.Internals + +#if (WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64) +#error Only word sizes 32 and 64 are supported. +#endif + + +#if WORD_SIZE_IN_BITS == 32 + +#define WSHIFT 5 +#define MMASK 31 + +#else + +#define WSHIFT 6 +#define MMASK 63 + +#endif + +-- | Calculate the integer base 2 logarithm of an 'Integer'. +-- The calculation is much more efficient than for the general case. +-- +-- The argument must be strictly positive, that condition is /not/ checked. +integerLog2# :: Integer -> Int# +integerLog2# (S# i) = wordLog2# (int2Word# i) +integerLog2# (J# s ba) = check (s -# 1#) + where + check i = case indexWordArray# ba i of + 0## -> check (i -# 1#) + w -> wordLog2# w +# (uncheckedIShiftL# i WSHIFT#) + +-- | This function calculates the integer base 2 logarithm of a 'Word#'. +-- @'wordLog2#' 0## = -1#@. +{-# INLINE wordLog2# #-} +wordLog2# :: Word# -> Int# +wordLog2# w = + case leadingZeros of + BA lz -> + let zeros u = indexInt8Array# lz (word2Int# u) in +#if WORD_SIZE_IN_BITS == 64 + case uncheckedShiftRL# w 56# of + a -> + if a `neWord#` 0## + then 64# -# zeros a + else + case uncheckedShiftRL# w 48# of + b -> + if b `neWord#` 0## + then 56# -# zeros b + else + case uncheckedShiftRL# w 40# of + c -> + if c `neWord#` 0## + then 48# -# zeros c + else + case uncheckedShiftRL# w 32# of + d -> + if d `neWord#` 0## + then 40# -# zeros d + else +#endif + case uncheckedShiftRL# w 24# of + e -> + if e `neWord#` 0## + then 32# -# zeros e + else + case uncheckedShiftRL# w 16# of + f -> + if f `neWord#` 0## + then 24# -# zeros f + else + case uncheckedShiftRL# w 8# of + g -> + if g `neWord#` 0## + then 16# -# zeros g + else 8# -# zeros w + +-- Lookup table +data BA = BA ByteArray# + +leadingZeros :: BA +leadingZeros = + let mkArr s = + case newByteArray# 256# s of + (# s1, mba #) -> + case writeInt8Array# mba 0# 9# s1 of + s2 -> + let fillA lim val idx st = + if idx ==# 256# + then st + else if idx <# lim + then case writeInt8Array# mba idx val st of + nx -> fillA lim val (idx +# 1#) nx + else fillA (2# *# lim) (val -# 1#) idx st + in case fillA 2# 8# 1# s2 of + s3 -> case unsafeFreezeByteArray# mba s3 of + (# _, ba #) -> ba + in case mkArr realWorld# of + b -> BA b +#endif -- | Only defined for positive inputs! integerLog10' :: Integer -> Int diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -131,11 +131,31 @@ , testGroup "Conversions" [ testGroup "Float" $ conversionsProperties (undefined :: Float) , testGroup "Double" $ conversionsProperties (undefined :: Double) + + , testGroup "floatingOrInteger" + [ testProperty "correct conversion" $ \s -> + case floatingOrInteger s :: Either Double Int of + Left d -> d == toRealFloat s + Right i -> i == fromInteger (coefficient s') * 10^(base10Exponent s') + where + s' = normalize s + , testProperty "Integer == Right" $ \(i::Integer) -> + (floatingOrInteger (fromInteger i) :: Either Double Integer) == Right i + , smallQuick "Double == Left" + (\(d::Double) -> isFloating d SC.==> + (floatingOrInteger (realToFrac d) :: Either Double Integer) == Left d) + (\(d::Double) -> isFloating d QC.==> + (floatingOrInteger (realToFrac d) :: Either Double Integer) == Left d) + ] ] ] testMain :: TestTree -> IO () testMain = defaultMainWithIngredients (antXMLRunner:defaultIngredients) + +isFloating :: Double -> Bool +isFloating 0 = False +isFloating d = fromInteger (floor d :: Integer) /= d conversionsProperties :: forall realFloat. ( RealFloat realFloat