diff --git a/bench/Benchmarks.hs b/bench/Benchmarks.hs --- a/bench/Benchmarks.hs +++ b/bench/Benchmarks.hs @@ -7,6 +7,7 @@ import Data.Bits import Data.BitVector.LittleEndian import Data.List (nubBy) +import Data.Hashable import Data.Semigroup @@ -15,11 +16,19 @@ benchmarks :: Benchmark benchmarks = bgroup "BitVector" - [ fromNumberBench + [ toBitsBench + , fromBitsBench + , fromNumberBench + , toSignedNumberBench + , toUnsignedNumberBench + , dimmensionBench , isZeroVectorBench , zeroPopCountBench + , subRangeBench , bitsBench , finiteBitsBench + , hashableBench + , semigroupBench ] @@ -63,11 +72,39 @@ hugeNumber = 14142135623730950488016887242096980785696718753769480731766797379907324784621070388503875343276415727350138462309122970249248360558507372126441214970999358314132226659275055927557999505011527820605715 +toBitsBench :: Benchmark +toBitsBench = unaryBenchmark "toBitsNumber" toBits + + +fromBitsBench :: Benchmark +fromBitsBench = constantNumberTimeBenchmark "fromBits" id g + where + g int n = let !bitCount = fromEnum $ logBase2Word int + bitStream = force $ foldMap (\i -> [testBit n i]) [0 .. bitCount - 1] + in fromBits bitStream + + fromNumberBench :: Benchmark fromNumberBench = constantNumberTimeBenchmark "fromNumber" id g where g int = let !bitCount = logBase2Word int in fromNumber bitCount + + +toSignedNumberBench :: Benchmark +toSignedNumberBench = unaryBenchmark "toSignedNumber" (toSignedNumber :: BitVector -> Integer) + + +toUnsignedNumberBench :: Benchmark +toUnsignedNumberBench = unaryBenchmark "toUnsignedNumber" (toUnsignedNumber :: BitVector -> Integer) + + +dimmensionBench :: Benchmark +dimmensionBench = constantNumberTimeBenchmark "dimmension" id g + where + g int _ = let !bitCount = logBase2Word int + !bitVector = fromNumber bitCount int + in dimension bitVector isZeroVectorBench :: Benchmark @@ -86,6 +123,16 @@ in ((0==) . popCount) bitVector +subRangeBench :: Benchmark +subRangeBench = constantNumberTimeBenchmark "subRange" id g + where + g int _ = let !bitCount = logBase2Word int + !bitVector = fromNumber bitCount int + !lowerBound = bitCount `div` 4 + !upperBound = (bitCount * 3) `div` 4 + in (lowerBound, upperBound) `subRange` bitVector + + bitsBench :: Benchmark bitsBench = bgroup "Bits" [ binaryBenchmark "(.|.)" (.|.) @@ -117,6 +164,19 @@ ] +hashableBench :: Benchmark +hashableBench = bgroup "Hashable" + [ unaryBenchmark "hash" hash + , indexingBenchmark "hashWithSalt" (flip hashWithSalt) + ] + + +semigroupBench :: Benchmark +semigroupBench = bgroup "Semigroup" + [ binaryBenchmark "(<>)" (<>) + ] + + constantNumberTimeBenchmark :: (NFData a, NFData b) => String -> (Integer -> a) -> (Integer -> a -> b) -> Benchmark constantNumberTimeBenchmark label f g = bgroup label $ generateBenchmark <$> magicNumbers where @@ -180,101 +240,3 @@ , ("large" , largeNumber) , ("huge" , hugeNumber) ] - -{- -invertBench :: Benchmark -invertBench = bench "MutualExclusionSet invert is constant-time" $ whnf invert $ force (ofSize 50) - - -isCoherentBench :: Benchmark -isCoherentBench = bench "MutualExclusionSet isCoherent is constant-time" $ whnf isCoherent $ force (ofSize 50) - - -isPermissibleBench :: Benchmark -isPermissibleBench = linearBenchmark "MutualExclusionSet isPermissible log-access" (force . ofSize) (const isPermissible) - - -isExcludedBench :: Benchmark -isExcludedBench = logBenchmark "MutualExclusionSet isExcluded log-access" ofSize f - where - -- We negate i to consider both the included and excluded cases - f i xs = (i `isExcluded` xs) `seq` negate i `isExcluded` xs - - -isIncludedBench :: Benchmark -isIncludedBench = logBenchmark "MutualExclusionSet isIncluded log-access" ofSize f - where - -- We negate i to consider both the included and excluded cases - f i xs = (i `isIncluded` xs) `seq` negate i `isIncluded` xs - - -excludedLookupBench :: Benchmark -excludedLookupBench = logBenchmark "MutualExclusionSet excludedLookup log-access" ofSize f - where - -- We negate i to consider both the included and excluded cases - f i xs = (i `excludedLookup` xs) `seq` negate i `excludedLookup` xs - - -includedLookupBench :: Benchmark -includedLookupBench = logBenchmark "MutualExclusionSet includedLookup log-access" ofSize f - where - -- We negate i to consider both the included and excluded cases - f i xs = (i `includedLookup` xs) `seq` negate i `includedLookup` xs - - -excludedSetBench :: Benchmark -excludedSetBench = linearBenchmark "MutualExclusionSet excludedSet linear access" (force . ofSize) (const excludedSet) - - -includedSetBench :: Benchmark -includedSetBench = linearBenchmark "MutualExclusionSet includedSet linear access" (force . ofSize) (const includedSet) - - -mutualExclusivePairsBench :: Benchmark -mutualExclusivePairsBench = linearBenchmark "MutualExclusionSet mutuallyExclusivePairs linear access" (force . ofSize) (const mutuallyExclusivePairs) - - -mergeBench :: Benchmark -mergeBench = linearBenchmark2 "merge (<>) is linear" (force . ofSize) (force . ofSizeEven) (const (<>)) - - -linearBenchmark :: (NFData a, NFData b) => String -> (Int -> a) -> (Int -> a -> b) -> Benchmark -linearBenchmark label f g = bgroup label $ generateBenchmark <$> [0 .. 9] - where - generateBenchmark expVal = bench (show domainSize) $ nf app target - where - !target = force $ f domainSize - !app = g expVal - domainSize = 10 * (expVal + 1) - - -linearBenchmark2 :: (NFData a, NFData b, NFData c) => String -> (Int -> a) -> (Int -> b) -> (Int -> a -> b -> c) -> Benchmark -linearBenchmark2 label f g h = bgroup label $ generateBenchmark <$> [0 .. 9] - where - generateBenchmark expVal = bench (show domainSize) $ nf app rhs - where - !lhs = force $ f domainSize - !rhs = force $ g domainSize - !app = h expVal lhs - domainSize = 10 * (expVal + 1) - - -logBenchmark :: String -> (Int -> a) -> (Int -> a -> b) -> Benchmark -logBenchmark label f g = bgroup label $ generateBenchmark <$> [0 .. 9] - where - generateBenchmark expVal = bench (show domainSize) $ whnf app target - where - !app = g indexpValrod - !target = f domainSize - indexpValrod = product [1..expVal] `mod` domainSize - domainSize = 2 `shiftL` expVal - - -ofSize :: Int -> MutualExclusionSet Int -ofSize n = unsafeFromList $ (\x -> (x, negate x)) <$> [1..n] - - -ofSizeEven :: Int -> MutualExclusionSet Int -ofSizeEven n = unsafeFromList $ (\x -> (x, negate x)) <$> [2,4..2*n] - --} 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: 0.1.0.0 +version: 0.1.1 synopsis: Efficient little-endian bit vector library category: Data, Bit Vectors license: BSD3 @@ -11,7 +11,7 @@ copyright: (c) Alex Washburn 2018 description: . - This package contains a time- and space- efficient implementation of little-endian bit vectors. Provides implementations of applicable typeclasses and numeric conversions. + This package contains a time- and space- efficient implementation of /little-endian/ bit vectors. Provides implementations of applicable typeclasses and numeric conversions. . The declared cost of each operation is either worst-case or amortized. . @@ -20,7 +20,7 @@ build-type: Simple cabal-version: >= 1.22 -tested-with: GHC == 8.4.1 +tested-with: GHC == 8.4.2 GHC == 8.2.2 GHC == 8.0.2 GHC == 7.10.3 @@ -36,7 +36,7 @@ library - build-depends: base >= 4.5.1 && < 4.11.1 + build-depends: base >= 4.5.1 && < 4.12 , deepseq , hashable , integer-gmp @@ -99,8 +99,9 @@ main-is: TestSuite.hs - build-depends: base >= 4.5.1 && < 4.11.1 + build-depends: base >= 4.5.1 && < 4.12 , bv-little + , deepseq , hashable , mono-traversable , QuickCheck @@ -124,10 +125,11 @@ main-is: Benchmarks.hs - build-depends: base >= 4.5.1 && < 4.11.1 + build-depends: base >= 4.5.1 && < 4.12 , bv-little , criterion , deepseq + , hashable if !impl(ghc >= 8.0) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,18 @@ -### v0.1.0.0 +### Unreleased changes + * None + +### [v0.1.1][1] + + * Updated to well-typed internal representation + + * Increased benchmark coverage + + * Increased test suite coverage + + +### [v0.1.0][0] + * Created instances of applicable typeclass instances * Added numeric conversion functions @@ -7,3 +20,7 @@ * Added basic test suite * Added stub benchmark + + +[0]: https://github.com/recursion-ninja/bv-little/tree/v0.1.0 +[1]: https://github.com/recursion-ninja/bv-little/tree/v0.1.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 @@ -71,15 +71,16 @@ import GHC.Generics import GHC.Integer.GMP.Internals import GHC.Integer.Logarithms -import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), NonNegative(..), suchThat) +import GHC.Natural +import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), NonNegative(..), suchThat, variant) -- | -- A little-endian bit vector of non-negative dimension. data BitVector = BV - { dim :: {-# UNPACK #-} !Int -- ^ The /dimension/ of a bit vector. - , nat :: !Integer -- ^ The value of a bit vector, as a natural number. + { dim :: {-# UNPACK #-} !Word -- ^ The /dimension/ of a bit vector. + , nat :: !Natural -- ^ The value of a bit vector, as a natural number. } deriving ( Data , Generic , Typeable @@ -97,9 +98,9 @@ arbitrary = do dimVal <- getNonNegative <$> arbitrary - let upperBound = 2^dimVal + let upperBound = shiftL 1 dimVal intVal <- (getNonNegative <$> arbitrary) `suchThat` (< upperBound) - pure $ BV dimVal intVal + pure . BV (toEnum dimVal) $ intToNat intVal -- | @@ -116,18 +117,23 @@ (BV w1 a) `xor` (BV w2 b) = BV (max w1 w2) $ a `xor` b {-# INLINE complement #-} - complement (BV w n) = BV w $ 2^w - 1 - n + complement (BV w n) = BV w $ (shiftL 1 (fromEnum w)) - 1 - n {-# INLINE zeroBits #-} zeroBits = BV 0 0 {-# INLINE bit #-} - bit i = BV (i+1) (2^i) + bit i = BV (succ $ toEnum i) (shiftL 1 i) {-# INLINE clearBit #-} + -- We do this more complicated operation rather than call 'clearBit' + -- because it is undefined for Natural in base < 4.10.0.0 clearBit bv@(BV w n) i - | i < 0 || i >= w = bv - | otherwise = BV w $ n `clearBit` i + | i < 0 || toEnum i >= w = bv + | otherwise = + let !allBits = pred . shiftL 1 $ fromEnum w + !mask = bit i `xor` allBits + in BV w $ n .&. mask {- {-# INLINE setBit #-} @@ -137,49 +143,63 @@ -} {-# INLINE testBit #-} - testBit (BV w n) i = i >= 0 && i < w && n `testBit` i + testBit (BV w n) i = i >= 0 && toEnum i < w && n `testBit` i - bitSize (BV w _) = w + bitSize (BV w _) = fromEnum w {-# INLINE bitSizeMaybe #-} - bitSizeMaybe (BV w _) = Just w + bitSizeMaybe (BV w _) = Just $ fromEnum w {-# INLINE isSigned #-} isSigned = const False {-# INLINE shiftL #-} shiftL (BV w n) k - | k > w = BV w 0 - | otherwise = BV w $ shiftL n k `mod` 2^w + | toEnum k > w = BV w 0 + | otherwise = BV w $ shiftL n k .&. pred (shiftL 1 (fromEnum w)) {-# INLINE shiftR #-} shiftR (BV w n) k - | k > w = BV w 0 - | otherwise = BV w $ shiftR n k + | toEnum k > w = BV w 0 + | otherwise = BV w $ shiftR n k {-# INLINE rotateL #-} - rotateL bv 0 = bv + rotateL bv 0 = bv + rotateL bv@(BV 0 _) _ = bv + rotateL bv@(BV 1 _) _ = bv rotateL bv@(BV w n) k - | 0 == w = bv - | k == w = BV w n - | k > w = rotateL (BV w n) (k `mod` w) - | otherwise = BV w $ h + l + | k < 0 = bv + | j >= w = go . fromEnum $ j `mod` w + | otherwise = go k where - s = w - k - l = n `shiftR` s - h = (n `shiftL` k) `mod` 2^w + !j = toEnum k + go 0 = bv + go !i = BV w $ h + l + where + !v = fromEnum w + !d = v - i + !m = pred $ shiftL 1 d + !l = n `shiftR` d + !h = (n .&. m) `shiftL` i {-# INLINE rotateR #-} - rotateR bv 0 = bv + rotateR bv 0 = bv + rotateR bv@(BV 0 _) _ = bv + rotateR bv@(BV 1 _) _ = bv rotateR bv@(BV w n) k - | 0 == w = bv - | k == w = bv - | k > w = rotateR (BV w n) (k `mod` w) - | otherwise = BV w $ h + l + | k < 0 = bv + | j >= w = go . fromEnum $ j `mod` w + | otherwise = go k where - s = w - k - l = n `shiftR` k - h = (n `shiftL` s) `mod` 2^w + !j = toEnum k + go 0 = bv + go !i = BV w $ h + l + where + !v = fromEnum w + !d = v - i + !m = pred $ shiftL 1 i + !l = n `shiftR` i + !h = (n .&. m) `shiftL` d {-# INLINE popCount #-} popCount = popCount . nat @@ -187,9 +207,11 @@ -- | -- /Since: 0.1.0.0/ -instance CoArbitrary BitVector +instance CoArbitrary BitVector where + coarbitrary bv = variant (dimension bv) + -- | -- /Since: 0.1.0.0/ instance Eq BitVector where @@ -203,27 +225,27 @@ instance FiniteBits BitVector where {-# INLINE finiteBitSize #-} - finiteBitSize = dim + finiteBitSize = fromEnum . dim {-# INLINE countTrailingZeros #-} - countTrailingZeros (BV w n) = max 0 $ w - lastSetBit - 1 + countTrailingZeros (BV w n) = max 0 $ fromEnum w - lastSetBit - 1 where - lastSetBit = I# (integerLog2# n) + lastSetBit = I# (integerLog2# (toInteger n)) {-# INLINE countLeadingZeros #-} - countLeadingZeros (BV w 0) = w - countLeadingZeros (BV w intVal) = - case intVal of - S# v -> countTrailingZeros $ iMask .|. I# v - Jp# (BN# v) -> f $ ByteArray v - Jn# (BN# v) -> f $ ByteArray v + countLeadingZeros (BV w 0) = fromEnum w + countLeadingZeros (BV w natVal) = + case natVal of + NatS# v -> countTrailingZeros $ iMask .|. W# v + NatJ# (BN# v) -> f $ ByteArray v where iMask = complement zeroBits `xor` (2 ^ w - 1) + !x = fromEnum w f :: ByteArray -> Int f byteArr = g 0 where - (q, r) = w `quotRem` 64 + (q, r) = x `quotRem` 64 wMask = complement zeroBits `xor` (2 ^ r - 1) :: Word64 g :: Int -> Int @@ -242,7 +264,7 @@ -- /Since: 0.1.0.0/ instance Hashable BitVector where - hash (BV w n) = w `hashWithSalt` hash n + hash (BV w n) = fromEnum w `hashWithSalt` hash n hashWithSalt salt bv = salt `hashWithSalt` hash bv @@ -287,14 +309,14 @@ onull = (== 0) . dim {-# INLINE olength #-} - olength = dim + olength = fromEnum . dim -- | -- /Since: 0.1.0.0/ instance MonoFunctor BitVector where - omap f (BV w n) = BV w . go w $ n `xor` n + omap f (BV w n) = BV w . go (fromEnum w) $ n `xor` n -- NB: 'setBit' is a GMP function, faster than regular addition. where go 0 !acc = acc @@ -344,20 +366,24 @@ instance Semigroup BitVector where {-# INLINE (<>) #-} - (<>) (BV x m) (BV y n) = BV (x + y) $ (n `shiftL` x) + m + (<>) (BV x m) (BV y n) = BV (x + y) $ (n `shiftL` fromEnum x) + m {-# INLINABLE sconcat #-} - sconcat xs = uncurry BV $ foldl' f (0,0) xs + sconcat xs = BV w' n' where - f (bitCount, natVal) (BV w n) = (bitCount + w, natVal + (n `shiftL` bitCount)) + (w', _, n') = foldl' f (0, 0, 0) xs + f (bitCountW, bitCountI, natVal) (BV w n) = + (bitCountW + w, bitCountI + fromEnum w, natVal + (n `shiftL` bitCountI)) {-# INLINE stimes #-} stimes 0 _ = mempty - stimes e (BV w n) = BV limit $ go (limit - w) n + stimes e (BV w n) = BV limit $ go start n where - limit = fromEnum e * w + !x = fromEnum w + !start = fromEnum $ limit - w + !limit = (toEnum . fromEnum) e * w go 0 !acc = acc - go !k !acc = go (k-w) $ (n `shiftL` k) + acc + go !k !acc = go (k-x) $ (n `shiftL` k) + acc -- | @@ -385,7 +411,7 @@ -- [3]1 {-# INLINE fromBits #-} fromBits :: Foldable f => f Bool -> BitVector -fromBits bs = BV n k +fromBits bs = BV (toEnum n) k -- NB: 'setBit' is a GMP function, faster than regular addition. where (!n, !k) = foldl' go (0, 0) bs @@ -412,7 +438,7 @@ -- [True, True, False, True] {-# INLINE toBits #-} toBits :: BitVector -> [Bool] -toBits (BV w n) = testBit n <$> [ 0 .. w - 1 ] +toBits (BV w n) = testBit n <$> [ 0 .. fromEnum w - 1 ] -- | @@ -450,14 +476,13 @@ => Word -- ^ dimension of bit vector -> v -- ^ /signed, little-endian/ integral value -> BitVector -fromNumber !dimValue !intValue = BV width $ mask .&. v +fromNumber !dimValue !intValue = BV dimValue . intToNat $ mask .&. v where - !v | signum int < 0 = negate $ 2^intBits - int + !v | signum int < 0 = negate $ (shiftL 1 intBits) - int | otherwise = int !int = toInteger intValue !intBits = I# (integerLog2# int) - !width = fromEnum dimValue !mask = 2 ^ dimValue - 1 @@ -491,8 +516,9 @@ toSignedNumber :: Num a => BitVector -> a toSignedNumber (BV w n) = fromInteger v where - v | n `testBit` (w-1) = negate $ 2^w - n - | otherwise = n + !i = toInteger n + !v | n `testBit` (fromEnum w - 1) = negate $ (shiftL 1 (fromEnum w)) - i + | otherwise = i -- | @@ -523,7 +549,7 @@ -- 15 {-# INLINE toUnsignedNumber #-} toUnsignedNumber :: Num a => BitVector -> a -toUnsignedNumber = fromInteger . nat +toUnsignedNumber = fromInteger . toInteger . nat -- | @@ -544,7 +570,7 @@ -- 4 {-# INLINE dimension #-} dimension :: BitVector -> Word -dimension = toEnum . dim +dimension = dim -- | @@ -598,7 +624,37 @@ subRange :: (Word, Word) -> BitVector -> BitVector subRange (!lower, !upper) (BV _ n) | lower > upper = zeroBits - | otherwise = BV m $ (n `shiftR` i) `mod` 2^m + | otherwise = + case toInt lower of + Nothing -> zeroBits + Just i -> + let b = n `shiftR` i + in case toInt upper of + Nothing -> + let m = toEnum $ maxBound - i + 1 + in BV m $ n `shiftR` i + Just j -> + let x = j - i + m | x == maxBound = x + | otherwise = x + 1 + in BV (toEnum m) $ b .&. pred (1 `shiftL` m) + + +toInt :: Word -> Maybe Int +toInt w + | w > maxInt = Nothing + | otherwise = Just $ fromEnum w where - i = fromEnum lower - m = fromEnum $ upper - lower + 1 + maxInt = toEnum (maxBound :: Int) + + + +-- | +-- While similar to the function 'naturalFromInteger' exported from GHC.Natural, +-- 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 #-} +intToNat :: Integer -> Natural +intToNat (S# i#) | I# i# >= 0 = NatS# (int2Word# i#) +intToNat (Jp# bn) = NatJ# bn +intToNat _ = NatS# (int2Word# 0#) diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -1,7 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} +-- We apply this to suppress the deprecated warning cause by calls to 'bitSize' +-- If there is a more fine-grained way to supress this warning without suppressing +-- deprecated warnings for the whole module, we should do that instead. +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + module Main ( main ) where +import Control.DeepSeq import Data.Bits import Data.BitVector.LittleEndian import Data.Functor.Compose @@ -29,8 +35,10 @@ , monoFoldableProperties , monoidProperties , monoTraversableProperties + , normalFormDataProperties , orderingProperties , semigroupProperties + , showProperties , bitVectorProperties ] @@ -294,6 +302,7 @@ [ testProperty "t . otraverse f === otraverse (t . f)" testNaturality , testProperty "otraverse Identity === Identity" testIdentity , testProperty "otraverse (Compose . fmap g . f) === Compose . fmap (otraverse g) . otraverse f" testComposition + , testProperty "otraverse === omapM" testDefinitionEquality ] where testNaturality :: Blind (Bool -> [Bool]) -> BitVector -> Property @@ -308,7 +317,21 @@ testComposition (Blind f) (Blind g) bv = otraverse (Compose . fmap g . f) bv === (Compose . fmap (otraverse g) . otraverse f) bv + testDefinitionEquality :: Blind (Bool -> Maybe Bool) -> BitVector -> Property + testDefinitionEquality (Blind f) bv = + otraverse f bv === omapM f bv + +normalFormDataProperties :: TestTree +normalFormDataProperties = testGroup "Properties of NFData" + [ testProperty "rnf result is finite" finiteReduction + ] + where + finiteReduction :: BitVector -> Property + finiteReduction bv = + rnf bv === () + + orderingProperties :: TestTree orderingProperties = testGroup "Properties of an Ordering" [ testProperty "ordering preserves symetry" symetry @@ -355,6 +378,21 @@ stimes i bv === (mconcat . replicate i) bv +showProperties :: TestTree +showProperties = testGroup "Properties of Show" + [ testProperty "show result is finite" finiteString + , testProperty "show result is non-null" nonNullString + ] + where + finiteString :: BitVector -> Property + finiteString bv = + show bv === show bv + + nonNullString :: BitVector -> Bool + nonNullString = + not . null . show + + bitVectorProperties :: TestTree bitVectorProperties = testGroup "BitVector properties" [ testProperty "otoList === toBits" otoListTest @@ -367,6 +405,9 @@ , testProperty "(0 ==) . toUnsignedNumber ==> isZeroVector" toUnsignedNumImpliesZeroVector , testProperty "toSignedNumber . fromNumber === id" bitVectorUnsignedNumIdentity , testProperty "isSigned == const False" noSignBitVector +-- For an unknown reason, this test case causes GHC to panic! +-- , testProperty "i > j ==> subRange (i,j) === const zeroBits" badSubRangeEmptyResult + , testProperty "i <= j ==> dimension . subRange (i,j) === const (j - i + 1)" subRangeFixedDimension ] where otoListTest :: BitVector -> Property @@ -410,3 +451,14 @@ noSignBitVector :: BitVector -> Property noSignBitVector bv = isSigned bv === False + + badSubRangeEmptyResult :: (Word, Word) -> BitVector -> Property + badSubRangeEmptyResult range@(lower, upper) bv = + 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 + where + lower = toEnum lowerI + upper = toEnum upperI