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