{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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 qualified Test.QuickCheck as QC import qualified Test.Tasty.QuickCheck as QC (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) import qualified Data.Text.Lazy.Builder.Scientific as T import Numeric ( floatToDigits ) 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) (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 ] , testGroup "Parsing" [ testCase "reads \"\"" $ testReads "" [] , testCase "reads \"1.\"" $ testReads "1." [(1.0, ".")] , testCase "reads \"1.2e\"" $ testReads "1.2e" [(1.2, "e")] , 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 , testGroup "toDecimalDigits" [ smallQuick "laws" (SC.over nonNegativeScientificSeries toDecimalDigits_laws) (QC.forAll nonNegativeScientificGen toDecimalDigits_laws) , smallQuick "== Numeric.floatToDigits" (toDecimalDigits_eq_floatToDigits . SC.getNonNegative) (toDecimalDigits_eq_floatToDigits . QC.getNonNegative) ] , testGroup "Builder" [ testProperty "Text" $ \s -> formatScientific Scientific.Generic Nothing s == TL.unpack (TLB.toLazyText $ T.formatScientificBuilder Scientific.Generic Nothing s) , testProperty "ByteString" $ \s -> formatScientific Scientific.Generic Nothing s == BLC8.unpack (B.toLazyByteString $ B.formatScientificBuilder Scientific.Generic Nothing s) ] , testProperty "formatScientific_fromFloatDigits" $ \(d::Double) -> formatScientific Scientific.Generic Nothing (Scientific.fromFloatDigits d) == show d -- , testProperty "formatScientific_realToFrac" $ \(d::Double) -> -- formatScientific B.Generic Nothing (realToFrac d :: Scientific) == -- show d ] , testGroup "Num" [ testGroup "Equal to Rational" [ testProperty "fromInteger" $ \i -> fromInteger i === fromRational (fromInteger i) , testProperty "+" $ bin (+) , testProperty "-" $ bin (-) , testProperty "*" $ bin (*) , testProperty "abs" $ unary abs , testProperty "negate" $ unary negate , 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 "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 "subtracting the addition" $ \x y -> x + y - y === x , testProperty "+ and negate" $ \x -> x + negate x === 0 , testProperty "- and negate" $ \x -> 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) ] , testGroup "Real" [ testProperty "fromRational . toRational == id" $ \x -> (fromRational . toRational) x === x ] , testGroup "RealFrac" [ testGroup "Equal to Rational" [ testProperty "properFraction" $ \x -> let (n1::Integer, f1::Scientific) = properFraction x (n2::Integer, f2::Rational) = properFraction (toRational x) in (n1 == n2) && (f1 == fromRational f2) , testProperty "round" $ \(x::Scientific) -> (round x :: Integer) == round (toRational x) , testProperty "truncate" $ \(x::Scientific) -> (truncate x :: Integer) == truncate (toRational x) , testProperty "ceiling" $ \(x::Scientific) -> (ceiling x :: Integer) == ceiling (toRational x) , testProperty "floor" $ \(x::Scientific) -> (floor x :: Integer) == floor (toRational x) ] , testProperty "properFraction_laws" properFraction_laws , testProperty "round" $ \s -> round s == roundDefault s , testProperty "truncate" $ \s -> truncate s == truncateDefault s , testProperty "ceiling" $ \s -> ceiling s == ceilingDefault s , testProperty "floor" $ \s -> floor s == floorDefault s ] , testGroup "Conversions" [ testProperty "fromRationalRepetend" $ \(l, r) -> r == (case fromRationalRepetend (Just l) r of Left (s, rr) -> toRational s + rr Right (s, mbRepetend) -> case mbRepetend of Nothing -> toRational s Just repetend -> toRationalRepetend s repetend) , testGroup "Float" $ conversionsProperties (undefined :: Float) , testGroup "Double" $ conversionsProperties (undefined :: Double) , testGroup "floatingOrInteger" [ testProperty "correct conversion" $ \s -> case floatingOrInteger s :: Either Double Int of Left d -> d == toRealFloat s Right i -> i == fromInteger (coefficient s') * 10^(base10Exponent s') where s' = normalize s , testProperty "Integer == Right" $ \(i::Integer) -> (floatingOrInteger (fromInteger i) :: Either Double Integer) == Right i , smallQuick "Double == Left" (\(d::Double) -> genericIsFloating d SC.==> (floatingOrInteger (realToFrac d) :: Either Double Integer) == Left d) (\(d::Double) -> genericIsFloating d QC.==> (floatingOrInteger (realToFrac d) :: Either Double Integer) == Left d) ] , testGroup "toBoundedInteger" [ testGroup "correct conversion" [ testProperty "Int64" $ toBoundedIntegerConversion (undefined :: Int64) , testProperty "Word64" $ toBoundedIntegerConversion (undefined :: Word64) , testProperty "NegativeNum" $ toBoundedIntegerConversion (undefined :: NegativeInt) ] ] ] , testGroup "toBoundedRealFloat" [ testCase "0 * 10^1000 == 0" $ toBoundedRealFloat (scientific 0 1000) @?= Right (0 :: Float) ] , testGroup "toBoundedInteger" [ testGroup "to Int64" $ [ testCase "succ of maxBound" $ let i = succ . fromIntegral $ (maxBound :: Int64) s = scientific i 0 in (toBoundedInteger s :: Maybe Int64) @?= Nothing , testCase "pred of minBound" $ let i = pred . fromIntegral $ (minBound :: Int64) s = scientific i 0 in (toBoundedInteger s :: Maybe Int64) @?= Nothing , testCase "0 * 10^1000 == 0" $ toBoundedInteger (scientific 0 1000) @?= Just (0 :: Int64) ] ] , testGroup "Predicates" [ testProperty "isFloating" $ \s -> isFloating s == genericIsFloating s , testProperty "isInteger" $ \s -> isInteger s == not (genericIsFloating s) ] ] testMain :: TestTree -> IO () testMain = defaultMainWithIngredients (antXMLRunner:defaultIngredients) testReads :: String -> [(Scientific, String)] -> Assertion testReads inp out = reads inp @?= out testRead :: String -> Scientific -> Assertion testRead inp out = read 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 toDecimalDigits_eq_floatToDigits :: Double -> Bool toDecimalDigits_eq_floatToDigits d = Scientific.toDecimalDigits (Scientific.fromFloatDigits d) == Numeric.floatToDigits 10 d conversionsProperties :: forall realFloat. ( RealFloat realFloat , QC.Arbitrary realFloat , SC.Serial IO realFloat , Show realFloat ) => realFloat -> [TestTree] conversionsProperties _ = [ -- testProperty "fromFloatDigits_1" $ \(d :: realFloat) -> -- Scientific.fromFloatDigits d === realToFrac d -- testProperty "fromFloatDigits_2" $ \(s :: Scientific) -> -- Scientific.fromFloatDigits (realToFrac s :: realFloat) == s testProperty "toRealFloat" $ \(d :: realFloat) -> (Scientific.toRealFloat . realToFrac) d == d , testProperty "toRealFloat . fromFloatDigits == id" $ \(d :: realFloat) -> (Scientific.toRealFloat . Scientific.fromFloatDigits) d == d -- , testProperty "fromFloatDigits . toRealFloat == id" $ \(s :: Scientific) -> -- Scientific.fromFloatDigits (Scientific.toRealFloat s :: realFloat) == s ] toBoundedIntegerConversion :: forall i. (Integral i, Bounded i) => i -> Scientific -> Bool toBoundedIntegerConversion _ s = case toBoundedInteger s :: Maybe i of Just i -> i == (fromIntegral $ (coefficient s') * 10^(base10Exponent s')) && i >= minBound && i <= maxBound where s' = normalize s Nothing -> isFloating s || 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 unary :: (forall a. Num a => a -> a) -> Scientific -> Bool unary op a = toRational (op a) == op (toRational a) toDecimalDigits_laws :: Scientific -> Bool toDecimalDigits_laws x = let (ds, e) = Scientific.toDecimalDigits x rule1 = n >= 1 n = length ds rule2 = toRational x == coeff * 10 ^^ e coeff = foldr (\di a -> a / 10 + fromIntegral di) 0 (0:ds) rule3 = all (\di -> 0 <= di && di <= 9) ds rule4 | n == 1 = True | otherwise = null $ takeWhile (==0) $ reverse ds 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) && abs f < 1 where posX = positive x (n, f) = properFraction x :: (Integer, Scientific) positive :: (Ord a, Num a) => a -> Bool positive y = y >= 0 floorDefault :: Scientific -> Integer floorDefault x = if r < 0 then n - 1 else n where (n,r) = properFraction x ceilingDefault :: Scientific -> Integer ceilingDefault x = if r > 0 then n + 1 else n where (n,r) = properFraction x truncateDefault :: Scientific -> Integer truncateDefault x = m where (m,_) = properFraction x roundDefault :: Scientific -> Integer roundDefault x = let (n,r) = properFraction x m = if r < 0 then n - 1 else n + 1 in case signum (abs r - 0.5) of -1 -> n 0 -> if even n then n else m 1 -> m _ -> error "round default defn: Bad value" newtype NegativeInt = NegativeInt Int deriving (Show, Enum, Eq, Ord, Num, Real, Integral) instance Bounded NegativeInt where minBound = -100 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 ---------------------------------------------------------------------- instance QC.Arbitrary Scientific where arbitrary = QC.frequency [ (70, scientific <$> QC.arbitrary <*> intGen) , (20, scientific <$> QC.arbitrary <*> bigIntGen) , (10, scientific <$> pure 0 <*> bigIntGen) ] shrink s = zipWith scientific (QC.shrink $ Scientific.coefficient s) (QC.shrink $ Scientific.base10Exponent s) nonNegativeScientificGen :: QC.Gen Scientific nonNegativeScientificGen = scientific <$> (QC.getNonNegative <$> QC.arbitrary) <*> intGen normalizedScientificGen :: QC.Gen Scientific normalizedScientificGen = Scientific.normalize <$> QC.arbitrary bigIntGen :: QC.Gen Int 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