scientific 0.3.6.2 → 0.3.9.0
raw patch · 9 files changed
Files
- bench/bench.hs +15/−0
- changelog +20/−0
- scientific.cabal +87/−73
- src/Data/ByteString/Builder/Scientific.hs +9/−22
- src/Data/Scientific.hs +173/−154
- src/Data/Text/Lazy/Builder/Scientific.hs +9/−18
- src/GHC/Integer/Compat.hs +9/−1
- src/Utils.hs +47/−0
- test/test.hs +93/−89
bench/bench.hs view
@@ -57,6 +57,21 @@ , bgroup "dangerouslyBig" $ benchToBoundedInteger dangerouslyBig , bgroup "64" $ benchToBoundedInteger 64 ]++ , bgroup "read"+ [ benchRead "123456789.123456789"+ , benchRead "12345678900000000000.12345678900000000000000000"+ , benchRead "12345678900000000000.12345678900000000000000000e1234"+ ]++ , bgroup "division"+ [ bench (show n ++ " / " ++ show d) $ nf (uncurry (/)) t+ | t@(n, d) <-+ [ (0.4 , 20.0)+ , (0.4e-100, 0.2e50)+ ] :: [(Scientific, Scientific)]+ ]+ ] where pos :: Fractional a => a
changelog view
@@ -1,3 +1,23 @@+0.3.9.0++ * Reimplement most internal functions which used to normalize inputs+ to not unnecessarily normalize them.++ * Speedup 'normalize' and 'toDecimalDigits'. Now both are practically+ linear in the coefficient size.+ Thanks to Andrzej Rybczak for reporting these issues.++0.3.7.0++ * Make division (/) on Scientifics slightly more efficient.++ * Fix the Show instance to surround negative numbers with parentheses when+ necessary.++ * Add (Template Haskell) Lift Scientific instance++ * Mark modules as Safe or Trustworthy (Safe Haskell).+ 0.3.6.2 * Due to a regression introduced in 0.3.4.14 the RealFrac methods and floatingOrInteger became vulnerable to a space blowup when
scientific.cabal view
@@ -1,6 +1,6 @@-name: scientific-version: 0.3.6.2-synopsis: Numbers represented using scientific notation+name: scientific+version: 0.3.9.0+synopsis: Numbers represented using scientific notation description: "Data.Scientific" provides the number type 'Scientific'. Scientific numbers are arbitrary precision and space efficient. They are represented using@@ -32,94 +32,107 @@ @'Integral's@ (like: 'Int') or @'RealFloat's@ (like: 'Double' or 'Float') will always be bounded by the target type. -homepage: https://github.com/basvandijk/scientific-bug-reports: https://github.com/basvandijk/scientific/issues-license: BSD3-license-file: LICENSE-author: Bas van Dijk-maintainer: Bas van Dijk <v.dijk.bas@gmail.com>-category: Data-build-type: Simple-cabal-version: >=1.10--extra-source-files:- changelog--Tested-With: GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , GHC == 8.0.2- , GHC == 8.2.2- , GHC == 8.4.1+homepage: https://github.com/basvandijk/scientific+bug-reports: https://github.com/basvandijk/scientific/issues+license: BSD3+license-file: LICENSE+author: Bas van Dijk+maintainer: Bas van Dijk <v.dijk.bas@gmail.com>+category: Data+build-type: Simple+cabal-version: >=1.10+extra-source-files: changelog+tested-with:+ GHC ==8.6.5+ || ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.8+ || ==9.4.8+ || ==9.6.6+ || ==9.8.4+ || ==9.10.3+ || ==9.12.2+ || ==9.14.1 source-repository head type: git- location: git://github.com/basvandijk/scientific.git--flag bytestring-builder- description: Depend on the bytestring-builder package for backwards compatibility.- default: False- manual: False+ location: https://github.com/basvandijk/scientific.git flag integer-simple description: Use the integer-simple package instead of integer-gmp default: False library- exposed-modules: Data.ByteString.Builder.Scientific- Data.Scientific- Data.Text.Lazy.Builder.Scientific- other-modules: GHC.Integer.Compat- Utils- other-extensions: DeriveDataTypeable, BangPatterns- ghc-options: -Wall- build-depends: base >= 4.3 && < 5- , integer-logarithms >= 1- , deepseq >= 1.3- , text >= 0.8- , hashable >= 1.1.2- , primitive >= 0.1- , containers >= 0.1- , binary >= 0.4.1+ -- main module first, so it's loaded into cabal repl.+ exposed-modules:+ Data.Scientific+ exposed-modules:+ Data.ByteString.Builder.Scientific+ Data.Text.Lazy.Builder.Scientific - if flag(bytestring-builder)- build-depends: bytestring >= 0.9 && < 0.10.4- , bytestring-builder >= 0.10.4 && < 0.11- else- build-depends: bytestring >= 0.10.4+ other-modules:+ GHC.Integer.Compat+ Utils - if flag(integer-simple)- build-depends: integer-simple+ other-extensions:+ BangPatterns+ DeriveDataTypeable+ Trustworthy++ ghc-options: -Wall+ build-depends:+ base >=4.12.0.0 && <4.23+ , binary >=0.8.6.0 && <0.9+ , bytestring >=0.10.8.2 && <0.13+ , containers >=0.6.0.1 && <0.9+ , deepseq >=1.4.4.0 && <1.6+ , hashable >=1.4.4.0 && <1.6+ , integer-logarithms >=1.0.3.1 && <1.1+ , primitive >=0.9.0.0 && <0.10+ , template-haskell >=2.14.0.0 && <2.25+ , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2++ if impl(ghc >=9.0)+ build-depends: base >=4.15++ if flag(integer-simple)+ build-depends: invalid-cabal-flag-settings <0+ else+ if flag(integer-simple)+ build-depends: integer-simple++ else build-depends: integer-gmp - hs-source-dirs: src- default-language: Haskell2010+ if impl(ghc <8)+ other-extensions: TemplateHaskell + if impl(ghc >=9.0)+ -- these flags may abort compilation with GHC-8.10+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295+ ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode++ hs-source-dirs: src+ default-language: Haskell2010+ test-suite test-scientific type: exitcode-stdio-1.0 hs-source-dirs: test main-is: test.hs default-language: Haskell2010 ghc-options: -Wall-- build-depends: scientific- , base >= 4.3 && < 5- , binary >= 0.4.1- , tasty >= 0.5- , tasty-ant-xml >= 1.0- , tasty-hunit >= 0.8- , tasty-smallcheck >= 0.2- , tasty-quickcheck >= 0.8- , smallcheck >= 1.0- , QuickCheck >= 2.5- , text >= 0.8-- if flag(bytestring-builder)- build-depends: bytestring >= 0.9 && < 0.10.4- , bytestring-builder >= 0.10.4 && < 0.11- else- build-depends: bytestring >= 0.10.4+ build-depends:+ base+ , binary+ , bytestring+ , QuickCheck >=2.14.2+ , scientific+ , tasty >=1.4.0.1+ , tasty-hunit >=0.8+ , tasty-quickcheck >=0.8+ , text benchmark bench-scientific type: exitcode-stdio-1.0@@ -127,6 +140,7 @@ main-is: bench.hs default-language: Haskell2010 ghc-options: -O2- build-depends: scientific- , base >= 4.3 && < 5- , criterion >= 0.5+ build-depends:+ base+ , criterion >=0.5+ , scientific
src/Data/ByteString/Builder/Scientific.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, Safe #-} module Data.ByteString.Builder.Scientific ( scientificBuilder@@ -17,18 +17,7 @@ import Utils (roundTo, i2d) -#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (mempty)-#endif--#if MIN_VERSION_base(4,5,0) import Data.Monoid ((<>))-#else-import Data.Monoid (Monoid, mappend)-(<>) :: Monoid a => a -> a -> a-(<>) = mappend-infixr 6 <>-#endif -- | A @ByteString@ @Builder@ which renders a scientific number to full@@ -70,11 +59,10 @@ byteStringCopy (BC8.replicate dec' '0') <> byteStringCopy "e0" _ ->- let- (ei,is') = roundTo (dec'+1) is- (d:ds') = map i2d (if ei > 0 then init is' else is')- in- char8 d <> char8 '.' <> string8 ds' <> char8 'e' <> intDec (e-1+ei)+ let (ei,is') = roundTo (dec'+1) is+ in case map i2d (if ei > 0 then init is' else is') of+ [] -> mempty+ d:ds' -> char8 d <> char8 '.' <> string8 ds' <> char8 'e' <> intDec (e-1+ei) Fixed -> let mk0 ls = case ls of { "" -> char8 '0' ; _ -> string8 ls}@@ -100,8 +88,7 @@ in mk0 ls <> (if null rs then mempty else char8 '.' <> string8 rs) else- let- (ei,is') = roundTo dec' (replicate (-e) 0 ++ is)- d:ds' = map i2d (if ei > 0 then is' else 0:is')- in- char8 d <> (if null ds' then mempty else char8 '.' <> string8 ds')+ let (ei,is') = roundTo dec' (replicate (-e) 0 ++ is)+ in case map i2d (if ei > 0 then is' else 0:is') of+ [] -> mempty+ d:ds' -> char8 d <> (if null ds' then mempty else char8 '.' <> string8 ds')
src/Data/Scientific.hs view
@@ -1,9 +1,12 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Scientific@@ -48,7 +51,7 @@ -- -- This module is designed to be imported qualified: ----- @import Data.Scientific as Scientific@+-- @import qualified Data.Scientific as Scientific@ module Data.Scientific ( Scientific @@ -91,14 +94,12 @@ , normalize ) where - ---------------------------------------------------------------------- -- Imports ---------------------------------------------------------------------- import Control.Exception (throw, ArithException(DivideByZero)) import Control.Monad (mplus)-import Control.Monad.ST (runST) import Control.DeepSeq (NFData, rnf) import Data.Binary (Binary, get, put) import Data.Char (intToDigit, ord)@@ -106,9 +107,9 @@ import Data.Hashable (Hashable(..)) import Data.Int (Int8, Int16, Int32, Int64) import qualified Data.Map as M (Map, empty, insert, lookup)+import Data.Maybe (isJust) import Data.Ratio ((%), numerator, denominator) import Data.Typeable (Typeable)-import qualified Data.Primitive.Array as Primitive import Data.Word (Word8, Word16, Word32, Word64) import Math.NumberTheory.Logarithms (integerLog10') import qualified Numeric (floatToDigits)@@ -119,26 +120,10 @@ import Text.ParserCombinators.ReadP ( ReadP ) import Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) -#if !MIN_VERSION_base(4,9,0)-import Control.Applicative ((*>))-#endif--#if !MIN_VERSION_base(4,8,0)-import Data.Functor ((<$>))-import Data.Word (Word)-import Control.Applicative ((<*>))-#endif--#if MIN_VERSION_base(4,5,0)-import Data.Bits (unsafeShiftR)-#else-import Data.Bits (shiftR)-#endif--import GHC.Integer (quotRemInteger, quotInteger)-import GHC.Integer.Compat (divInteger)-import Utils (roundTo)+import GHC.Integer.Compat (quotRemInteger, quotInteger, divInteger)+import Utils (maxExpt, roundTo, magnitude) +import Language.Haskell.TH.Syntax (Lift (..)) ---------------------------------------------------------------------- -- Type@@ -163,6 +148,20 @@ -- in 'toDecimalDigits'. -- -- Use 'normalize' to do manual normalization.+ --+ -- /WARNING:/ 'coefficient' and 'base10exponent' violate+ -- substantivity of 'Eq'.+ --+ -- >>> let x = scientific 1 2+ -- >>> let y = scientific 100 0+ -- >>> x == y+ -- True+ --+ -- but+ --+ -- >>> (coefficient x == coefficient y, base10Exponent x == base10Exponent y)+ -- (False,False)+ -- , base10Exponent :: {-# UNPACK #-} !Int -- ^ The base-10 exponent of a scientific number.@@ -173,17 +172,26 @@ scientific :: Integer -> Int -> Scientific scientific = Scientific - ---------------------------------------------------------------------- -- Instances ---------------------------------------------------------------------- +-- | @since 0.3.7.0+deriving instance Lift Scientific+ instance NFData Scientific where rnf (Scientific _ _) = () -- | A hash can be safely calculated from a @Scientific@. No magnitude @10^e@ is -- calculated so there's no risk of a blowup in space or time when hashing -- scientific numbers coming from untrusted sources.+--+-- >>> import Data.Hashable (hash)+-- >>> let x = scientific 1 2+-- >>> let y = scientific 100 0+-- >>> (x == y, hash x == hash y)+-- (True,True)+-- instance Hashable Scientific where hashWithSalt salt s = salt `hashWithSalt` c `hashWithSalt` e where@@ -200,38 +208,63 @@ -- is calculated so there's no risk of a blowup in space or time when comparing -- scientific numbers coming from untrusted sources. instance Eq Scientific where- s1 == s2 = c1 == c2 && e1 == e2- where- Scientific c1 e1 = normalize s1- Scientific c2 e2 = normalize s2+ Scientific c1 e1 == Scientific c2 e2+ -- if exponents are equal we can compare the coefficients+ | e1 == e2 = c1 == c2 + -- if numbers are normalised (i.e. no trailing zeroes in coefficient)+ -- we can also compare them directly+ | rem c1 10 /= 0+ , rem c2 10 /= 0+ = e1 == e2 && c1 == c2++ Scientific c1 e1 == Scientific c2 e2 = case compare c1 0 of+ EQ -> c2 == 0+ LT -> if c2 < 0 then eqScientific1 (-c1) e1 (-c2) e2 else False+ GT -> if c2 > 0 then eqScientific1 c1 e1 c2 e2 else False++-- | Equality comparison of positive scientific numbers.+-- The coefficients c1 and c2 are positive.+eqScientific1 :: Integer -> Int -> Integer -> Int -> Bool+eqScientific1 c1 e1 c2 e2+ | log1 /= log2 = False -- if logarithms are non-equal, numbers cannot be equal+ | otherwise = case compare e1 e2 of+ EQ -> c1 == c2+ -- an alternative is to divide by the difference,+ -- and check that remainder is zero.+ --+ -- I think it doesn't matter in practice.+ GT -> c1 * magnitude (e1 - e2) == c2+ LT -> c1 == c2 * magnitude (e2 - e1)+ where+ log1 = integerLog10' c1 + e1+ log2 = integerLog10' c2 + e2+ -- | Scientific numbers can be safely compared for ordering. No magnitude @10^e@ -- is calculated so there's no risk of a blowup in space or time when comparing -- scientific numbers coming from untrusted sources. instance Ord Scientific where- compare s1 s2- | c1 == c2 && e1 == e2 = EQ- | c1 < 0 = if c2 < 0 then cmp (-c2) e2 (-c1) e1 else LT- | c1 > 0 = if c2 > 0 then cmp c1 e1 c2 e2 else GT- | otherwise = if c2 > 0 then LT else GT- where- Scientific c1 e1 = normalize s1- Scientific c2 e2 = normalize s2-- cmp cx ex cy ey- | log10sx < log10sy = LT- | log10sx > log10sy = GT- | d < 0 = if cx <= (cy `quotInteger` magnitude (-d)) then LT else GT- | d > 0 = if cy > (cx `quotInteger` magnitude d) then LT else GT- | otherwise = if cx < cy then LT else GT- where- log10sx = log10cx + ex- log10sy = log10cy + ey+ compare (Scientific c1 e1) (Scientific c2 e2)+ | e1 == e2 = compare c1 c2 - log10cx = integerLog10' cx- log10cy = integerLog10' cy+ compare (Scientific c1 e1) (Scientific c2 e2) = case compare c1 0 of+ EQ -> compare 0 c2+ LT -> if c2 < 0 then cmpScientific (-c2) e2 (-c1) e1 else LT+ GT -> if c2 > 0 then cmpScientific c1 e1 c2 e2 else GT - d = log10cx - log10cy+-- | Order comparison of positive scientific numbers.+-- The coeffients c1 and c2 are positive.+cmpScientific :: Integer -> Int -> Integer -> Int -> Ordering+cmpScientific c1 e1 c2 e2 = case compare log1 log2 of+ GT -> GT+ LT -> LT+ EQ -> case compare e1 e2 of+ EQ -> compare c1 c2+ GT -> compare (c1 * magnitude (e1 - e2)) c2+ LT -> compare c1 (c2 * magnitude (e2 - e1))+ where+ log1 = integerLog10' c1 + e1+ log2 = integerLog10' c2 + e2 -- | /WARNING:/ '+' and '-' compute the 'Integer' magnitude: @10^e@ where @e@ is -- the difference between the @'base10Exponent's@ of the arguments. If these@@ -295,15 +328,23 @@ -- | /WARNING:/ 'recip' and '/' will throw an error when their outputs are -- <https://en.wikipedia.org/wiki/Repeating_decimal repeating decimals>. --+-- These methods also compute 'Integer' magnitudes (@10^e@). If these methods+-- are applied to arguments which have huge exponents this could fill up all+-- space and crash your program! So don't apply these methods to scientific+-- numbers coming from untrusted sources.+-- -- 'fromRational' will throw an error when the input 'Rational' is a repeating -- decimal. Consider using 'fromRationalRepetend' for these rationals which -- will detect the repetition and indicate where it starts. instance Fractional Scientific where recip = fromRational . recip . toRational- {-# INLINABLE recip #-} - x / y = fromRational $ toRational x / toRational y- {-# INLINABLE (/) #-}+ Scientific c1 e1 / Scientific c2 e2+ | d < 0 = fromRational (x / (fromInteger (magnitude (-d))))+ | otherwise = fromRational (x * fromInteger (magnitude d))+ where+ d = e1 - e2+ x = c1 % c2 fromRational rational = case mbRepetendIx of@@ -650,50 +691,7 @@ 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 = 324--expts10 :: Primitive.Array Integer-expts10 = runST $ do- ma <- Primitive.newArray maxExpt uninitialised- Primitive.writeArray ma 0 1- Primitive.writeArray ma 1 10- let go !ix- | ix == maxExpt = Primitive.unsafeFreezeArray ma- | otherwise = do- Primitive.writeArray ma ix xx- Primitive.writeArray ma (ix+1) (10*xx)- go (ix+2)- where- xx = x * x- x = Primitive.indexArray expts10 half-#if MIN_VERSION_base(4,5,0)- !half = ix `unsafeShiftR` 1-#else- !half = ix `shiftR` 1-#endif- go 2--uninitialised :: error-uninitialised = error "Data.Scientific: uninitialised element"---- | @magnitude e == 10 ^ e@-magnitude :: Num a => Int -> a-magnitude e | e < maxExpt = cachedPow10 e- | otherwise = cachedPow10 hi * 10 ^ (e - hi)- where- cachedPow10 = fromInteger . Primitive.indexArray expts10-- hi = maxExpt - 1------------------------------------------------------------------------- -- Conversions ---------------------------------------------------------------------- @@ -792,24 +790,16 @@ -- This function also guards against computing huge Integer magnitudes (@10^e@) -- that could fill up all space and crash your program. toBoundedInteger :: forall i. (Integral i, Bounded i) => Scientific -> Maybe i-toBoundedInteger s- | c == 0 = fromIntegerBounded 0- | integral = if dangerouslyBig- then Nothing- else fromIntegerBounded n- | otherwise = Nothing+toBoundedInteger (isInteger_ -> Just (Scientific c e))+ | c == 0 = fromIntegerBounded 0+ | e == 0 = fromIntegerBounded c+ | dangerouslyBig = Nothing+ | otherwise = fromIntegerBounded n where- c = coefficient s-- integral = e >= 0 || e' >= 0-- e = base10Exponent s- e' = base10Exponent s'-- s' = normalize s+ l = integerLog10' (abs c) + e - dangerouslyBig = e > limit &&- e > integerLog10' (max (abs iMinBound) (abs iMaxBound))+ -- whether logarithm of s is bigger than logarithm of source type bounds+ dangerouslyBig = l > 1 + integerLog10' (max (abs iMinBound) (abs iMaxBound)) fromIntegerBounded :: Integer -> Maybe i fromIntegerBounded i@@ -820,10 +810,12 @@ iMaxBound = toInteger (maxBound :: i) -- This should not be evaluated if the given Scientific is dangerouslyBig- -- since it could consume all space and crash the process:+ -- since it could consume all space and crash the process n :: Integer- n = toIntegral s'+ n = c * magnitude e +toBoundedInteger _ = Nothing+ {-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Int #-} {-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Int8 #-} {-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Int16 #-}@@ -853,12 +845,11 @@ -- Also see: 'isFloating' or 'isInteger'. 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+ | Just s' <- isInteger_ s+ = Right (toIntegral s') + | otherwise+ = Left (toRealFloat s) ---------------------------------------------------------------------- -- Predicates@@ -874,12 +865,31 @@ -- -- Also see: 'floatingOrInteger'. isInteger :: Scientific -> Bool-isInteger s = base10Exponent s >= 0 ||- base10Exponent s' >= 0- where- s' = normalize s+isInteger = isJust . isInteger_ +-- | Like 'isInteger', but if number is integer, return+-- 'Scientific' such that 'base10exponent' is non-negative.+-- /Note:/ this resulting scientific number might still be not 'normalise'd.+--+-- @since 0.3.9+--+isInteger_ :: Scientific -> Maybe Scientific+isInteger_ s@(Scientific c e)+ | e >= 0 = Just s+ | c == 0 = Just (Scientific c 0)+ | integerLog10' (abs c) < negate e = Nothing + -- here the magnitude (negate e) is smaller than c because of previous check.+ -- thus dividing by it once is at least as fast as normalising of whole scientific number+ -- in the worst case.+ | c < 0+ , let (q, r) = quotRem (negate c) (magnitude (negate e))+ = if r == 0 then Just (Scientific (negate q) 0) else Nothing++ | otherwise+ , let (q, r) = quotRem c (magnitude (negate e))+ = if r == 0 then Just (Scientific q 0) else Nothing+ ---------------------------------------------------------------------- -- Parsing ----------------------------------------------------------------------@@ -921,7 +931,8 @@ step a digit = a * 10 + fromIntegral digit {-# INLINE step #-} - n <- foldDigits step 0+ ds <- ReadP.munch1 isDecimal+ let n = read ds :: Integer let s = SP n 0 fractional = foldDigits (\(SP a e) digit ->@@ -979,12 +990,17 @@ -- | See 'formatScientific' if you need more control over the rendering. instance Show Scientific where- show s | coefficient s < 0 = '-':showPositive (-s)- | otherwise = showPositive s+ showsPrec d s+ | coefficient s < 0 = showParen (d > prefixMinusPrec) $+ showChar '-' . showPositive (-s)+ | otherwise = showPositive s where- showPositive :: Scientific -> String- showPositive = fmtAsGeneric . toDecimalDigits+ prefixMinusPrec :: Int+ prefixMinusPrec = 6 + showPositive :: Scientific -> ShowS+ showPositive = showString . fmtAsGeneric . toDecimalDigits+ fmtAsGeneric :: ([Int], Int) -> String fmtAsGeneric x@(_is, e) | e < 0 || e > 7 = fmtAsExponent x@@ -1054,11 +1070,10 @@ 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)+ let (ei,is') = roundTo (dec'+1) is+ in case map intToDigit (if ei > 0 then init is' else is') of+ [] -> ""+ d:ds' -> d:'.':ds' ++ 'e':show (e-1+ei) fmtAsFixedDecs :: Int -> ([Int], Int) -> String fmtAsFixedDecs dec (is, e) =@@ -1070,11 +1085,10 @@ 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')+ let (ei,is') = roundTo dec' (replicate (-e) 0 ++ is)+ in case map intToDigit (if ei > 0 then is' else 0:is') of+ [] -> ""+ d:ds' -> d : (if null ds' then "" else '.':ds') where mk0 ls = case ls of { "" -> "0" ; _ -> ls} @@ -1099,15 +1113,10 @@ toDecimalDigits (Scientific 0 _) = ([0], 0) toDecimalDigits (Scientific c' e') = case normalizePositive c' e' of- Scientific c e -> go c 0 []+ Scientific c e -> (ds, length ds + e) where- go :: Integer -> Int -> [Int] -> ([Int], Int)- go 0 !n ds = (ds, ne) where !ne = n + e- go i !n ds = case i `quotRemInteger` 10 of- (# q, r #) -> go q (n+1) (d:ds)- where- !d = fromIntegral r-+ -- show for Integer is faster than repeated quotRem _ 10+ ds = map (\d -> ord d - ord '0') (show c) ---------------------------------------------------------------------- -- Normalization@@ -1119,13 +1128,23 @@ -- You should rarely have a need for this function since scientific numbers are -- automatically normalized when pretty-printed and in 'toDecimalDigits'. normalize :: Scientific -> Scientific-normalize (Scientific c e)- | c > 0 = normalizePositive c e- | c < 0 = -(normalizePositive (-c) e)- | otherwise {- c == 0 -} = Scientific 0 0+normalize (Scientific c e) = case compare c 0 of+ GT -> normalizePositive c e+ LT -> -(normalizePositive (-c) e)+ EQ -> Scientific 0 0 normalizePositive :: Integer -> Int -> Scientific-normalizePositive !c !e = case quotRemInteger c 10 of- (# c', r #)- | r == 0 -> normalizePositive c' (e+1)- | otherwise -> Scientific c e+normalizePositive !c !e = case stripPowers c 10 of+ (c', k) -> Scientific c' (e+k)++stripPowers :: Integer -> Integer -> (Integer, Int)+stripPowers !c !p+ | r /= 0+ = (c, 0)++ -- remove factors of p*p; this speedups the normalisation by quite a bit.+ | let (c', k) = stripPowers q (p*p)+ , let (q', r') = quotRem c' p+ = if r' == 0 then (q', 2 * k + 2) else (c', 2 * k + 1)+ where+ (q, r) = quotRem c p
src/Data/Text/Lazy/Builder/Scientific.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, Safe #-} module Data.Text.Lazy.Builder.Scientific ( scientificBuilder@@ -16,14 +16,7 @@ import qualified Data.Text as T (replicate) import Utils (roundTo, i2d) -#if MIN_VERSION_base(4,5,0) import Data.Monoid ((<>))-#else-import Data.Monoid (Monoid, mappend)-(<>) :: Monoid a => a -> a -> a-(<>) = mappend-infixr 6 <>-#endif -- | A @Text@ @Builder@ which renders a scientific number to full -- precision, using standard decimal notation for arguments whose@@ -62,11 +55,10 @@ 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 (e-1+ei)+ let (ei,is') = roundTo (dec'+1) is+ in case map i2d (if ei > 0 then init is' else is') of+ [] -> mempty+ d:ds' -> singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> decimal (e-1+ei) Fixed -> let mk0 ls = case ls of { "" -> "0" ; _ -> fromString ls}@@ -90,8 +82,7 @@ in mk0 ls <> (if null rs 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' then "" else singleton '.' <> fromString ds')+ let (ei,is') = roundTo dec' (replicate (-e) 0 ++ is)+ in case map i2d (if ei > 0 then is' else 0:is') of+ [] -> mempty+ d:ds' -> singleton d <> (if null ds' then "" else singleton '.' <> fromString ds')
src/GHC/Integer/Compat.hs view
@@ -1,7 +1,14 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-} -module GHC.Integer.Compat (divInteger) where+module GHC.Integer.Compat (divInteger, quotRemInteger, quotInteger) where +import GHC.Integer (quotRemInteger, quotInteger)++#if MIN_VERSION_base(4,15,0)+import GHC.Integer (divInteger)+#else+ #ifdef MIN_VERSION_integer_simple #if MIN_VERSION_integer_simple(0,1,1)@@ -20,4 +27,5 @@ divInteger = div #endif +#endif #endif
src/Utils.hs view
@@ -1,14 +1,24 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-} module Utils ( roundTo , i2d+ , maxExpt+ , magnitude ) where import GHC.Base (Int(I#), Char(C#), chr#, ord#, (+#)) +import qualified Data.Primitive.Array as Primitive+import Control.Monad.ST (runST)++import Data.Bits (unsafeShiftR)+ roundTo :: Int -> [Int] -> (Int, [Int]) roundTo d is = case f d True is of@@ -34,3 +44,40 @@ {-# INLINE i2d #-} i2d :: Int -> Char i2d (I# i#) = C# (chr# (ord# '0'# +# i# ))++----------------------------------------------------------------------+-- Exponentiation with a cache for the most common numbers.+----------------------------------------------------------------------++-- | The same limit as in GHC.Float.+maxExpt :: Int+maxExpt = 324++expts10 :: Primitive.Array Integer+expts10 = runST $ do+ ma <- Primitive.newArray maxExpt uninitialised+ Primitive.writeArray ma 0 1+ Primitive.writeArray ma 1 10+ let go !ix+ | ix == maxExpt = Primitive.unsafeFreezeArray ma+ | otherwise = do+ Primitive.writeArray ma ix xx+ Primitive.writeArray ma (ix+1) (10*xx)+ go (ix+2)+ where+ xx = x * x+ x = Primitive.indexArray expts10 half+ !half = ix `unsafeShiftR` 1+ go 2++uninitialised :: error+uninitialised = error "Data.Scientific: uninitialised element"++-- | @magnitude e == 10 ^ e@+magnitude :: Num a => Int -> a+magnitude e | e < maxExpt = cachedPow10 e+ | otherwise = cachedPow10 hi * 10 ^ (e - hi)+ where+ cachedPow10 = fromInteger . Primitive.indexArray expts10++ hi = maxExpt - 1
test/test.hs view
@@ -1,30 +1,24 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import Control.Monad import Data.Int import Data.Word import Data.Scientific as Scientific import Test.Tasty-import Test.Tasty.Runners.AntXML-import Test.Tasty.HUnit (testCase, (@?=), Assertion, assertBool)-import qualified Test.SmallCheck as SC-import qualified Test.SmallCheck.Series as SC-import qualified Test.Tasty.SmallCheck as SC (testProperty)+import Test.Tasty.HUnit (testCase, (@?=), (@=?), Assertion, assertBool)+import Test.QuickCheck (Property, (===), (.&&.)) import qualified Test.QuickCheck as QC-import qualified Test.Tasty.QuickCheck as QC (testProperty)+import Test.Tasty.QuickCheck (testProperty) import qualified Data.Binary as Binary (encode, decode) import qualified Data.Text.Lazy as TL (unpack) import qualified Data.Text.Lazy.Builder as TLB (toLazyText)@@ -40,14 +34,58 @@ main = testMain $ testGroup "scientific" [ testGroup "DoS protection" [ testGroup "Eq"- [ testCase "1e1000000" $ assertBool "" $- (read "1e1000000" :: Scientific) == (read "1e1000000" :: Scientific)+ [ testCase "1e1000000" $ assertBool "" $ (read "1e1000000" :: Scientific) == (read "1e1000000" :: Scientific)+ , testCase "1e1000000 ineq" $ assertBool "" $ (read "1e1000000" :: Scientific) /= (read "1e1000002" :: Scientific)++ -- this also indirectly checks that 'read' is fast enough.+ , testCase "10...0" $ assertBool "" $+ (read "1e1000000" :: Scientific) ==+ (read ('1' : replicate 1000000 '0')) ] , testGroup "Ord" [ testCase "compare 1234e1000000 123e1000001" $ compare (read "1234e1000000" :: Scientific) (read "123e1000001" :: Scientific) @?= GT++ , testCase "10...0" $+ compare (read "1e1000001" :: Scientific)+ (read ('1' : replicate 1000000 '0' ++ "0"))+ @?= EQ+ , testCase "1...1" $+ compare (read "1e1000001" :: Scientific)+ (read ('1' : replicate 1000000 '0' ++ "1"))+ @?= LT ] + , testGroup "isInteger"+ [ testCase "1e1000000" $ True @=? isInteger (read "1e1000000" :: Scientific)+ , testCase "10...0e-1" $ True @=? isInteger (read $ '1' : replicate 1000000 '0' ++ "e-1" :: Scientific)+ , testCase "10...0e-10...0" $ True @=? isInteger (read $ '1' : replicate 1000000 '0' ++ "e-1000000" :: Scientific)+ , testCase "10...0e-20...0" $ False @=? isInteger (read $ '1' : replicate 1000000 '0' ++ "e-2000000" :: Scientific)+ ]++ , testGroup "toBoundedInteger"+ [ testCase "1e1000000" $ Nothing @=? toBoundedInteger @Int (read "1e1000000") + , testCase "10...0e-1" $ Nothing @=? toBoundedInteger @Int (read $ '1' : replicate 1000000 '0' ++ "e-1")+ ]++ , testGroup "floatingOrInteger"+ [ testCase "1e1000000" $ Right (10 ^ (1000000 :: Int) :: Integer) @=? floatingOrInteger @Double @Integer (read "1e1000000") + , testCase "10...0e-1" $ Right (10 ^ ( 999999 :: Int) :: Integer) @=? floatingOrInteger @Double @Integer (read $ '1' : replicate 1000000 '0' ++ "e-1")+ ]++ , testGroup "normalize"+ [ testCase "1e1000000" $ True @=? isInteger (normalize (read "1e1000000" :: Scientific))+ , testCase "10...0e-1" $ True @=? isInteger (normalize (read $ '1' : replicate 1000000 '0' ++ "e-1" :: Scientific))+ , testCase "10...0e-10...0" $ True @=? isInteger (normalize (read $ '1' : replicate 1000000 '0' ++ "e-1000000" :: Scientific))+ , testCase "10...0e-20...0" $ False @=? isInteger (normalize (read $ '1' : replicate 1000000 '0' ++ "e-2000000" :: Scientific))+ ]++ , testGroup "toDecimalDigits"+ [ testCase "9...9" $ do+ let (ds, n) = toDecimalDigits (read $ replicate 1000000 '9')+ (1000000,1000000) @=? (length ds, n)+ ]+ , testGroup "RealFrac" [ testGroup "floor" [ testCase "1e1000000" $ (floor (read "1e1000000" :: Scientific) :: Int) @?= 0@@ -82,20 +120,15 @@ (toRealFloat (read "1e1000000" :: Scientific) :: Double) , testCase "1e-1000000" $ (toRealFloat (read "1e-1000000" :: Scientific) :: Double) @?= 0 ]- , testGroup "toBoundedInteger"- [ testCase "1e1000000" $ (toBoundedInteger (read "1e1000000" :: Scientific) :: Maybe Int) @?= Nothing- ] ] - , smallQuick "normalization"- (SC.over normalizedScientificSeries $ \s ->- s /= 0 SC.==> abs (Scientific.coefficient s) `mod` 10 /= 0)+ , testProperty "normalization" (QC.forAll normalizedScientificGen $ \s -> s /= 0 QC.==> abs (Scientific.coefficient s) `mod` 10 /= 0) , testGroup "Binary" [ testProperty "decode . encode == id" $ \s ->- Binary.decode (Binary.encode s) === s+ Binary.decode (Binary.encode s) === theSci s ] , testGroup "Parsing"@@ -113,15 +146,16 @@ ] , testGroup "Formatting"- [ testProperty "read . show == id" $ \s -> read (show s) === s+ [ testProperty "read . show == id" $ \s -> read (show s) === theSci s+ , testCase "show (Just 1)" $ testShow (Just 1) "Just 1.0"+ , testCase "show (Just 0)" $ testShow (Just 0) "Just 0.0"+ , testCase "show (Just (-1))" $ testShow (Just (-1)) "Just (-1.0)" , testGroup "toDecimalDigits"- [ smallQuick "laws"- (SC.over nonNegativeScientificSeries toDecimalDigits_laws)+ [ testProperty "laws" (QC.forAll nonNegativeScientificGen toDecimalDigits_laws) - , smallQuick "== Numeric.floatToDigits"- (toDecimalDigits_eq_floatToDigits . SC.getNonNegative)+ , testProperty "== Numeric.floatToDigits" (toDecimalDigits_eq_floatToDigits . QC.getNonNegative) ] @@ -159,7 +193,7 @@ , testGroup "Num" [ testGroup "Equal to Rational"- [ testProperty "fromInteger" $ \i -> fromInteger i === fromRational (fromInteger i)+ [ testProperty "fromInteger" $ \i -> fromInteger i === theSci (fromRational (fromInteger i)) , testProperty "+" $ bin (+) , testProperty "-" $ bin (-) , testProperty "*" $ bin (*)@@ -168,27 +202,26 @@ , testProperty "signum" $ unary signum ] - , testProperty "0 identity of +" $ \a -> a + 0 === a- , testProperty "1 identity of *" $ \a -> 1 * a === a- , testProperty "0 identity of *" $ \a -> 0 * a === 0+ , testProperty "0 identity of +" $ \a -> a + 0 === theSci a+ , testProperty "1 identity of *" $ \a -> 1 * a === theSci a+ , testProperty "0 identity of *" $ \a -> 0 * a === theSci 0 - , testProperty "associativity of +" $ \a b c -> a + (b + c) === (a + b) + c- , testProperty "commutativity of +" $ \a b -> a + b === b + a- , testProperty "distributivity of * over +" $ \a b c -> a * (b + c) === a * b + a * c+ , testProperty "associativity of +" $ \a b c -> a + (b + c) === (a + b) + theSci c+ , testProperty "commutativity of +" $ \a b -> a + b === b + theSci a+ , testProperty "distributivity of * over +" $ \a b c -> a * (b + c) === a * b + a * theSci c - , testProperty "subtracting the addition" $ \x y -> x + y - y === x+ , testProperty "subtracting the addition" $ \x y -> x + y - y === theSci x - , testProperty "+ and negate" $ \x -> x + negate x === 0- , testProperty "- and negate" $ \x -> x - negate x === x + x+ , testProperty "+ and negate" $ \x -> theSci x + negate x === 0+ , testProperty "- and negate" $ \x -> theSci x - negate x === x + x - , smallQuick "abs . negate == id"- (SC.over nonNegativeScientificSeries $ \x -> abs (negate x) === x)- (QC.forAll nonNegativeScientificGen $ \x -> abs (negate x) === x)+ , testProperty "abs . negate == id"+ (QC.forAll nonNegativeScientificGen $ \x -> abs (negate x) === theSci x) ] , testGroup "Real" [ testProperty "fromRational . toRational == id" $ \x ->- (fromRational . toRational) x === x+ (fromRational . toRational) x === theSci x ] , testGroup "RealFrac"@@ -196,7 +229,7 @@ [ testProperty "properFraction" $ \x -> let (n1::Integer, f1::Scientific) = properFraction x (n2::Integer, f2::Rational) = properFraction (toRational x)- in (n1 == n2) && (f1 == fromRational f2)+ in (n1 === n2) .&&. (f1 === fromRational f2) , testProperty "round" $ \(x::Scientific) -> (round x :: Integer) == round (toRational x)@@ -240,15 +273,15 @@ s' = normalize s , testProperty "Integer == Right" $ \(i::Integer) -> (floatingOrInteger (fromInteger i) :: Either Double Integer) == Right i- , smallQuick "Double == Left"- (\(d::Double) -> genericIsFloating d SC.==>- (floatingOrInteger (realToFrac d) :: Either Double Integer) == Left d)+ , testProperty "Double == Left" (\(d::Double) -> genericIsFloating d QC.==> (floatingOrInteger (realToFrac d) :: Either Double Integer) == Left d) ] , testGroup "toBoundedInteger" [ testGroup "correct conversion"- [ testProperty "Int64" $ toBoundedIntegerConversion (undefined :: Int64)+ + [ testCase "100e-2" $ toBoundedInteger @Int (read "100e-2") @?= Just 1+ , testProperty "Int64" $ toBoundedIntegerConversion (undefined :: Int64) , testProperty "Word64" $ toBoundedIntegerConversion (undefined :: Word64) , testProperty "NegativeNum" $ toBoundedIntegerConversion (undefined :: NegativeInt) ]@@ -278,8 +311,12 @@ ] ] +-- used as type annotation+theSci :: Scientific -> Scientific+theSci = id+ testMain :: TestTree -> IO ()-testMain = defaultMainWithIngredients (antXMLRunner:defaultIngredients)+testMain = defaultMainWithIngredients defaultIngredients testReads :: String -> [(Scientific, String)] -> Assertion testReads inp out = reads inp @?= out@@ -287,6 +324,9 @@ testRead :: String -> Scientific -> Assertion testRead inp out = read inp @?= out +testShow :: Maybe Scientific -> String -> Assertion+testShow inp out = show inp @?= out+ testScientificP :: String -> [(Scientific, String)] -> Assertion testScientificP inp out = readP_to_S Scientific.scientificP inp @?= out @@ -301,7 +341,6 @@ conversionsProperties :: forall realFloat. ( RealFloat realFloat , QC.Arbitrary realFloat- , SC.Serial IO realFloat , Show realFloat ) => realFloat -> [TestTree]@@ -337,23 +376,6 @@ s < fromIntegral (minBound :: i) || s > fromIntegral (maxBound :: i) -testProperty :: (SC.Testable IO test, QC.Testable test)- => TestName -> test -> TestTree-testProperty n test = smallQuick n test test--smallQuick :: (SC.Testable IO smallCheck, QC.Testable quickCheck)- => TestName -> smallCheck -> quickCheck -> TestTree-smallQuick n sc qc = testGroup n- [ SC.testProperty "smallcheck" sc- , QC.testProperty "quickcheck" qc- ]---- | ('==') specialized to 'Scientific' so we don't have to put type--- signatures everywhere.-(===) :: Scientific -> Scientific -> Bool-(===) = (==)-infix 4 ===- bin :: (forall a. Num a => a -> a -> a) -> Scientific -> Scientific -> Bool bin op a b = toRational (a `op` b) == toRational a `op` toRational b @@ -377,10 +399,10 @@ in rule1 && rule2 && rule3 && rule4 -properFraction_laws :: Scientific -> Bool-properFraction_laws x = fromInteger n + f === x &&- (positive n == posX || n == 0) &&- (positive f == posX || f == 0) &&+properFraction_laws :: Scientific -> Property+properFraction_laws x = fromInteger n + f === x .&&.+ (positive n == posX || n == 0) .&&.+ (positive f == posX || f == 0) .&&. abs f < 1 where posX = positive x@@ -418,23 +440,6 @@ maxBound = -10 ------------------------------------------------------------------------- SmallCheck instances-------------------------------------------------------------------------instance (Monad m) => SC.Serial m Scientific where- series = scientifics--scientifics :: (Monad m) => SC.Series m Scientific-scientifics = SC.cons2 scientific--nonNegativeScientificSeries :: (Monad m) => SC.Series m Scientific-nonNegativeScientificSeries = liftM SC.getNonNegative SC.series--normalizedScientificSeries :: (Monad m) => SC.Series m Scientific-normalizedScientificSeries = liftM Scientific.normalize SC.series------------------------------------------------------------------------- -- QuickCheck instances ---------------------------------------------------------------------- @@ -446,10 +451,13 @@ <*> bigIntGen) , (10, scientific <$> pure 0 <*> bigIntGen)+ , (10, (\c e' e -> scientific (c * 10 ^ min 10 (abs e')) e) <$> QC.arbitrary <*> intGen <*> intGen) ] - shrink s = zipWith scientific (QC.shrink $ Scientific.coefficient s)- (QC.shrink $ Scientific.base10Exponent s)+ shrink s = + [ scientific c e+ | (c, e) <- QC.shrink (Scientific.coefficient s, Scientific.base10Exponent s)+ ] nonNegativeScientificGen :: QC.Gen Scientific nonNegativeScientificGen =@@ -463,8 +471,4 @@ bigIntGen = QC.sized $ \size -> QC.resize (size * 1000) intGen intGen :: QC.Gen Int-#if MIN_VERSION_QuickCheck(2,7,0) intGen = QC.arbitrary-#else-intGen = QC.sized $ \n -> QC.choose (-n, n)-#endif