diff --git a/bv-little.cabal b/bv-little.cabal --- a/bv-little.cabal +++ b/bv-little.cabal @@ -1,5 +1,5 @@ name: bv-little -version: 1.0.0 +version: 1.0.1 synopsis: Efficient little-endian bit vector library category: Data, Bit Vectors license: BSD3 @@ -20,7 +20,8 @@ build-type: Simple cabal-version: >= 1.22 -tested-with: GHC == 8.6.2 +tested-with: GHC == 8.8.1 + GHC == 8.6.5 GHC == 8.4.4 GHC == 8.2.2 GHC == 8.0.2 @@ -50,7 +51,7 @@ if !impl(ghc >= 8.0) - build-depends: semigroups + build-depends: semigroups >= 0.18 && < 0.19 default-language: Haskell2010 @@ -103,7 +104,7 @@ main-is: TestSuite.hs - build-depends: base >= 4.5.1 && < 4.13 + build-depends: base >= 4.5.1 && < 5 , bv-little , deepseq , hashable @@ -119,7 +120,7 @@ if !impl(ghc >= 8.0) - build-depends: semigroups + build-depends: semigroups >= 0.18 && < 0.19 , transformers default-language: Haskell2010 @@ -138,7 +139,7 @@ main-is: Benchmarks.hs - build-depends: base >= 4.5.1 && < 4.13 + build-depends: base >= 4.5.1 && < 5 , bv-little , criterion , deepseq @@ -149,7 +150,7 @@ if !impl(ghc >= 8.0) - build-depends: semigroups + build-depends: semigroups >= 0.18 && < 0.19 default-language: Haskell2010 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -2,7 +2,13 @@ * None +### [v1.0.1][4] + * Correcting Eq instance to test for value equality and not construction equality + + * Updated unit tests do not fail when the antecedent of logical implication cannot be satisfied + + ### [v1.0.0][3] * Added explicit recursion to monomorphic folds to improve time and space performance @@ -65,3 +71,4 @@ [1]: https://github.com/recursion-ninja/bv-little/tree/v0.1.1 [2]: https://github.com/recursion-ninja/bv-little/tree/v0.1.2 [3]: https://github.com/recursion-ninja/bv-little/tree/v1.0.0 +[4]: https://github.com/recursion-ninja/bv-little/tree/v1.0.1 diff --git a/src/Data/BitVector/LittleEndian.hs b/src/Data/BitVector/LittleEndian.hs --- a/src/Data/BitVector/LittleEndian.hs +++ b/src/Data/BitVector/LittleEndian.hs @@ -87,7 +87,7 @@ import GHC.Integer.GMP.Internals import GHC.Integer.Logarithms import GHC.Natural -import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), NonNegative(..), suchThat, variant) +import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), NonNegative(..), choose, suchThat, variant) import TextShow (TextShow(showb)) @@ -117,13 +117,52 @@ -- @since 0.1.0 instance Arbitrary BitVector where + -- Arbitrary instance distribution weighting: + -- - 2% = (maxBound :: Word) + -- - 2% = (maxBound :: Word) + 1 + -- - 8% = all bits on + -- - 8% = all bits off + -- - 80% = any bit configuration arbitrary = do - dimVal <- getNonNegative <$> arbitrary - let upperBound = shiftL 1 dimVal - intVal <- (getNonNegative <$> arbitrary) `suchThat` (< upperBound) - pure . BV (toEnum dimVal) $ intToNat intVal + -- 1/25 chance of generating the boundary value at which the natural number + -- must use different Natural constructors: NatS# & NatJ# + n <- choose (0, 25 :: Word) + case n of + 0 -> boundaryValue + 1 -> allBitsOn + 2 -> allBitsOn + 3 -> allBitsOff + 4 -> allBitsOff + _ -> anyBitValue + where + allBitsOn = genBitVector $ Just True + allBitsOff = genBitVector $ Just False + anyBitValue = genBitVector $ Nothing + + boundaryValue = do + let wrdVal = maxBound :: Word + let dimVal = toEnum $ popCount wrdVal + let numVal = wordToNatural wrdVal + -- 50/50 change to generate above or below the constructor boundary + underBoundary <- arbitrary + let (lowerBound, naturalVal) + | underBoundary = (dimVal , numVal ) + | otherwise = (dimVal + 1, numVal + 1) + widthVal <- (getNonNegative <$> arbitrary) `suchThat` (>= lowerBound) + pure $ BV widthVal naturalVal + genBitVector spec = do + dimVal <- getNonNegative <$> arbitrary + let upperBound = shiftL 1 dimVal + -- 1/5 chance all bits on or all bits off + natVal <- case spec of + Just False -> pure $ intToNat 0 + Just True -> pure . intToNat $ upperBound - 1 + Nothing -> fmap intToNat $ + (getNonNegative <$> arbitrary) `suchThat` (< upperBound) + pure $ BV (toEnum dimVal) natVal + -- | -- @since 0.1.0 instance Bits BitVector where @@ -156,12 +195,12 @@ !mask = bit i `xor` allBits in BV w $ n .&. mask -{- {-# INLINE setBit #-} setBit bv@(BV w n) i - | i < 0 || i >= w = bv - | otherwise = BV w $ n `setBit` i --} + | i < 0 = bv + | otherwise = BV (max w j) $ n `setBit` i + where + !j = toEnum i + 1 {-# INLINE testBit #-} testBit (BV w n) i = i >= 0 && toEnum i < w && n `testBit` i @@ -238,7 +277,10 @@ instance Eq BitVector where {-# INLINE (==) #-} - (==) (BV w1 m) (BV w2 n) = w1 == w2 && m == n + (==) (BV w1 m) (BV w2 n) = w1 == w2 && naturalToBigNat m == naturalToBigNat n + where + naturalToBigNat (NatS# w ) = wordToBigNat w + naturalToBigNat (NatJ# bn) = bn -- | @@ -1112,7 +1154,9 @@ -- this function does not throw an exception when an negative valued 'Integer' -- is supplied and is also compatible with base < 4.10.0.0. {-# INLINE intToNat #-} +-- {-# NOINLINE intToNat #-} intToNat :: Integer -> Natural -intToNat (S# i#) | I# i# >= 0 = NatS# (int2Word# i#) -intToNat (Jp# bn) = NatJ# bn -intToNat _ = NatS# (int2Word# 0#) +intToNat (S# i#) | isTrue# (i# >=# 0#) = NatS# (int2Word# i#) +intToNat (Jp# bn) | isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn) + | otherwise = NatJ# bn +intToNat _ = NatS# (int2Word# 0#) diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -32,6 +32,11 @@ import TextShow (TextShow(showb), toString) +infix 0 -=> +(-=>) :: QC.Testable p => Bool -> p -> Property +(-=>) p q = not p .||. q + + main :: IO () main = defaultMain testSuite @@ -109,7 +114,7 @@ clearBitDefinition :: NonNegative Int -> BitVector -> Property clearBitDefinition (NonNegative i) bv = - i < (fromEnum . dimension) bv ==> + i < (fromEnum . dimension) bv -=> (bv `clearBit` i === bv .&. complement (zed .|. bit i)) where zed = fromNumber (dimension bv) (0 :: Integer) @@ -208,12 +213,12 @@ hashableTests :: TestTree hashableTests = testGroup "Properties of Hashable" [ localOption (QuickCheckTests 10000) - $ QC.testProperty "a == b ==> (hashWithSalt a) === (hashWithSalt b)" differentSaltsDifferentHashes + $ QC.testProperty "a == b -=> (hashWithSalt a) === (hashWithSalt b)" differentSaltsDifferentHashes ] where differentSaltsDifferentHashes :: BitVector -> Int -> Int -> Property differentSaltsDifferentHashes bv salt1 salt2 = - salt1 /= salt2 ==> hashWithSalt salt1 bv /= hashWithSalt salt2 bv + salt1 /= salt2 -=> hashWithSalt salt1 bv /= hashWithSalt salt2 bv @@ -299,13 +304,13 @@ testFoldr1 :: BinaryLogicalOperator -> BitVector -> Property -- testFoldr1 (Blind f) bv = testFoldr1 x bv = - (not . onull) bv ==> ofoldr1Ex f bv === (foldr1 f . otoList) bv + (not . onull) bv -=> ofoldr1Ex f bv === (foldr1 f . otoList) bv where f = getBinaryLogicalOperator x testFoldl1 :: Blind (Bool -> Bool -> Bool) -> BitVector -> Property testFoldl1 (Blind f) bv = - (not . onull) bv ==> ofoldl1Ex' f bv === (foldl1 f . otoList) bv + (not . onull) bv -=> ofoldl1Ex' f bv === (foldl1 f . otoList) bv testAll :: Blind (Bool -> Bool) -> BitVector -> Property testAll (Blind f) bv = @@ -325,11 +330,11 @@ testHead :: BitVector -> Property testHead bv = - (not . onull) bv ==> headEx bv === (getFirst . ofoldMap1Ex First) bv + (not . onull) bv -=> headEx bv === (getFirst . ofoldMap1Ex First) bv testTail :: BitVector -> Property testTail bv = - (not . onull) bv ==> lastEx bv === (getLast . ofoldMap1Ex Last) bv + (not . onull) bv -=> lastEx bv === (getLast . ofoldMap1Ex Last) bv testInclusionConsistency :: (Bool, BitVector) -> Property testInclusionConsistency (e, bv) = @@ -526,8 +531,8 @@ transitivity :: BitVector -> BitVector -> BitVector -> Property transitivity a b c = caseOne .||. caseTwo where - caseOne = (a <= b && b <= c) ==> a <= c - caseTwo = (a >= b && b >= c) ==> a >= c + caseOne = (a <= b && b <= c) -=> a <= c + caseTwo = (a >= b && b >= c) -=> a >= c semigroupProperties :: TestTree @@ -589,12 +594,12 @@ , testCase "isZeroVector zeroBits" zeroBitsIsZeroVector , QC.testProperty "isZeroVector === (0 ==) . popCount" popCountAndZeroVector , QC.testProperty "isZeroVector === all not . toBits" zeroVectorAndAllBitsOff - , QC.testProperty "(0 ==) . toUnsignedNumber ==> isZeroVector" toUnsignedNumImpliesZeroVector + , QC.testProperty "(0 ==) . toUnsignedNumber -=> isZeroVector" toUnsignedNumImpliesZeroVector , QC.testProperty "toSignedNumber . fromNumber === id" bitVectorUnsignedNumIdentity , QC.testProperty "isSigned == const False" noSignBitVector -- For an unknown reason, this test case causes GHC to panic! --- , QC.testProperty "i > j ==> subRange (i,j) === const zeroBits" badSubRangeEmptyResult - , QC.testProperty "i <= j ==> dimension . subRange (i,j) === const (j - i + 1)" subRangeFixedDimension +-- , QC.testProperty "i > j -=> subRange (i,j) === const zeroBits" badSubRangeEmptyResult + , QC.testProperty "i <= j -=> dimension . subRange (i,j) === const (j - i + 1)" subRangeFixedDimension ] where otoListTest :: BitVector -> Property @@ -627,7 +632,7 @@ toUnsignedNumImpliesZeroVector :: BitVector -> Property toUnsignedNumImpliesZeroVector bv = - ((0 ==) . (toUnsignedNumber :: BitVector -> Integer)) bv ==> isZeroVector bv + ((0 ==) . (toUnsignedNumber :: BitVector -> Integer)) bv -=> isZeroVector bv bitVectorUnsignedNumIdentity :: Integer -> Property bitVectorUnsignedNumIdentity num = @@ -641,11 +646,11 @@ badSubRangeEmptyResult :: (Word, Word) -> BitVector -> Property badSubRangeEmptyResult range@(lower, upper) bv = - lower > upper ==> subRange range bv === zeroBits + lower > upper -=> subRange range bv === zeroBits subRangeFixedDimension :: (NonNegative Int, NonNegative Int) -> BitVector -> Property subRangeFixedDimension (NonNegative lowerI, NonNegative upperI) bv = - lower <= upper ==> dimension (subRange (lower, upper) bv) === upper - lower + 1 + lower <= upper -=> dimension (subRange (lower, upper) bv) === upper - lower + 1 where lower = toEnum lowerI upper = toEnum upperI