diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for libBF-hs +## 0.6.7 -- 2023.11.28 + +* Add `Data` instances for `BigFloat`, `Sign`, `BFRep`, and `BFNum`. + ## 0.6.6 -- 2023.07.17 * Update the vendored version of `libbf` to include the changes from the diff --git a/libBF.cabal b/libBF.cabal --- a/libBF.cabal +++ b/libBF.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: libBF -version: 0.6.6 +version: 0.6.7 synopsis: A binding to the libBF library. description: LibBF is a C library for working with arbitray precision IEEE 754 floating point numbers. @@ -78,17 +78,13 @@ ghc-options: -Wall default-language: Haskell2010 -executable bf-test - main-is: RunUnitTests.hs - hs-source-dirs: tests - build-depends: base, libBF - default-language: Haskell2010 - - test-suite libBF-tests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: RunUnitTests.hs + ghc-options: -Wall default-language: Haskell2010 - build-depends: base, libBF - + build-depends: base, + libBF, + tasty >= 1.3 && < 1.6, + tasty-hunit >= 0.10 && < 0.11 diff --git a/src/LibBF.hs b/src/LibBF.hs --- a/src/LibBF.hs +++ b/src/LibBF.hs @@ -61,6 +61,7 @@ import Data.Bits +import Data.Data (Data(..)) import Data.Hashable import Data.Word import Data.Int @@ -72,6 +73,15 @@ -- | Arbitrary precision floating point numbers. newtype BigFloat = BigFloat BF + +instance Data BigFloat where + -- BigFloat is exported as an abstract data type, so we intentionally define + -- the Data instance in a simplistic way so as to avoid leaking the BF + -- internals. + gfoldl _ z = z + gunfold _ _ = error "Data.Data.gunfold(BigFloat)" + toConstr _ = error "Data.Data.toConstr(BigFloat)" + dataTypeOf _ = error "Data.Data.dataTypeOf(BigFloat)" instance NFData BigFloat where rnf x = x `seq` () diff --git a/src/LibBF/Mutable.hsc b/src/LibBF/Mutable.hsc --- a/src/LibBF/Mutable.hsc +++ b/src/LibBF/Mutable.hsc @@ -2,6 +2,7 @@ {-# Language PatternSynonyms #-} {-# Language MultiWayIf #-} {-# Language BlockArguments #-} +{-# Language DeriveDataTypeable #-} -- | Mutable big-float computation. module LibBF.Mutable ( -- * Allocation @@ -69,6 +70,7 @@ import Foreign.ForeignPtr import Foreign.C.Types import Foreign.C.String +import Data.Data (Data) import Data.Word import Data.Int import Data.Bits @@ -175,7 +177,7 @@ -- | Indicates if a number is positive or negative. data Sign = Neg {-^ Negative -} | Pos {-^ Positive -} - deriving (Eq,Ord,Show) + deriving (Data,Eq,Ord,Show) foreign import ccall "bf_set_nan" @@ -553,7 +555,7 @@ -- | An explicit representation for big nums. data BFRep = BFRep !Sign !BFNum -- ^ A signed number | BFNaN -- ^ Not a number - deriving (Eq,Ord,Show) + deriving (Data,Eq,Ord,Show) instance Hashable BFRep where hashWithSalt s BFNaN = s `hashWithSalt` (0::Int) @@ -564,7 +566,7 @@ data BFNum = Zero -- ^ zero | Num Integer !Int64 -- ^ @x * 2 ^ y@ | Inf -- ^ infinity - deriving (Eq,Ord,Show) + deriving (Data,Eq,Ord,Show) instance Hashable BFNum where hashWithSalt s Zero = s `hashWithSalt` (0::Int) diff --git a/tests/RunUnitTests.hs b/tests/RunUnitTests.hs --- a/tests/RunUnitTests.hs +++ b/tests/RunUnitTests.hs @@ -1,42 +1,63 @@ {-# Language BlockArguments #-} module Main(main) where -import Data.Foldable(traverse_) -import System.Exit(exitFailure) -import System.IO(hPutStrLn,stderr) -import Control.Monad(unless) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit ((@=?), assertFailure, testCase) import LibBF main :: IO () main = - do putStrLn $ bfToString 16 (showFree Nothing) bfNaN - print $ bfFromString 10 (expBits 3 <> precBits 2 <> rnd ToZero) "0.001" - print $ bfFromString 10 (expBits 3 <> precBits 2 <> rnd ToZero) "1.0e200" - dblTest "+" (+) (bfAdd (float64 NearEven)) 1 2 - dblTest "/" (/) (bfDiv (float64 NearEven)) 1 0 - traverse_ (\bf -> bfSubnormalTest bf False) - [bfPosZero, bfFromInt 1, bfFromInt 0, bfNaN, bfNegInf, bfPosInf] + defaultMain $ + testGroup "LibBF tests" + [ testGroup "bfToString" + [ testCase "NaN" $ + "NaN" @=? bfToString 16 (showFree Nothing) bfNaN + ] + , testGroup "bfFromString" + [ testCase "Underflow" $ + let (_, status) = + bfFromString 10 (expBits 3 <> precBits 2 <> rnd ToZero) "0.001" in + True @=? statusUnderflow status + , testCase "Overflow" $ + let (_, status) = + bfFromString 10 (expBits 3 <> precBits 2 <> rnd ToZero) "1.0e200" in + True @=? statusOverflow status + ] + , testGroup "bfAdd" + [ dblTestCase "+" (+) (bfAdd (float64 NearEven)) 1 2 + ] + , testGroup "bfDiv" + [ dblTestCase "/" (/) (bfDiv (float64 NearEven)) 1 0 + ] + , testGroup "bfIsSubnormal (float32 NearEven)" + (map (\bf -> bfSubnormalTestCase bf False) + [bfPosZero, bfFromInt 1, bfFromInt 0, bfNaN, bfNegInf, bfPosInf]) + ] -check :: String -> Bool -> IO () -check x b = unless b - do hPutStrLn stderr ("Test failed: " ++ x) - exitFailure +statusUnderflow :: Status -> Bool +statusUnderflow Underflow = True +statusUnderflow _ = False -dblTest :: +statusOverflow :: Status -> Bool +statusOverflow Overflow = True +statusOverflow _ = False + +-- Check that a binary operation over BigFloats returns the same result as the +-- corresponding operation over doubles. +dblTestCase :: String -> (Double -> Double -> Double) -> (BigFloat -> BigFloat -> (BigFloat, Status)) -> - Double -> Double -> IO () -dblTest op opD opBF x y = + Double -> Double -> TestTree +dblTestCase op opD opBF x y = + testCase (unwords [show x, op, show y]) $ case z1 of - Left err -> check (lab ("status: " ++ err)) False - Right a -> check (lab (show a)) (z == a) + Left err -> assertFailure ("status: " ++ err) + Right actual -> expected @=? actual where - lab err = unwords [ show x, op, show y, "=", show z, err ] - - z = opD x y + expected = opD x y z1 = case opBF (bfFromDouble x) (bfFromDouble y) of (res,_) -> case bfToDouble NearEven res of @@ -45,7 +66,7 @@ -- Check that calling bfIsSubnormal on a BigFloat value returns the expected -- result. -bfSubnormalTest :: BigFloat -> Bool -> IO () -bfSubnormalTest bf expected = - check ("bfIsSubnormal (float32 NearEven) " ++ show bf) - (bfIsSubnormal (float32 NearEven) bf == expected) +bfSubnormalTestCase :: BigFloat -> Bool -> TestTree +bfSubnormalTestCase bf expected = + testCase (show bf) $ + expected @=? bfIsSubnormal (float32 NearEven) bf