diff --git a/bench/bench.hs b/bench/bench.hs --- a/bench/bench.hs +++ b/bench/bench.hs @@ -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 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,78 @@ +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 + applied to scientifics with huge exponents. This has now been + fixed again. + +0.3.6.1 + * Fix build on GHC < 8. + +0.3.6.0 + * Make the methods of the Hashable, Eq and Ord instances safe to + use when applied to scientific numbers coming from untrusted + sources. Previously these methods first converted their arguments + to Rational before applying the operation. This is unsafe because + converting a Scientific to a Rational could fill up all space and + crash your program when the Scientific has a huge base10Exponent. + + Do note that the hash computation of the Hashable Scientific + instance has been changed because of this improvement! + + Thanks to Tom Sydney Kerckhove (@NorfairKing) for pushing me to + fix this. + + * fromRational :: Rational -> Scientific now throws an error + instead of diverging when applied to a repeating decimal. This + does mean it will consume space linear in the number of digits of + the resulting scientific. This makes "fromRational" and the other + Fractional methods "recip" and "/" a bit safer to use. + + * To get the old unsafe but more efficient behaviour the following + function was added: unsafeFromRational :: Rational -> Scientific. + + * Add alternatives for fromRationalRepetend: + + fromRationalRepetendLimited + :: Int -- ^ limit + -> Rational + -> Either (Scientific, Rational) + (Scientific, Maybe Int) + + and: + + fromRationalRepetendUnlimited + :: Rational -> (Scientific, Maybe Int) + + Thanks to Ian Jeffries (@seagreen) for the idea. + +0.3.5.3 + * Dropped upper version bounds of dependencies + because it's to much work to maintain. + +0.3.5.2 + * Remove unused ghc-prim dependency. + * Added unit tests for read and scientificP + 0.3.5.1 * Replace use of Vector from vector with Array from primitive. diff --git a/scientific.cabal b/scientific.cabal --- a/scientific.cabal +++ b/scientific.cabal @@ -1,8 +1,8 @@ -name: scientific -version: 0.3.5.1 -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 + "Data.Scientific" provides the number type 'Scientific'. Scientific numbers are arbitrary precision and space efficient. They are represented using . The implementation uses a coefficient @c :: 'Integer'@ and a base-10 exponent @@ -25,95 +25,114 @@ @1e1000000000 :: 'Rational'@ will fill up all space and crash your program. Scientific works as expected: . - > > read "1e1000000000" :: Scientific - > 1.0e1000000000 + >>> 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. -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 -category: Data -build-type: Simple -cabal-version: >=1.10 - -extra-source-files: - changelog +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 +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 && < 4.11 - , ghc-prim - , integer-logarithms >= 1 && <1.1 - , deepseq >= 1.3 && < 1.5 - , text >= 0.8 && < 1.3 - , hashable >= 1.1.2 && < 1.3 - , primitive >= 0.1 && < 0.7 - , containers >= 0.1 && < 0.6 - , binary >= 0.4.1 && < 0.9 + -- 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 && < 0.11 + 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 && < 4.11 - , binary >= 0.4.1 && < 0.9 - , tasty >= 0.5 && < 0.12 - , tasty-ant-xml >= 1.0 && < 1.2 - , tasty-hunit >= 0.8 && < 0.10 - , tasty-smallcheck >= 0.2 && < 0.9 - , tasty-quickcheck >= 0.8 && < 0.10 - , smallcheck >= 1.0 && < 1.2 - , QuickCheck >= 2.5 && < 2.11 - , text >= 0.8 && < 1.3 - - 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 && < 0.11 + 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 @@ -121,6 +140,7 @@ main-is: bench.hs default-language: Haskell2010 ghc-options: -O2 - build-depends: scientific - , base >= 4.3 && < 4.11 - , criterion >= 0.5 && < 1.3 + build-depends: + base + , criterion >=0.5 + , scientific diff --git a/src/Data/ByteString/Builder/Scientific.hs b/src/Data/ByteString/Builder/Scientific.hs --- a/src/Data/ByteString/Builder/Scientific.hs +++ b/src/Data/ByteString/Builder/Scientific.hs @@ -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') diff --git a/src/Data/Scientific.hs b/src/Data/Scientific.hs --- a/src/Data/Scientific.hs +++ b/src/Data/Scientific.hs @@ -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 @@ -22,6 +25,11 @@ -- aren't truly arbitrary precision. I intend to change the type of the exponent -- to 'Integer' in a future release. -- +-- /WARNING:/ Although @Scientific@ has instances for all numeric classes the +-- methods should be used with caution when applied to scientific numbers coming +-- from untrusted sources. See the warnings of the instances belonging to +-- 'Scientific'. +-- -- 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: @@ -41,16 +49,9 @@ -- to @'Integral's@ (like: 'Int') or @'RealFloat's@ (like: 'Double' or 'Float') -- will always be bounded by the target type. -- --- /WARNING:/ Although @Scientific@ is an instance of 'Fractional', the methods --- are only partially defined! Specifically 'recip' and '/' will diverge --- (i.e. loop and consume all space) when their outputs have an infinite decimal --- expansion. 'fromRational' will diverge when the input 'Rational' has an --- infinite decimal expansion. Consider using 'fromRationalRepetend' for these --- rationals which will detect the repetition and indicate where it starts. --- -- This module is designed to be imported qualified: -- --- @import Data.Scientific as Scientific@ +-- @import qualified Data.Scientific as Scientific@ module Data.Scientific ( Scientific @@ -66,8 +67,14 @@ , isInteger -- * Conversions + -- ** Rational + , unsafeFromRational , fromRationalRepetend + , fromRationalRepetendLimited + , fromRationalRepetendUnlimited , toRationalRepetend + + -- ** Floating & integer , floatingOrInteger , toRealFloat , toBoundedRealFloat @@ -87,25 +94,22 @@ , 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) import Data.Data (Data) -import Data.Function (on) 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) @@ -116,22 +120,10 @@ import Text.ParserCombinators.ReadP ( ReadP ) import Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) -#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 @@ -156,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. @@ -166,50 +172,105 @@ 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 = hashWithSalt salt . toRational + hashWithSalt salt s = salt `hashWithSalt` c `hashWithSalt` e + where + Scientific c e = normalize s +-- | Note that in the future I intend to change the type of the 'base10Exponent' +-- from @Int@ to @Integer@. To be forward compatible the @Binary@ instance +-- already encodes the exponent as 'Integer'. instance Binary Scientific where - put (Scientific c e) = do - put c - -- In the future I intend to change the type of the base10Exponent e from - -- Int to Integer. To support backward compatability I already convert e - -- to Integer here: - put $ toInteger e - + put (Scientific c e) = put c *> put (toInteger e) get = Scientific <$> get <*> (fromInteger <$> get) +-- | Scientific numbers can be safely compared for equality. 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 Eq Scientific where - (==) = (==) `on` toRational - {-# INLINABLE (==) #-} + Scientific c1 e1 == Scientific c2 e2 + -- if exponents are equal we can compare the coefficients + | e1 == e2 = c1 == c2 - (/=) = (/=) `on` toRational - {-# INLINABLE (/=) #-} + -- 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 -instance Ord Scientific where - (<) = (<) `on` toRational - {-# INLINABLE (<) #-} + 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 - (<=) = (<=) `on` toRational - {-# INLINABLE (<=) #-} +-- | 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 - (>) = (>) `on` toRational - {-# INLINABLE (>) #-} +-- | 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 (Scientific c1 e1) (Scientific c2 e2) + | e1 == e2 = compare c1 c2 - (>=) = (>=) `on` toRational - {-# INLINABLE (>=) #-} + 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 - compare = compare `on` toRational - {-# INLINABLE compare #-} +-- | 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 +-- 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. The other methods can be used safely. instance Num Scientific where Scientific c1 e1 + Scientific c2 e2 | e1 < e2 = Scientific (c1 + c2*l) e1 @@ -264,36 +325,66 @@ "realToFrac_toRealFloat_Float" realToFrac = toRealFloat :: Scientific -> Float #-} --- | /WARNING:/ 'recip' and '/' will diverge (i.e. loop and consume all space) --- when their outputs are . +-- | /WARNING:/ 'recip' and '/' will throw an error when their outputs are +-- . -- --- 'fromRational' will diverge when the input 'Rational' is a repeating decimal. --- Consider using 'fromRationalRepetend' for these rationals which will detect --- the repetition and indicate where it starts. +-- 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 - | d == 0 = throw DivideByZero - | otherwise = positivize (longDiv 0 0) (numerator rational) + fromRational rational = + case mbRepetendIx of + Nothing -> s + Just _ix -> error $ + "fromRational has been applied to a repeating decimal " ++ + "which can't be represented as a Scientific! " ++ + "It's better to avoid performing fractional operations on Scientifics " ++ + "and convert them to other fractional types like Double as early as possible." 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 = case n `quotRemInteger` d of - (#q, r#) -> longDiv (c + q) e r + (s, mbRepetendIx) = fromRationalRepetendUnlimited rational - d = denominator rational +-- | Although 'fromRational' is unsafe because it will throw errors on +-- , +-- @unsafeFromRational@ is even more unsafe because it will diverge instead (i.e +-- loop and consume all space). Though it will be more efficient because it +-- doesn't need to consume space linear in the number of digits in the resulting +-- scientific to detect the repetition. +-- +-- Consider using 'fromRationalRepetend' for these rationals which will detect +-- the repetition and indicate where it starts. +unsafeFromRational :: Rational -> Scientific +unsafeFromRational rational + | d == 0 = throw DivideByZero + | otherwise = 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 = case n `quotRemInteger` d of + (#q, r#) -> longDiv (c + q) e r --- | Like 'fromRational', this function converts a `Rational` to a `Scientific` --- but instead of diverging (i.e loop and consume all space) on + d = denominator rational + +-- | Like 'fromRational' and 'unsafeFromRational', this function converts a +-- `Rational` to a `Scientific` but instead of failing or diverging (i.e loop +-- and consume all space) on -- -- it detects the repeating part, the /repetend/, and returns where it starts. -- @@ -335,7 +426,18 @@ -> Rational -> Either (Scientific, Rational) (Scientific, Maybe Int) -fromRationalRepetend mbLimit rational +fromRationalRepetend mbLimit rational = + case mbLimit of + Nothing -> Right $ fromRationalRepetendUnlimited rational + Just l -> fromRationalRepetendLimited l rational + +-- | Like 'fromRationalRepetend' but always accepts a limit. +fromRationalRepetendLimited + :: Int -- ^ limit + -> Rational + -> Either (Scientific, Rational) + (Scientific, Maybe Int) +fromRationalRepetendLimited l rational | d == 0 = throw DivideByZero | num < 0 = case longDiv (-num) of Left (s, r) -> Left (-s, -r) @@ -345,11 +447,38 @@ num = numerator rational longDiv :: Integer -> Either (Scientific, Rational) (Scientific, Maybe Int) - longDiv n = case mbLimit of - Nothing -> Right $ longDivNoLimit 0 0 M.empty n - Just l -> longDivWithLimit (-l) n + longDiv = longDivWithLimit 0 0 M.empty - -- Divide the numerator by the denominator using long division. + longDivWithLimit + :: Integer + -> Int + -> M.Map Integer Int + -> (Integer -> Either (Scientific, Rational) + (Scientific, Maybe Int)) + longDivWithLimit !c !e _ns 0 = Right (Scientific c e, Nothing) + longDivWithLimit !c !e ns !n + | Just e' <- M.lookup n ns = Right (Scientific c e, Just (-e')) + | e <= (-l) = Left (Scientific c e, n % (d * magnitude (-e))) + | n < d = let !ns' = M.insert n e ns + in longDivWithLimit (c * 10) (e - 1) ns' (n * 10) + | otherwise = case n `quotRemInteger` d of + (#q, r#) -> longDivWithLimit (c + q) e ns r + + d = denominator rational + +-- | Like 'fromRationalRepetend' but doesn't accept a limit. +fromRationalRepetendUnlimited :: Rational -> (Scientific, Maybe Int) +fromRationalRepetendUnlimited rational + | d == 0 = throw DivideByZero + | num < 0 = case longDiv (-num) of + (s, mb) -> (-s, mb) + | otherwise = longDiv num + where + num = numerator rational + + longDiv :: Integer -> (Scientific, Maybe Int) + longDiv = longDivNoLimit 0 0 M.empty + longDivNoLimit :: Integer -> Int -> M.Map Integer Int @@ -362,22 +491,6 @@ | otherwise = case n `quotRemInteger` d of (#q, r#) -> longDivNoLimit (c + q) e ns r - longDivWithLimit :: Int -> Integer -> Either (Scientific, Rational) (Scientific, Maybe Int) - longDivWithLimit l = go 0 0 M.empty - where - go :: Integer - -> Int - -> M.Map Integer Int - -> (Integer -> Either (Scientific, Rational) (Scientific, Maybe Int)) - go !c !e _ns 0 = Right (Scientific c e, Nothing) - go !c !e ns !n - | Just e' <- M.lookup n ns = Right (Scientific c e, Just (-e')) - | e <= l = Left (Scientific c e, n % (d * magnitude (-e))) - | n < d = let !ns' = M.insert n e ns - in go (c * 10) (e - 1) ns' (n * 10) - | otherwise = case n `quotRemInteger` d of - (#q, r#) -> go (c + q) e ns r - d = denominator rational -- | @@ -393,6 +506,11 @@ -- -- * @r < -(base10Exponent s)@ -- +-- /WARNING:/ @toRationalRepetend@ needs to compute the 'Integer' magnitude: +-- @10^^n@. Where @n@ is based on the 'base10Exponent` of the scientific. If +-- applied to a huge exponent this could fill up all space and crash your +-- program! So don't apply this function to untrusted input. +-- -- The formula to convert the @Scientific@ @s@ -- with a repetend starting at index @r@ is described in the paper: -- @@ -443,6 +561,10 @@ nines = m - 1 +-- | /WARNING:/ the methods of the @RealFrac@ instance need to compute the +-- magnitude @10^e@. If applied to a huge exponent this could take a long +-- time. Even worse, when the destination type is unbounded (i.e. 'Integer') it +-- could fill up all space and crash your program! instance RealFrac Scientific where -- | The function 'properFraction' takes a Scientific number @s@ -- and returns a pair @(n,f)@ such that @s = n+f@, and: @@ -566,53 +688,10 @@ -- | Precondition: the 'Scientific' @s@ needs to be an integer: -- @base10Exponent (normalize s) >= 0@ toIntegral :: (Num a) => Scientific -> a -toIntegral (Scientific c e) = fromInteger c * fromInteger (magnitude e) +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 :: Int -> Integer -magnitude e | e < maxExpt = cachedPow10 e - | otherwise = cachedPow10 hi * 10 ^ (e - hi) - where - cachedPow10 = Primitive.indexArray expts10 - - hi = maxExpt - 1 - - ----------------------------------------------------------------------- -- Conversions ---------------------------------------------------------------------- @@ -711,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 @@ -739,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 #-} @@ -754,19 +827,29 @@ {-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Word32 #-} {-# SPECIALIZE toBoundedInteger :: Scientific -> Maybe Word64 #-} --- | @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@ 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' and wrapped in 'Left'. +-- +-- In case it's integer to scientific is converted to the desired 'Integral' and +-- wrapped in 'Right'. +-- +-- /WARNING:/ To convert the scientific to an integral the magnitude @10^e@ +-- needs to be computed. If applied to a huge exponent this could take a long +-- time. Even worse, when the destination type is unbounded (i.e. 'Integer') it +-- could fill up all space and crash your program! So don't apply this function +-- to untrusted input but use 'toBoundedInteger' instead. +-- -- 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 @@ -782,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 ---------------------------------------------------------------------- @@ -829,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 -> @@ -885,13 +988,19 @@ -- Pretty Printing ---------------------------------------------------------------------- +-- | 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 @@ -961,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) = @@ -977,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} @@ -1006,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 @@ -1026,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 diff --git a/src/Data/Text/Lazy/Builder/Scientific.hs b/src/Data/Text/Lazy/Builder/Scientific.hs --- a/src/Data/Text/Lazy/Builder/Scientific.hs +++ b/src/Data/Text/Lazy/Builder/Scientific.hs @@ -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') diff --git a/src/GHC/Integer/Compat.hs b/src/GHC/Integer/Compat.hs --- a/src/GHC/Integer/Compat.hs +++ b/src/GHC/Integer/Compat.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -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) -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) @@ -34,18 +28,107 @@ import qualified Data.ByteString.Lazy.Char8 as BLC8 import qualified Data.ByteString.Builder.Scientific as B import qualified Data.ByteString.Builder as B +import Text.ParserCombinators.ReadP (readP_to_S) main :: IO () main = testMain $ testGroup "scientific" - [ smallQuick "normalization" - (SC.over normalizedScientificSeries $ \s -> - s /= 0 SC.==> abs (Scientific.coefficient s) `mod` 10 /= 0) + [ testGroup "DoS protection" + [ testGroup "Eq" + [ 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 + , testCase "-1e-1000000" $ (floor (read "-1e-1000000" :: Scientific) :: Int) @?= (-1) + , testCase "1e-1000000" $ (floor (read "1e-1000000" :: Scientific) :: Int) @?= 0 + ] + , testGroup "ceiling" + [ testCase "1e1000000" $ (ceiling (read "1e1000000" :: Scientific) :: Int) @?= 0 + , testCase "-1e-1000000" $ (ceiling (read "-1e-1000000" :: Scientific) :: Int) @?= 0 + , testCase "1e-1000000" $ (ceiling (read "1e-1000000" :: Scientific) :: Int) @?= 1 + ] + , testGroup "round" + [ testCase "1e1000000" $ (round (read "1e1000000" :: Scientific) :: Int) @?= 0 + , testCase "-1e-1000000" $ (round (read "-1e-1000000" :: Scientific) :: Int) @?= 0 + , testCase "1e-1000000" $ (round (read "1e-1000000" :: Scientific) :: Int) @?= 0 + ] + , testGroup "truncate" + [ testCase "1e1000000" $ (truncate (read "1e1000000" :: Scientific) :: Int) @?= 0 + , testCase "-1e-1000000" $ (truncate (read "-1e-1000000" :: Scientific) :: Int) @?= 0 + , testCase "1e-1000000" $ (truncate (read "1e-1000000" :: Scientific) :: Int) @?= 0 + ] + , testGroup "properFracton" + [ testCase "1e1000000" $ properFraction (read "1e1000000" :: Scientific) @?= (0 :: Int, 0) + , testCase "-1e-1000000" $ let s = read "-1e-1000000" :: Scientific + in properFraction s @?= (0 :: Int, s) + , testCase "1e-1000000" $ let s = read "1e-1000000" :: Scientific + in properFraction s @?= (0 :: Int, s) + ] + ] + , testGroup "toRealFloat" + [ testCase "1e1000000" $ assertBool "Should be infinity!" $ isInfinite $ + (toRealFloat (read "1e1000000" :: Scientific) :: Double) + , testCase "1e-1000000" $ (toRealFloat (read "1e-1000000" :: Scientific) :: Double) @?= 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" @@ -55,18 +138,24 @@ , testCase "reads \"(1.3 )\"" $ testReads "(1.3 )" [(1.3, "")] , testCase "reads \"((1.3))\"" $ testReads "((1.3))" [(1.3, "")] , testCase "reads \" 1.3\"" $ testReads " 1.3" [(1.3, "")] + , testCase "read \" ( (( -1.0e+3 ) ))\"" $ testRead " ( (( -1.0e+3 ) ))" (-1000.0) + , testCase "scientificP \"3\"" $ testScientificP "3" [(3.0, "")] + , testCase "scientificP \"3.0e2\"" $ testScientificP "3.0e2" [(3.0, "e2"), (300.0, "")] + , testCase "scientificP \"+3.0e+2\"" $ testScientificP "+3.0e+2" [(3.0, "e+2"), (300.0, "")] + , testCase "scientificP \"-3.0e-2\"" $ testScientificP "-3.0e-2" [(-3.0, "e-2"), (-3.0e-2, "")] ] , 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) ] @@ -91,9 +180,20 @@ -- show d ] + , testGroup "Eq" + [ testProperty "==" $ \(s1 :: Scientific) (s2 :: Scientific) -> + (s1 == s2) == (toRational s1 == toRational s2) + , testProperty "s == s" $ \(s :: Scientific) -> s == s + ] + + , testGroup "Ord" + [ testProperty "compare" $ \(s1 :: Scientific) (s2 :: Scientific) -> + compare s1 s2 == compare (toRational s1) (toRational s2) + ] + , 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 (*) @@ -102,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" @@ -130,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) @@ -174,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) ] @@ -212,12 +311,25 @@ ] ] +-- 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 +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 + genericIsFloating :: RealFrac a => a -> Bool genericIsFloating a = fromInteger (floor a :: Integer) /= a @@ -229,7 +341,6 @@ conversionsProperties :: forall realFloat. ( RealFloat realFloat , QC.Arbitrary realFloat - , SC.Serial IO realFloat , Show realFloat ) => realFloat -> [TestTree] @@ -265,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 @@ -305,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 @@ -346,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 ---------------------------------------------------------------------- @@ -374,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 = @@ -391,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