1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE MultiParamTypeClasses #-} 5{-# LANGUAGE RankNTypes #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7{-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 9{-# OPTIONS_GHC -fno-warn-orphans #-} 10 11module Main where 12 13#if !MIN_VERSION_base(4,8,0) 14import Control.Applicative 15#endif 16import Control.Monad 17import Data.Int 18import Data.Word 19import Data.Scientific as Scientific 20import Test.Tasty 21import Test.Tasty.Runners.AntXML 22import Test.Tasty.HUnit (testCase, (@?=), Assertion, assertBool) 23import qualified Test.SmallCheck as SC 24import qualified Test.SmallCheck.Series as SC 25import qualified Test.Tasty.SmallCheck as SC (testProperty) 26import qualified Test.QuickCheck as QC 27import qualified Test.Tasty.QuickCheck as QC (testProperty) 28import qualified Data.Binary as Binary (encode, decode) 29import qualified Data.Text.Lazy as TL (unpack) 30import qualified Data.Text.Lazy.Builder as TLB (toLazyText) 31import qualified Data.Text.Lazy.Builder.Scientific as T 32import Numeric ( floatToDigits ) 33 34import qualified Data.ByteString.Lazy.Char8 as BLC8 35import qualified Data.ByteString.Builder.Scientific as B 36import qualified Data.ByteString.Builder as B 37import Text.ParserCombinators.ReadP (readP_to_S) 38 39main :: IO () 40main = testMain $ testGroup "scientific" 41 [ testGroup "DoS protection" 42 [ testGroup "Eq" 43 [ testCase "1e1000000" $ assertBool "" $ 44 (read "1e1000000" :: Scientific) == (read "1e1000000" :: Scientific) 45 ] 46 , testGroup "Ord" 47 [ testCase "compare 1234e1000000 123e1000001" $ 48 compare (read "1234e1000000" :: Scientific) (read "123e1000001" :: Scientific) @?= GT 49 ] 50 51 , testGroup "RealFrac" 52 [ testGroup "floor" 53 [ testCase "1e1000000" $ (floor (read "1e1000000" :: Scientific) :: Int) @?= 0 54 , testCase "-1e-1000000" $ (floor (read "-1e-1000000" :: Scientific) :: Int) @?= (-1) 55 , testCase "1e-1000000" $ (floor (read "1e-1000000" :: Scientific) :: Int) @?= 0 56 ] 57 , testGroup "ceiling" 58 [ testCase "1e1000000" $ (ceiling (read "1e1000000" :: Scientific) :: Int) @?= 0 59 , testCase "-1e-1000000" $ (ceiling (read "-1e-1000000" :: Scientific) :: Int) @?= 0 60 , testCase "1e-1000000" $ (ceiling (read "1e-1000000" :: Scientific) :: Int) @?= 1 61 ] 62 , testGroup "round" 63 [ testCase "1e1000000" $ (round (read "1e1000000" :: Scientific) :: Int) @?= 0 64 , testCase "-1e-1000000" $ (round (read "-1e-1000000" :: Scientific) :: Int) @?= 0 65 , testCase "1e-1000000" $ (round (read "1e-1000000" :: Scientific) :: Int) @?= 0 66 ] 67 , testGroup "truncate" 68 [ testCase "1e1000000" $ (truncate (read "1e1000000" :: Scientific) :: Int) @?= 0 69 , testCase "-1e-1000000" $ (truncate (read "-1e-1000000" :: Scientific) :: Int) @?= 0 70 , testCase "1e-1000000" $ (truncate (read "1e-1000000" :: Scientific) :: Int) @?= 0 71 ] 72 , testGroup "properFracton" 73 [ testCase "1e1000000" $ properFraction (read "1e1000000" :: Scientific) @?= (0 :: Int, 0) 74 , testCase "-1e-1000000" $ let s = read "-1e-1000000" :: Scientific 75 in properFraction s @?= (0 :: Int, s) 76 , testCase "1e-1000000" $ let s = read "1e-1000000" :: Scientific 77 in properFraction s @?= (0 :: Int, s) 78 ] 79 ] 80 , testGroup "toRealFloat" 81 [ testCase "1e1000000" $ assertBool "Should be infinity!" $ isInfinite $ 82 (toRealFloat (read "1e1000000" :: Scientific) :: Double) 83 , testCase "1e-1000000" $ (toRealFloat (read "1e-1000000" :: Scientific) :: Double) @?= 0 84 ] 85 , testGroup "toBoundedInteger" 86 [ testCase "1e1000000" $ (toBoundedInteger (read "1e1000000" :: Scientific) :: Maybe Int) @?= Nothing 87 ] 88 ] 89 90 , smallQuick "normalization" 91 (SC.over normalizedScientificSeries $ \s -> 92 s /= 0 SC.==> abs (Scientific.coefficient s) `mod` 10 /= 0) 93 (QC.forAll normalizedScientificGen $ \s -> 94 s /= 0 QC.==> abs (Scientific.coefficient s) `mod` 10 /= 0) 95 96 , testGroup "Binary" 97 [ testProperty "decode . encode == id" $ \s -> 98 Binary.decode (Binary.encode s) === s 99 ] 100 101 , testGroup "Parsing" 102 [ testCase "reads \"\"" $ testReads "" [] 103 , testCase "reads \"1.\"" $ testReads "1." [(1.0, ".")] 104 , testCase "reads \"1.2e\"" $ testReads "1.2e" [(1.2, "e")] 105 , testCase "reads \"(1.3 )\"" $ testReads "(1.3 )" [(1.3, "")] 106 , testCase "reads \"((1.3))\"" $ testReads "((1.3))" [(1.3, "")] 107 , testCase "reads \" 1.3\"" $ testReads " 1.3" [(1.3, "")] 108 , testCase "read \" ( (( -1.0e+3 ) ))\"" $ testRead " ( (( -1.0e+3 ) ))" (-1000.0) 109 , testCase "scientificP \"3\"" $ testScientificP "3" [(3.0, "")] 110 , testCase "scientificP \"3.0e2\"" $ testScientificP "3.0e2" [(3.0, "e2"), (300.0, "")] 111 , testCase "scientificP \"+3.0e+2\"" $ testScientificP "+3.0e+2" [(3.0, "e+2"), (300.0, "")] 112 , testCase "scientificP \"-3.0e-2\"" $ testScientificP "-3.0e-2" [(-3.0, "e-2"), (-3.0e-2, "")] 113 ] 114 115 , testGroup "Formatting" 116 [ testProperty "read . show == id" $ \s -> read (show s) === s 117 118 , testGroup "toDecimalDigits" 119 [ smallQuick "laws" 120 (SC.over nonNegativeScientificSeries toDecimalDigits_laws) 121 (QC.forAll nonNegativeScientificGen toDecimalDigits_laws) 122 123 , smallQuick "== Numeric.floatToDigits" 124 (toDecimalDigits_eq_floatToDigits . SC.getNonNegative) 125 (toDecimalDigits_eq_floatToDigits . QC.getNonNegative) 126 ] 127 128 , testGroup "Builder" 129 [ testProperty "Text" $ \s -> 130 formatScientific Scientific.Generic Nothing s == 131 TL.unpack (TLB.toLazyText $ 132 T.formatScientificBuilder Scientific.Generic Nothing s) 133 134 , testProperty "ByteString" $ \s -> 135 formatScientific Scientific.Generic Nothing s == 136 BLC8.unpack (B.toLazyByteString $ 137 B.formatScientificBuilder Scientific.Generic Nothing s) 138 ] 139 140 , testProperty "formatScientific_fromFloatDigits" $ \(d::Double) -> 141 formatScientific Scientific.Generic Nothing (Scientific.fromFloatDigits d) == 142 show d 143 144 -- , testProperty "formatScientific_realToFrac" $ \(d::Double) -> 145 -- formatScientific B.Generic Nothing (realToFrac d :: Scientific) == 146 -- show d 147 ] 148 149 , testGroup "Eq" 150 [ testProperty "==" $ \(s1 :: Scientific) (s2 :: Scientific) -> 151 (s1 == s2) == (toRational s1 == toRational s2) 152 , testProperty "s == s" $ \(s :: Scientific) -> s == s 153 ] 154 155 , testGroup "Ord" 156 [ testProperty "compare" $ \(s1 :: Scientific) (s2 :: Scientific) -> 157 compare s1 s2 == compare (toRational s1) (toRational s2) 158 ] 159 160 , testGroup "Num" 161 [ testGroup "Equal to Rational" 162 [ testProperty "fromInteger" $ \i -> fromInteger i === fromRational (fromInteger i) 163 , testProperty "+" $ bin (+) 164 , testProperty "-" $ bin (-) 165 , testProperty "*" $ bin (*) 166 , testProperty "abs" $ unary abs 167 , testProperty "negate" $ unary negate 168 , testProperty "signum" $ unary signum 169 ] 170 171 , testProperty "0 identity of +" $ \a -> a + 0 === a 172 , testProperty "1 identity of *" $ \a -> 1 * a === a 173 , testProperty "0 identity of *" $ \a -> 0 * a === 0 174 175 , testProperty "associativity of +" $ \a b c -> a + (b + c) === (a + b) + c 176 , testProperty "commutativity of +" $ \a b -> a + b === b + a 177 , testProperty "distributivity of * over +" $ \a b c -> a * (b + c) === a * b + a * c 178 179 , testProperty "subtracting the addition" $ \x y -> x + y - y === x 180 181 , testProperty "+ and negate" $ \x -> x + negate x === 0 182 , testProperty "- and negate" $ \x -> x - negate x === x + x 183 184 , smallQuick "abs . negate == id" 185 (SC.over nonNegativeScientificSeries $ \x -> abs (negate x) === x) 186 (QC.forAll nonNegativeScientificGen $ \x -> abs (negate x) === x) 187 ] 188 189 , testGroup "Real" 190 [ testProperty "fromRational . toRational == id" $ \x -> 191 (fromRational . toRational) x === x 192 ] 193 194 , testGroup "RealFrac" 195 [ testGroup "Equal to Rational" 196 [ testProperty "properFraction" $ \x -> 197 let (n1::Integer, f1::Scientific) = properFraction x 198 (n2::Integer, f2::Rational) = properFraction (toRational x) 199 in (n1 == n2) && (f1 == fromRational f2) 200 201 , testProperty "round" $ \(x::Scientific) -> 202 (round x :: Integer) == round (toRational x) 203 204 , testProperty "truncate" $ \(x::Scientific) -> 205 (truncate x :: Integer) == truncate (toRational x) 206 207 , testProperty "ceiling" $ \(x::Scientific) -> 208 (ceiling x :: Integer) == ceiling (toRational x) 209 210 , testProperty "floor" $ \(x::Scientific) -> 211 (floor x :: Integer) == floor (toRational x) 212 ] 213 214 , testProperty "properFraction_laws" properFraction_laws 215 216 , testProperty "round" $ \s -> round s == roundDefault s 217 , testProperty "truncate" $ \s -> truncate s == truncateDefault s 218 , testProperty "ceiling" $ \s -> ceiling s == ceilingDefault s 219 , testProperty "floor" $ \s -> floor s == floorDefault s 220 ] 221 222 , testGroup "Conversions" 223 [ testProperty "fromRationalRepetend" $ \(l, r) -> r == 224 (case fromRationalRepetend (Just l) r of 225 Left (s, rr) -> toRational s + rr 226 Right (s, mbRepetend) -> 227 case mbRepetend of 228 Nothing -> toRational s 229 Just repetend -> toRationalRepetend s repetend) 230 231 , testGroup "Float" $ conversionsProperties (undefined :: Float) 232 , testGroup "Double" $ conversionsProperties (undefined :: Double) 233 234 , testGroup "floatingOrInteger" 235 [ testProperty "correct conversion" $ \s -> 236 case floatingOrInteger s :: Either Double Int of 237 Left d -> d == toRealFloat s 238 Right i -> i == fromInteger (coefficient s') * 10^(base10Exponent s') 239 where 240 s' = normalize s 241 , testProperty "Integer == Right" $ \(i::Integer) -> 242 (floatingOrInteger (fromInteger i) :: Either Double Integer) == Right i 243 , smallQuick "Double == Left" 244 (\(d::Double) -> genericIsFloating d SC.==> 245 (floatingOrInteger (realToFrac d) :: Either Double Integer) == Left d) 246 (\(d::Double) -> genericIsFloating d QC.==> 247 (floatingOrInteger (realToFrac d) :: Either Double Integer) == Left d) 248 ] 249 , testGroup "toBoundedInteger" 250 [ testGroup "correct conversion" 251 [ testProperty "Int64" $ toBoundedIntegerConversion (undefined :: Int64) 252 , testProperty "Word64" $ toBoundedIntegerConversion (undefined :: Word64) 253 , testProperty "NegativeNum" $ toBoundedIntegerConversion (undefined :: NegativeInt) 254 ] 255 ] 256 ] 257 , testGroup "toBoundedRealFloat" 258 [ testCase "0 * 10^1000 == 0" $ 259 toBoundedRealFloat (scientific 0 1000) @?= Right (0 :: Float) 260 ] 261 , testGroup "toBoundedInteger" 262 [ testGroup "to Int64" $ 263 [ testCase "succ of maxBound" $ 264 let i = succ . fromIntegral $ (maxBound :: Int64) 265 s = scientific i 0 266 in (toBoundedInteger s :: Maybe Int64) @?= Nothing 267 , testCase "pred of minBound" $ 268 let i = pred . fromIntegral $ (minBound :: Int64) 269 s = scientific i 0 270 in (toBoundedInteger s :: Maybe Int64) @?= Nothing 271 , testCase "0 * 10^1000 == 0" $ 272 toBoundedInteger (scientific 0 1000) @?= Just (0 :: Int64) 273 ] 274 ] 275 , testGroup "Predicates" 276 [ testProperty "isFloating" $ \s -> isFloating s == genericIsFloating s 277 , testProperty "isInteger" $ \s -> isInteger s == not (genericIsFloating s) 278 ] 279 ] 280 281testMain :: TestTree -> IO () 282testMain = defaultMainWithIngredients (antXMLRunner:defaultIngredients) 283 284testReads :: String -> [(Scientific, String)] -> Assertion 285testReads inp out = reads inp @?= out 286 287testRead :: String -> Scientific -> Assertion 288testRead inp out = read inp @?= out 289 290testScientificP :: String -> [(Scientific, String)] -> Assertion 291testScientificP inp out = readP_to_S Scientific.scientificP inp @?= out 292 293genericIsFloating :: RealFrac a => a -> Bool 294genericIsFloating a = fromInteger (floor a :: Integer) /= a 295 296toDecimalDigits_eq_floatToDigits :: Double -> Bool 297toDecimalDigits_eq_floatToDigits d = 298 Scientific.toDecimalDigits (Scientific.fromFloatDigits d) 299 == Numeric.floatToDigits 10 d 300 301conversionsProperties :: forall realFloat. 302 ( RealFloat realFloat 303 , QC.Arbitrary realFloat 304 , SC.Serial IO realFloat 305 , Show realFloat 306 ) 307 => realFloat -> [TestTree] 308conversionsProperties _ = 309 [ 310 -- testProperty "fromFloatDigits_1" $ \(d :: realFloat) -> 311 -- Scientific.fromFloatDigits d === realToFrac d 312 313 -- testProperty "fromFloatDigits_2" $ \(s :: Scientific) -> 314 -- Scientific.fromFloatDigits (realToFrac s :: realFloat) == s 315 316 testProperty "toRealFloat" $ \(d :: realFloat) -> 317 (Scientific.toRealFloat . realToFrac) d == d 318 319 , testProperty "toRealFloat . fromFloatDigits == id" $ \(d :: realFloat) -> 320 (Scientific.toRealFloat . Scientific.fromFloatDigits) d == d 321 322 -- , testProperty "fromFloatDigits . toRealFloat == id" $ \(s :: Scientific) -> 323 -- Scientific.fromFloatDigits (Scientific.toRealFloat s :: realFloat) == s 324 ] 325 326toBoundedIntegerConversion 327 :: forall i. (Integral i, Bounded i) 328 => i -> Scientific -> Bool 329toBoundedIntegerConversion _ s = 330 case toBoundedInteger s :: Maybe i of 331 Just i -> i == (fromIntegral $ (coefficient s') * 10^(base10Exponent s')) && 332 i >= minBound && 333 i <= maxBound 334 where 335 s' = normalize s 336 Nothing -> isFloating s || 337 s < fromIntegral (minBound :: i) || 338 s > fromIntegral (maxBound :: i) 339 340testProperty :: (SC.Testable IO test, QC.Testable test) 341 => TestName -> test -> TestTree 342testProperty n test = smallQuick n test test 343 344smallQuick :: (SC.Testable IO smallCheck, QC.Testable quickCheck) 345 => TestName -> smallCheck -> quickCheck -> TestTree 346smallQuick n sc qc = testGroup n 347 [ SC.testProperty "smallcheck" sc 348 , QC.testProperty "quickcheck" qc 349 ] 350 351-- | ('==') specialized to 'Scientific' so we don't have to put type 352-- signatures everywhere. 353(===) :: Scientific -> Scientific -> Bool 354(===) = (==) 355infix 4 === 356 357bin :: (forall a. Num a => a -> a -> a) -> Scientific -> Scientific -> Bool 358bin op a b = toRational (a `op` b) == toRational a `op` toRational b 359 360unary :: (forall a. Num a => a -> a) -> Scientific -> Bool 361unary op a = toRational (op a) == op (toRational a) 362 363toDecimalDigits_laws :: Scientific -> Bool 364toDecimalDigits_laws x = 365 let (ds, e) = Scientific.toDecimalDigits x 366 367 rule1 = n >= 1 368 n = length ds 369 370 rule2 = toRational x == coeff * 10 ^^ e 371 coeff = foldr (\di a -> a / 10 + fromIntegral di) 0 (0:ds) 372 373 rule3 = all (\di -> 0 <= di && di <= 9) ds 374 375 rule4 | n == 1 = True 376 | otherwise = null $ takeWhile (==0) $ reverse ds 377 378 in rule1 && rule2 && rule3 && rule4 379 380properFraction_laws :: Scientific -> Bool 381properFraction_laws x = fromInteger n + f === x && 382 (positive n == posX || n == 0) && 383 (positive f == posX || f == 0) && 384 abs f < 1 385 where 386 posX = positive x 387 388 (n, f) = properFraction x :: (Integer, Scientific) 389 390positive :: (Ord a, Num a) => a -> Bool 391positive y = y >= 0 392 393floorDefault :: Scientific -> Integer 394floorDefault x = if r < 0 then n - 1 else n 395 where (n,r) = properFraction x 396 397ceilingDefault :: Scientific -> Integer 398ceilingDefault x = if r > 0 then n + 1 else n 399 where (n,r) = properFraction x 400 401truncateDefault :: Scientific -> Integer 402truncateDefault x = m where (m,_) = properFraction x 403 404roundDefault :: Scientific -> Integer 405roundDefault x = let (n,r) = properFraction x 406 m = if r < 0 then n - 1 else n + 1 407 in case signum (abs r - 0.5) of 408 -1 -> n 409 0 -> if even n then n else m 410 1 -> m 411 _ -> error "round default defn: Bad value" 412 413newtype NegativeInt = NegativeInt Int 414 deriving (Show, Enum, Eq, Ord, Num, Real, Integral) 415 416instance Bounded NegativeInt where 417 minBound = -100 418 maxBound = -10 419 420---------------------------------------------------------------------- 421-- SmallCheck instances 422---------------------------------------------------------------------- 423 424instance (Monad m) => SC.Serial m Scientific where 425 series = scientifics 426 427scientifics :: (Monad m) => SC.Series m Scientific 428scientifics = SC.cons2 scientific 429 430nonNegativeScientificSeries :: (Monad m) => SC.Series m Scientific 431nonNegativeScientificSeries = liftM SC.getNonNegative SC.series 432 433normalizedScientificSeries :: (Monad m) => SC.Series m Scientific 434normalizedScientificSeries = liftM Scientific.normalize SC.series 435 436 437---------------------------------------------------------------------- 438-- QuickCheck instances 439---------------------------------------------------------------------- 440 441instance QC.Arbitrary Scientific where 442 arbitrary = QC.frequency 443 [ (70, scientific <$> QC.arbitrary 444 <*> intGen) 445 , (20, scientific <$> QC.arbitrary 446 <*> bigIntGen) 447 , (10, scientific <$> pure 0 448 <*> bigIntGen) 449 ] 450 451 shrink s = zipWith scientific (QC.shrink $ Scientific.coefficient s) 452 (QC.shrink $ Scientific.base10Exponent s) 453 454nonNegativeScientificGen :: QC.Gen Scientific 455nonNegativeScientificGen = 456 scientific <$> (QC.getNonNegative <$> QC.arbitrary) 457 <*> intGen 458 459normalizedScientificGen :: QC.Gen Scientific 460normalizedScientificGen = Scientific.normalize <$> QC.arbitrary 461 462bigIntGen :: QC.Gen Int 463bigIntGen = QC.sized $ \size -> QC.resize (size * 1000) intGen 464 465intGen :: QC.Gen Int 466#if MIN_VERSION_QuickCheck(2,7,0) 467intGen = QC.arbitrary 468#else 469intGen = QC.sized $ \n -> QC.choose (-n, n) 470#endif 471