bv-little (empty) → 0.1.0.0
raw patch · 9 files changed
+1594/−0 lines, 9 filesdep +QuickCheckdep +basedep +bv-littlesetup-changed
Dependencies added: QuickCheck, base, bv-little, criterion, deepseq, hashable, integer-gmp, mono-traversable, primitive, semigroups, tasty, tasty-hunit, tasty-quickcheck, transformers
Files
- LICENSE +29/−0
- README.md +37/−0
- Setup.hs +2/−0
- bench/Benchmarks.hs +280/−0
- bv-little.cabal +155/−0
- changelog.md +9/−0
- src/Data/BitVector/LittleEndian.hs +604/−0
- stack.yaml +66/−0
- test/TestSuite.hs +412/−0
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2018, Alex Washburn+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,37 @@+## Efficient little-endian bit vector Haskell library++[](https://travis-ci.org/recursion-ninja/bv-little)+[](https://coveralls.io/github/recursion-ninja/bv-little?branch=master)+[](http://opensource.org/licenses/BSD-3-Clause)+[](https://hackage.haskell.org/package/bv-little)+[](http://stackage.org/nightly/package/bv-little)+[](http://stackage.org/lts/package/bv-little)+++This package contains an efficient implementation of little-endian bit vectors. It implements most applicable typeclasses and also conversions to and from signed or unsigned numbers. Care has been taken to balance the number of transitive dependencies with respect to functionality provided.++For an implementation of big-endian bit vectors, use the [`bv`](https://hackage.haskell.org/package/bv) package.++#### Tests++The test suite ensures that all typeclass instances are "lawful" and that data-structure–specific functionality is well defined.++The `TestSuite.hs` file contains the specification. It can be run by invoking any of the following commands:++ * `cabal new-test`++ * `cabal test`++ * `stack test`++#### Benchmarks++The benchmarks provide an empirical check for the asymptotic complexity of data structure operations and also provide easy metrics for detecting performance regressions.++The `Benchmaks.hs` file contains these metrics. It can be run by invoking any of the following commands:++ * `cabal new-bench`++ * `cabal bench`++ * `stack bench`
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Benchmarks.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE BangPatterns #-}++module Main (main) where++import Control.DeepSeq+import Criterion.Main+import Data.Bits+import Data.BitVector.LittleEndian+import Data.List (nubBy)+import Data.Semigroup+++main :: IO ()+main = defaultMain [ benchmarks ]++benchmarks :: Benchmark+benchmarks = bgroup "BitVector"+ [ fromNumberBench+ , isZeroVectorBench+ , zeroPopCountBench+ , bitsBench+ , finiteBitsBench+ ]+++-- |+-- This number is the first 10-digit prime in e. It is used as a "no trick up my sleeve" arbitrary large number.+--+-- ceiling ( log_2 (prime) ) === 33+tinyNumber :: Integer+tinyNumber = 7427466391+++-- |+-- This number is phi * 10^20. It is used as a "no trick up my sleeve" arbitrary large number.+--+-- ceiling ( log_2 (phi * 10^20) ) === 68+smallNumber :: Integer+smallNumber = 161803398874989484820+++-- |+-- This number is e * 10^50. It is used as a "no trick up my sleeve" arbitrary large number.+--+-- ceiling ( log_2 (e * 10^50) ) === 168+mediumNumber :: Integer+mediumNumber = 271828182845904523536028747135266249775724709369995+++-- |+-- This number is pi * 10^100. It is used as a "no trick up my sleeve" arbitrary large number.+--+-- ceiling ( log_2 (pi * 10^100) ) === 334+largeNumber :: Integer+largeNumber = 31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679+++-- |+-- This number is -1 * √2 * 10^200. It is used as a "no trick up my sleeve" arbitrary large negative number.+--+-- ceiling ( log_2 (√2 * 10^200) ) === 665+hugeNumber :: Integer+hugeNumber = 14142135623730950488016887242096980785696718753769480731766797379907324784621070388503875343276415727350138462309122970249248360558507372126441214970999358314132226659275055927557999505011527820605715+++fromNumberBench :: Benchmark+fromNumberBench = constantNumberTimeBenchmark "fromNumber" id g+ where+ g int = let !bitCount = logBase2Word int+ in fromNumber bitCount+ ++isZeroVectorBench :: Benchmark+isZeroVectorBench = constantNumberTimeBenchmark "isZeroVector" id g+ where+ g int _ = let !bitCount = logBase2Word int+ !bitVector = fromNumber bitCount int+ in isZeroVector bitVector+ ++zeroPopCountBench :: Benchmark+zeroPopCountBench = constantNumberTimeBenchmark "popCount is zero" id g+ where+ g int _ = let !bitCount = logBase2Word int+ !bitVector = fromNumber bitCount int+ in ((0==) . popCount) bitVector+ ++bitsBench :: Benchmark+bitsBench = bgroup "Bits"+ [ binaryBenchmark "(.|.)" (.|.)+ , binaryBenchmark "(.&.)" (.&.)+ , binaryBenchmark "xor" xor+ , unaryBenchmark "complement" complement+-- , unaryBenchmark "bitSize" bitSize+ , unaryBenchmark "bitSizeMaybe" bitSizeMaybe+ , unaryBenchmark "isSigned" isSigned+ , unaryBenchmark "popCount" popCount+ , indexingBenchmark "shift" shift+ , indexingBenchmark "shiftL" shiftL+ , indexingBenchmark "shiftR" shiftR+ , indexingBenchmark "rotate" rotate+ , indexingBenchmark "rotateL" rotateL+ , indexingBenchmark "rotateR" rotateR+ , indexingBenchmark "setBit" setBit+ , indexingBenchmark "clearBit" clearBit+ , indexingBenchmark "complementBit" complementBit+ , indexingBenchmark "testBit" testBit+ ]+++finiteBitsBench :: Benchmark+finiteBitsBench = bgroup "FiniteBits"+ [ unaryBenchmark "finiteBitSize" finiteBitSize+ , unaryBenchmark "countLeadingZeros" countLeadingZeros+ , unaryBenchmark "countTrailingZeros" countLeadingZeros+ ]+++constantNumberTimeBenchmark :: (NFData a, NFData b) => String -> (Integer -> a) -> (Integer -> a -> b) -> Benchmark+constantNumberTimeBenchmark label f g = bgroup label $ generateBenchmark <$> magicNumbers+ where+ generateBenchmark (intLabel, intValue) = bench intLabel $ nf app target+ where+ !target = force $ f intValue+ !app = g intValue++ +unaryBenchmark :: NFData a => String -> (BitVector -> a) -> Benchmark+unaryBenchmark label f = bgroup label $ generateBenchmark <$> magicNumbers+ where+ generateBenchmark (intLabel, intValue) = bench intLabel $ nf f target+ where+ !target = bvGen intValue++ +binaryBenchmark :: NFData a => String -> (BitVector -> BitVector -> a) -> Benchmark+binaryBenchmark label op = bgroup label $ generateBenchmark <$> combinations+ where+ generateBenchmark (intLabel1, intValue1, intLabel2, intValue2) = bench message $ nf id target+ where+ message = unwords [intLabel1, "`op`", intLabel2]+ !lhs = bvGen intValue1+ !rhs = bvGen intValue2+ target = lhs `op` rhs+ combinations = [ (a,b,c,d) | (a,b) <- magicNumbers, (c,d) <- magicNumbers, b < d ]+++indexingBenchmark :: NFData a => String -> (BitVector -> Int -> a) -> Benchmark+indexingBenchmark label op = bgroup label $ generateBenchmark <$> combinations+ where+ generateBenchmark (intLabel, intValue, idxLabel, idxValue) = bench message $ nf app target+ where+ message = unwords [intLabel, "@", idxLabel <> ":" <> show idxValue]+ !target = bvGen intValue+ app = (`op` idxValue)++ combinations = do+ (a, b) <- magicNumbers+ let bitCount = fromEnum $ logBase2Word b+ (c, d) <- nubBy (\x y -> snd x == snd y) [("first", 0), ("middle", bitCount `div` 2), ("last", bitCount - 1)]+ let e = force (a,b,c,d)+ [e]+++bvGen :: Integer -> BitVector+bvGen x = force $ fromNumber (logBase2Word x) x+++logBase2Word :: Integer -> Word+logBase2Word = succ . succ . ceiling . logBase (2.0 :: Double) . fromIntegral . abs+++magicNumbers :: [(String, Integer)]+magicNumbers =+ [ ("zero" , 0)+ , ("tiny" , tinyNumber)+ , ("small" , smallNumber)+ , ("medium", mediumNumber)+ , ("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]++-}
+ bv-little.cabal view
@@ -0,0 +1,155 @@+name: bv-little+version: 0.1.0.0+synopsis: Efficient little-endian bit vector library+category: Data, Bit Vectors+license: BSD3+license-file: LICENSE+author: Alex Washburn+maintainer: hackage@recursion.ninja+homepage: https://github.com/recursion-ninja/bv-little+bug-reports: https://github.com/recursion-ninja/bv-little/issues+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.+ .+ The declared cost of each operation is either worst-case or amortized.+ .+ For an implementation of /big-endian/ bit vectors, use the <https://hackage.haskell.org/package/bv bv> package.++build-type: Simple+cabal-version: >= 1.22++tested-with: GHC == 8.4.1+ GHC == 8.2.2+ GHC == 8.0.2+ GHC == 7.10.3++extra-source-files: changelog.md+ README.md+ stack.yaml++source-repository head+ type: git+ location: https://github.com/recursion-ninja/bv-little+++library++ build-depends: base >= 4.5.1 && < 4.11.1+ , deepseq+ , hashable+ , integer-gmp+ , mono-traversable+ , primitive+ , QuickCheck++ if !impl(ghc >= 8.0)++ build-depends: semigroups++ default-language: Haskell2010++ exposed-modules: Data.BitVector.LittleEndian++ ghc-options: -O2++ -- Sanity check warnings+ -Wall+ -fwarn-dodgy-foreign-imports+ -fwarn-incomplete-record-updates+ -fwarn-incomplete-uni-patterns+ -fwarn-overlapping-patterns++ -fwarn-duplicate-exports+ -fwarn-identities+ -fwarn-incomplete-patterns+ -fwarn-incomplete-record-updates+ -fwarn-incomplete-uni-patterns+ -fwarn-missing-fields+ -fwarn-missing-signatures+ -fwarn-overlapping-patterns+ -fwarn-tabs+ -fwarn-unused-binds+ -fwarn-unused-do-bind+ -fwarn-unused-imports+ -fwarn-unused-matches+ -fwarn-wrong-do-bind++ if impl(ghc >= 7.8)++ ghc-options: -fwarn-empty-enumerations+ -fwarn-overflowed-literals++ if impl(ghc >= 8.0)++ ghc-options: -Wcompat+ -fwarn-noncanonical-monoid-instances+ -fwarn-redundant-constraints+ -fwarn-semigroup+ -fwarn-unrecognised-warning-flags+ -fwarn-unused-foralls++ hs-source-dirs: src+++Test-Suite test-suite++ type: exitcode-stdio-1.0++ main-is: TestSuite.hs++ build-depends: base >= 4.5.1 && < 4.11.1+ , bv-little+ , hashable+ , mono-traversable+ , QuickCheck+ , tasty+ , tasty-hunit+ , tasty-quickcheck++ if !impl(ghc >= 8.0)++ build-depends: semigroups+ , transformers++ default-language: Haskell2010++ hs-source-dirs: test+++benchmark benchmark-suite++ type: exitcode-stdio-1.0++ main-is: Benchmarks.hs++ build-depends: base >= 4.5.1 && < 4.11.1+ , bv-little+ , criterion+ , deepseq++ if !impl(ghc >= 8.0)++ build-depends: semigroups++ default-language: Haskell2010++ ghc-options: -O2+ -threaded+ -fdicts-cheap+ -fmax-simplifier-iterations=10+ -fno-full-laziness+ -fspec-constr-count=6++ -- Sanity check warnings+ -Wall+ -fwarn-dodgy-foreign-imports+ -fwarn-incomplete-record-updates+ -fwarn-incomplete-uni-patterns+ -fwarn-overlapping-patterns++ -- Turn off type default warnings+ -fno-warn-type-defaults++ hs-source-dirs: bench
+ changelog.md view
@@ -0,0 +1,9 @@+### v0.1.0.0++ * Created instances of applicable typeclass instances++ * Added numeric conversion functions++ * Added basic test suite++ * Added stub benchmark
+ src/Data/BitVector/LittleEndian.hs view
@@ -0,0 +1,604 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.BitVector.LittleEndian+-- Copyright : (c) Alex Washburn 2018+-- License : BSD-style+--+-- Maintainer : github@recursion.ninja+-- Stability : provisional+-- Portability : portable+--+-- A bit vector similar to @Data.BitVector@ from the+-- <https://hackage.haskell.org/package/bv bv>, however the endianness is+-- reversed. This module defines /little-endian/ pseudo–size-polymorphic+-- bit vectors.+--+-- Little-endian bit vectors are isomorphic to a @[Bool]@ with the /least/+-- significant bit at the head of the list and the /most/ significant bit at the+-- end of the list. Consequently, the endianness of a bit vector affects the semantics of the+-- following typeclasses:+--+-- * 'Bits'+-- * 'FiniteBits'+-- * 'Semigroup'+-- * 'Monoid'+-- * 'MonoFoldable'+-- * 'MonoTraversable'+--+-- For an implementation of bit vectors which are isomorphic to a @[Bool]@ with the /most/+-- significant bit at the head of the list and the /least/ significant bit at the+-- end of the list, use the+-- <https://hackage.haskell.org/package/bv bv> package.+--+-- This module does /not/ define numeric instances for 'BitVector'. This is+-- intentional! To interact with a bit vector as an 'Integral' value,+-- convert the 'BitVector' using either 'toSignedNumber' or 'toUnsignedNumber'.+--+-----------------------------------------------------------------------------++{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, MagicHash #-}+{-# LANGUAGE Trustworthy, TypeFamilies #-}++module Data.BitVector.LittleEndian+ ( BitVector()+ -- * Bit-stream conversion+ , fromBits+ , toBits+ -- * Numeric conversion+ , fromNumber+ , toSignedNumber+ , toUnsignedNumber+ -- * Queries+ , dimension+ , isZeroVector+ , subRange+ ) where+++import Control.DeepSeq+import Data.Bits+import Data.Data+import Data.Foldable+import Data.Hashable+import Data.List.NonEmpty (NonEmpty(..))+import Data.Monoid ()+import Data.MonoTraversable+import Data.Ord+import Data.Primitive.ByteArray+import Data.Semigroup+import Data.Word+import GHC.Exts+import GHC.Generics+import GHC.Integer.GMP.Internals+import GHC.Integer.Logarithms+import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), NonNegative(..), suchThat)+++-- |+-- 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.+ } deriving ( Data+ , Generic+ , Typeable+ )+++-- |+-- /Since: 0.1.0.0/+type instance Element BitVector = Bool+++-- |+-- /Since: 0.1.0.0/+instance Arbitrary BitVector where++ arbitrary = do+ dimVal <- getNonNegative <$> arbitrary+ let upperBound = 2^dimVal+ intVal <- (getNonNegative <$> arbitrary) `suchThat` (< upperBound)+ pure $ BV dimVal intVal+++-- |+-- /Since: 0.1.0.0/+instance Bits BitVector where++ {-# INLINE (.&.) #-}+ (BV w1 a) .&. (BV w2 b) = BV (max w1 w2) $ a .&. b++ {-# INLINE (.|.) #-}+ (BV w1 a) .|. (BV w2 b) = BV (max w1 w2) $ a .|. b++ {-# INLINE xor #-}+ (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++ {-# INLINE zeroBits #-}+ zeroBits = BV 0 0++ {-# INLINE bit #-}+ bit i = BV (i+1) (2^i)++ {-# INLINE clearBit #-}+ clearBit bv@(BV w n) i+ | i < 0 || i >= w = bv+ | otherwise = BV w $ n `clearBit` i++{-+ {-# INLINE setBit #-}+ setBit bv@(BV w n) i+ | i < 0 || i >= w = bv+ | otherwise = BV w $ n `setBit` i+-}++ {-# INLINE testBit #-}+ testBit (BV w n) i = i >= 0 && i < w && n `testBit` i++ bitSize (BV w _) = w++ {-# INLINE bitSizeMaybe #-}+ bitSizeMaybe (BV w _) = Just 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++ {-# INLINE shiftR #-}+ shiftR (BV w n) k+ | k > w = BV w 0+ | otherwise = BV w $ shiftR n k++ {-# INLINE rotateL #-}+ rotateL bv 0 = 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+ where+ s = w - k+ l = n `shiftR` s+ h = (n `shiftL` k) `mod` 2^w++ {-# INLINE rotateR #-}+ rotateR bv 0 = 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+ where+ s = w - k+ l = n `shiftR` k+ h = (n `shiftL` s) `mod` 2^w++ {-# INLINE popCount #-}+ popCount = popCount . nat+++-- |+-- /Since: 0.1.0.0/+instance CoArbitrary BitVector+++-- |+-- /Since: 0.1.0.0/+instance Eq BitVector where++ {-# INLINE (==) #-}+ (==) (BV w1 m) (BV w2 n) = w1 == w2 && m == n+++-- |+-- /Since: 0.1.0.0/+instance FiniteBits BitVector where++ {-# INLINE finiteBitSize #-}+ finiteBitSize = dim++ {-# INLINE countTrailingZeros #-}+ countTrailingZeros (BV w n) = max 0 $ w - lastSetBit - 1+ where+ lastSetBit = I# (integerLog2# 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+ where+ iMask = complement zeroBits `xor` (2 ^ w - 1)++ f :: ByteArray -> Int+ f byteArr = g 0+ where+ (q, r) = w `quotRem` 64+ wMask = complement zeroBits `xor` (2 ^ r - 1) :: Word64++ g :: Int -> Int+ g !i+ | i >= q = countTrailingZeros $ wMask .|. value+ | otherwise =+ case countTrailingZeros value of+ 64 -> 64 + g (i+1)+ v -> v+ where+ value :: Word64+ value = byteArr `indexByteArray` i+++-- |+-- /Since: 0.1.0.0/+instance Hashable BitVector where++ hash (BV w n) = w `hashWithSalt` hash n++ hashWithSalt salt bv = salt `hashWithSalt` hash bv+++-- |+-- /Since: 0.1.0.0/+instance Monoid BitVector where++ {-# INLINE mappend #-}+ mappend = (<>)++ {-# INLINE mconcat #-}+ mconcat bs =+ case bs of+ [] -> mempty+ x:xs -> sconcat $ x:|xs++ {-# INLINE mempty #-}+ mempty = BV 0 0+++-- |+-- /Since: 0.1.0.0/+instance MonoFoldable BitVector where++ {-# INLINE ofoldMap #-}+ ofoldMap f = mconcat . fmap f. toBits++ {-# INLINE ofoldr #-}+ ofoldr f e = foldr f e . toBits++ {-# INLINE ofoldl' #-}+ ofoldl' f e = foldl' f e . toBits++ {-# INLINE ofoldr1Ex #-}+ ofoldr1Ex f = foldr1 f . toBits++ {-# INLINE ofoldl1Ex' #-}+ ofoldl1Ex' f = foldl1 f . toBits++ {-# INLINE onull #-}+ onull = (== 0) . dim++ {-# INLINE olength #-}+ olength = dim+++-- |+-- /Since: 0.1.0.0/+instance MonoFunctor BitVector where++ omap f (BV w n) = BV w . go w $ n `xor` n+ -- NB: 'setBit' is a GMP function, faster than regular addition.+ where+ go 0 !acc = acc+ go !i !acc = go i' acc'+ where+ i' = i - 1+ acc'+ | f (testBit n i') = acc `setBit` i'+ | otherwise = acc++++-- |+-- /Since: 0.1.0.0/+instance MonoTraversable BitVector where++ {-# INLINE otraverse #-}+ otraverse f = fmap fromBits . traverse f . toBits++ {-# INLINE omapM #-}+ omapM = otraverse+++-- |+-- /Since: 0.1.0.0/+instance NFData BitVector where++ -- Already a strict data type,+ -- always in normal form.+ {-# INLINE rnf #-}+ rnf = const ()+++-- |+-- /Since: 0.1.0.0/+instance Ord BitVector where++ {-# INLINE compare #-}+ compare lhs rhs =+ case comparing dim lhs rhs of+ EQ -> comparing nat lhs rhs+ v -> v+++-- |+-- /Since: 0.1.0.0/+instance Semigroup BitVector where++ {-# INLINE (<>) #-}+ (<>) (BV x m) (BV y n) = BV (x + y) $ (n `shiftL` x) + m++ {-# INLINABLE sconcat #-}+ sconcat xs = uncurry BV $ foldl' f (0,0) xs+ where+ f (bitCount, natVal) (BV w n) = (bitCount + w, natVal + (n `shiftL` bitCount))++ {-# INLINE stimes #-}+ stimes 0 _ = mempty+ stimes e (BV w n) = BV limit $ go (limit - w) n+ where+ limit = fromEnum e * w+ go 0 !acc = acc+ go !k !acc = go (k-w) $ (n `shiftL` k) + acc+++-- |+-- /Since: 0.1.0.0/+instance Show BitVector where++ show (BV w n) = mconcat [ "[", show w, "]", show n ]+++-- |+-- Create a bit vector from a /little-endian/ list of bits.+--+-- The following will hold:+--+-- > length . takeWhile not === countLeadingZeros . fromBits+-- > length . takeWhile not . reverse === countTrailingZeros . fromBits+--+-- /Time:/ \(\, \mathcal{O} \left( n \right) \)+--+-- /Since: 0.1.0.0/+--+-- ==== __Examples__+--+-- >>> fromBits [True, False, False]+-- [3]1+{-# INLINE fromBits #-}+fromBits :: Foldable f => f Bool -> BitVector+fromBits bs = BV n k+ -- NB: 'setBit' is a GMP function, faster than regular addition.+ where+ (!n, !k) = foldl' go (0, 0) bs+ go (!i, !v) b+ | b = (i+1, setBit v i)+ | otherwise = (i+1, v)+++-- |+-- Create a /little-endian/ list of bits from a bit vector.+--+-- The following will hold:+--+-- > length . takeWhile not . toBits === countLeadingZeros+-- > length . takeWhile not . reverse . toBits === countTrailingZeros+--+-- /Time:/ \(\, \mathcal{O} \left( n \right) \)+--+-- /Since: 0.1.0.0/+--+-- ==== __Examples__+--+-- >>> toBits [4]11+-- [True, True, False, True]+{-# INLINE toBits #-}+toBits :: BitVector -> [Bool]+toBits (BV w n) = testBit n <$> [ 0 .. w - 1 ]+++-- |+-- Create a bit vector of non-negative dimension from an integral value.+--+-- The integral value will be treated as an /signed/ number and the resulting+-- bit vector will contain the two's complement bit representation of the number.+--+-- The integral value will be interpreted as /little-endian/ so that the least+-- significant bit of the integral value will be the value of the 0th index of+-- the resulting bit vector and the most significant bit of the integral value+-- will be at index @dimension − 1@.+--+-- Note that if the bit representation of the integral value exceeds the+-- supplied dimension, then the most significant bits will be truncated in the+-- resulting bit vector.+--+-- /Time:/ \(\, \mathcal{O} \left( 1 \right) \)+--+-- /Since: 0.1.0.0/+--+-- ==== __Examples__+--+-- >>> fromNumber 8 96+-- [8]96+--+-- >>> fromNumber 8 -96+-- [8]160+--+-- >>> fromNumber 6 96+-- [6]32+{-# INLINE fromNumber #-}+fromNumber+ :: Integral v+ => Word -- ^ dimension of bit vector+ -> v -- ^ /signed, little-endian/ integral value+ -> BitVector+fromNumber !dimValue !intValue = BV width $ mask .&. v+ where+ !v | signum int < 0 = negate $ 2^intBits - int+ | otherwise = int++ !int = toInteger intValue+ !intBits = I# (integerLog2# int)+ !width = fromEnum dimValue+ !mask = 2 ^ dimValue - 1+++-- |+-- Two's complement value of a bit vector.+--+-- /Time:/ \(\, \mathcal{O} \left( 1 \right) \)+--+-- /Since: 0.1.0.0/+--+-- ==== __Examples__+--+-- >>> toSignedNumber [4]0+-- 0+--+-- >>> toSignedNumber [4]3+-- 3+--+-- >>> toSignedNumber [4]7+-- 7+--+-- >>> toSignedNumber [4]8+-- -8+--+-- >>> toSignedNumber [4]12+-- -4+--+-- >>> toSignedNumber [4]15+-- -1+{-# INLINE toSignedNumber #-}+toSignedNumber :: Num a => BitVector -> a+toSignedNumber (BV w n) = fromInteger v+ where+ v | n `testBit` (w-1) = negate $ 2^w - n+ | otherwise = n+++-- |+-- Unsigned value of a bit vector.+--+-- /Time:/ \(\, \mathcal{O} \left( 1 \right) \)+--+-- /Since: 0.1.0.0/+--+-- ==== __Examples__+--+-- >>> toSignedNumber [4]0+-- 0+--+-- >>> toSignedNumber [4]3+-- 3+--+-- >>> toSignedNumber [4]7+-- 7+--+-- >>> toSignedNumber [4]8+-- 8+--+-- >>> toSignedNumber [4]12+-- 12+--+-- >>> toSignedNumber [4]15+-- 15+{-# INLINE toUnsignedNumber #-}+toUnsignedNumber :: Num a => BitVector -> a+toUnsignedNumber = fromInteger . nat+++-- |+-- Get the dimension of a 'BitVector'. Preferable to 'finiteBitSize' as it+-- returns a type which cannot represent a non-negative value and a 'BitVector'+-- must have a non-negative dimension.+--+-- /Time:/ \(\, \mathcal{O} \left( 1 \right) \)+--+-- /Since: 0.1.0.0/+--+-- ==== __Examples__+--+-- >>> dimension [2]3+-- 2+--+-- >>> dimension [4]12+-- 4+{-# INLINE dimension #-}+dimension :: BitVector -> Word+dimension = toEnum . dim+++-- |+-- Determine if /any/ bits are set in the 'BitVector'.+-- Faster than @(0 ==) . popCount@.+--+-- /Time:/ \(\, \mathcal{O} \left( 1 \right) \)+--+-- /Since: 0.1.0.0/+--+-- ==== __Examples__+--+-- >>> isZeroVector [2]3+-- False+--+-- >>> isZeroVector [4]0+-- True+{-# INLINE isZeroVector #-}+isZeroVector :: BitVector -> Bool+isZeroVector = (0 ==) . nat+++-- |+-- Get the /inclusive/ range of bits in 'BitVector' as a new 'BitVector'.+--+-- If either of the bounds of the subrange exceed the bit vector's dimension,+-- the resulting subrange will append an infinite number of zeroes to the end+-- of the bit vector in order to satisfy the subrange request.+--+-- /Time:/ \(\, \mathcal{O} \left( 1 \right) \)+--+-- /Since: 0.1.0.0/+--+-- ==== __Examples__+--+-- >>> subRange (0,2) [4]7+-- [3]7+--+-- >>> subRange (1, 3) [4]7+-- [3]3+--+-- >>> subRange (2, 4) [4]7+-- [3]1+--+-- >>> subRange (3, 5) [4]7+-- [3]0+--+-- >>> subRange (10, 20) [4]7+-- [10]0+{-# INLINE subRange #-}+subRange :: (Word, Word) -> BitVector -> BitVector+subRange (!lower, !upper) (BV _ n)+ | lower > upper = zeroBits+ | otherwise = BV m $ (n `shiftR` i) `mod` 2^m+ where+ i = fromEnum lower+ m = fromEnum $ upper - lower + 1
+ stack.yaml view
@@ -0,0 +1,66 @@+# This file was automatically generated by 'stack init'+#+# Some commonly used options have been documented as comments in this file.+# For advanced use and comprehensive documentation of the format, please see:+# https://docs.haskellstack.org/en/stable/yaml_configuration/++# Resolver to choose a 'specific' stackage snapshot or a compiler version.+# A snapshot resolver dictates the compiler version and the set of packages+# to be used for project dependencies. For example:+#+# resolver: lts-3.5+# resolver: nightly-2015-09-21+# resolver: ghc-7.10.2+# resolver: ghcjs-0.1.0_ghc-7.10.2+# resolver:+# name: custom-snapshot+# location: "./custom-snapshot.yaml"+resolver: lts-10.3++# User packages to be built.+# Various formats can be used as shown in the example below.+#+# packages:+# - some-directory+# - https://example.com/foo/bar/baz-0.0.2.tar.gz+# - location:+# git: https://github.com/commercialhaskell/stack.git+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# extra-dep: true+# subdirs:+# - auto-update+# - wai+#+# A package marked 'extra-dep: true' will only be built if demanded by a+# non-dependency (i.e. a user package), and its test suites and benchmarks+# will not be run. This is useful for tweaking upstream packages.+packages:+- .+# Dependency packages to be pulled from upstream that are not in the resolver+# (e.g., acme-missiles-0.3)+# extra-deps: []++# Override default flag values for local packages and extra-deps+# flags: {}++# Extra package databases containing global packages+# extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true+#+# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: ">=1.6"+#+# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64+#+# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]+#+# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor
+ test/TestSuite.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE FlexibleInstances #-}++module Main ( main ) where++import Data.Bits+import Data.BitVector.LittleEndian+import Data.Functor.Compose+import Data.Functor.Identity+import Data.Hashable+import Data.List.NonEmpty (NonEmpty(..))+import Data.Monoid ()+import Data.MonoTraversable+import Data.Semigroup+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck hiding ((.&.))+++main :: IO ()+main = defaultMain testSuite+++testSuite :: TestTree+testSuite = testGroup "BitVector tests"+ [ bitsTests+ , finiteBitsTests+ , hashableTests+ , monoFunctorProperties+ , monoFoldableProperties+ , monoidProperties+ , monoTraversableProperties+ , orderingProperties+ , semigroupProperties+ , bitVectorProperties+ ]+++bitsTests :: TestTree+bitsTests = testGroup "Properties of Bits"+ [ testProperty "∀ i ≥ 0, clearBit zeroBits i === zeroBits" zeroBitsAndClearBit+ , testProperty "∀ i ≥ 0, setBit zeroBits i === bit i" zeroBitsAndSetBit+ , testProperty "∀ i ≥ 0, testBit zeroBits i === False" zeroBitsAndTestBit+ , testCase " popCount zeroBits === 0" zeroBitsAndPopCount+ , testProperty "complement === omap not" complementOmapNot+ , testProperty "(`setBit` i) === (.|. bit i)" setBitDefinition+ , testProperty "(`clearBit` i) === (.&. complement (bit i))" clearBitDefinition+ , testProperty "(`complementBit` i) === (`xor` bit i)" complementBitDefinition+ , testProperty "(`testBit` i) . (`setBit` n)" testBitAndSetBit+ , testProperty "not . (`testBit` i) . (`clearBit` i)" testBitAndClearBit+ , testProperty "(`shiftL` i) === (`shift` i)" leftShiftPositiveShift+ , testProperty "(`shiftR` i) === (`shift` -i)" rightShiftNegativeShift+ , testProperty "(`rotateL` i) === (`rotate` i)" leftRotatePositiveRotate+ , testProperty "(`rotateR` i) === (`rotate` -i)" rightRotateNegativeRotate+ , testProperty "(`rotateR` i) . (`rotateL` i) === id" leftRightRotateIdentity+ , testProperty "(`rotateL` i) . (`rotateR` i) === id" rightLeftRotateIdentity+ ]+ where+ zeroBitsAndClearBit :: NonNegative Int -> Property+ zeroBitsAndClearBit (NonNegative i) =+ clearBit (zeroBits :: BitVector) i === zeroBits++ zeroBitsAndSetBit :: NonNegative Int -> Property+ zeroBitsAndSetBit (NonNegative i) =+ setBit (zeroBits :: BitVector) i === bit i++ zeroBitsAndTestBit :: NonNegative Int -> Property+ zeroBitsAndTestBit (NonNegative i) =+ testBit (zeroBits :: BitVector) i === False++ zeroBitsAndPopCount :: Assertion+ zeroBitsAndPopCount =+ popCount (zeroBits :: BitVector) @?= 0++ complementOmapNot :: BitVector -> Property+ complementOmapNot bv =+ complement bv === omap not bv++ setBitDefinition :: NonNegative Int -> BitVector -> Property+ setBitDefinition (NonNegative i) bv =+ bv `setBit` i === bv .|. bit i++ clearBitDefinition :: NonNegative Int -> BitVector -> Property+ clearBitDefinition (NonNegative i) bv =+ i < (fromEnum . dimension) bv ==>+ (bv `clearBit` i === bv .&. complement (zed .|. bit i))+ where+ zed = fromNumber (dimension bv) (0 :: Integer)++ complementBitDefinition :: NonNegative Int -> BitVector -> Property+ complementBitDefinition (NonNegative i) bv =+ bv `complementBit` i === bv `xor` bit i++ testBitAndSetBit :: NonNegative Int -> BitVector -> Bool+ testBitAndSetBit (NonNegative i) bv =+ ((`testBit` i) . (`setBit` i)) bv++ testBitAndClearBit :: NonNegative Int -> BitVector -> Bool+ testBitAndClearBit (NonNegative i) bv =+ (not . (`testBit` i) . (`clearBit` i)) bv++ leftShiftPositiveShift :: NonNegative Int -> BitVector -> Property+ leftShiftPositiveShift (NonNegative i) bv =+ bv `shiftL` i === bv `shift` i+ + rightShiftNegativeShift :: NonNegative Int -> BitVector -> Property+ rightShiftNegativeShift (NonNegative i) bv =+ bv `shiftR` i === bv `shift` (-i)+ + leftRotatePositiveRotate :: NonNegative Int -> BitVector -> Property+ leftRotatePositiveRotate (NonNegative i) bv =+ bv `rotateL` i === bv `rotate` i++ rightRotateNegativeRotate :: NonNegative Int -> BitVector -> Property+ rightRotateNegativeRotate (NonNegative i) bv =+ bv `rotateR` i === bv `rotate` (-i)+ + leftRightRotateIdentity :: NonNegative Int -> BitVector -> Property+ leftRightRotateIdentity (NonNegative i) bv =+ ((`rotateR` i) . (`rotateL` i)) bv === bv++ rightLeftRotateIdentity :: NonNegative Int -> BitVector -> Property+ rightLeftRotateIdentity (NonNegative i) bv =+ ((`rotateL` i) . (`rotateR` i)) bv === bv+++finiteBitsTests :: TestTree+finiteBitsTests = testGroup "Properties of FiniteBits"+ [ testProperty "bitSize == finiteBitSize" finiteBitSizeIsBitSize+ , testProperty "bitSizeMaybe == Just . finiteBitSize" finiteBitSizeIsBitSizeMaybe+ , testProperty "fromEnum . dimension === finiteBitSize" finiteBitSizeIsDimension+ , testProperty "length . toBits === finiteBitSize" finiteBitSizeIsBitLength+ , testProperty "length . takeWhile not === countLeadingZeros . fromBits" countLeadingZeroAndFromBits+ , testProperty "length . takeWhile not . toBits === countLeadingZeros" countLeadingZeroAndToBits+ , testProperty "length . takeWhile not . reverse === countTrailingZeros . fromBits" countTrailingZeroAndFromBits+ , testProperty "length . takeWhile not . reverse . toBits === countTrailingZeros" countTrailingZeroAndToBits+ ]+ where+ finiteBitSizeIsBitSize :: BitVector -> Property+ finiteBitSizeIsBitSize bv =+ bitSize bv === finiteBitSize bv++ finiteBitSizeIsBitSizeMaybe :: BitVector -> Property+ finiteBitSizeIsBitSizeMaybe bv =+ bitSizeMaybe bv === (Just . finiteBitSize) bv+ + finiteBitSizeIsDimension :: BitVector -> Property+ finiteBitSizeIsDimension bv =+ (fromEnum . dimension) bv === finiteBitSize bv++ finiteBitSizeIsBitLength :: BitVector -> Property+ finiteBitSizeIsBitLength bv =+ (length . toBits) bv === finiteBitSize bv++ countLeadingZeroAndFromBits :: [Bool] -> Property+ countLeadingZeroAndFromBits bs =+ (length . takeWhile not) bs === (countLeadingZeros . fromBits) bs++ countLeadingZeroAndToBits :: BitVector -> Property+ countLeadingZeroAndToBits bv =+ (length . takeWhile not . toBits) bv === countLeadingZeros bv++ countTrailingZeroAndFromBits :: [Bool] -> Property+ countTrailingZeroAndFromBits bs =+ (length . takeWhile not . reverse) bs === (countTrailingZeros . fromBits) bs++ countTrailingZeroAndToBits :: BitVector -> Property+ countTrailingZeroAndToBits bv =+ (length . takeWhile not . reverse . toBits) bv === countTrailingZeros bv+++hashableTests :: TestTree+hashableTests = testGroup "Properties of Hashable"+ [ localOption (QuickCheckTests 10000)+ $ 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)+ + +monoFunctorProperties :: TestTree+monoFunctorProperties = testGroup "Properites of a MonoFunctor"+ [ testProperty "omap id === id" omapId+ , testProperty "omap (f . g) === omap f . omap g" omapComposition+ ]+ where+ omapId :: BitVector -> Property+ omapId bv =+ omap id bv === id bv++ omapComposition :: Blind (Bool -> Bool) -> Blind (Bool -> Bool) -> BitVector -> Property+ omapComposition (Blind f) (Blind g) bv =+ omap (f . g) bv === (omap f . omap g) bv+++monoFoldableProperties :: TestTree+monoFoldableProperties = testGroup "Properties of MonoFoldable"+ [ testProperty "ofoldr f z t === appEndo (ofoldMap (Endo . f) t ) z" testFoldrFoldMap+ , testProperty "ofoldl' f z t === appEndo (getDual (ofoldMap (Dual . Endo . flip f) t)) z" testFoldlFoldMap+ , testProperty "ofoldr f z === ofoldr f z . otoList" testFoldr+ , testProperty "ofoldl' f z === ofoldl' f z . otoList" testFoldl+ , testProperty "ofoldr1Ex f z === ofoldr1Ex f z . otoList" testFoldr1+ , testProperty "ofoldl1Ex' f z === ofoldl1Ex' f z . otoList" testFoldl1+ , testProperty "oall f === getAll . ofoldMap (All . f)" testAll+ , testProperty "oany f === getAny . ofoldMap (Any . f)" testAny+ , testProperty "olength === length . otoList" testLength+ , testProperty "onull === (0 ==) . olength" testNull+ , testProperty "headEx === getFirst . ofoldMap1Ex First" testHead+ , testProperty "lastEx === getLast . ofoldMap1Ex Last" testTail+ , testProperty "oelem e /== onotElem e" testInclusionConsistency+ ]+ where+ testFoldrFoldMap :: Blind (Bool -> Word -> Word) -> Word -> BitVector -> Property+ testFoldrFoldMap (Blind f) z bv =+ ofoldr f z bv === appEndo (ofoldMap (Endo . f) bv) z++ testFoldlFoldMap :: Blind (Word -> Bool -> Word) -> Word -> BitVector -> Property+ testFoldlFoldMap (Blind f) z bv =+ ofoldl' f z bv === appEndo (getDual (ofoldMap (Dual . Endo . flip f) bv)) z++ testFoldr :: Blind (Bool -> Word -> Word) -> Word -> BitVector -> Property+ testFoldr (Blind f) z bv =+ ofoldr f z bv === (ofoldr f z . otoList) bv++ testFoldl :: Blind (Word -> Bool -> Word) -> Word -> BitVector -> Property+ testFoldl (Blind f) z bv =+ ofoldl' f z bv === (ofoldl' f z . otoList) bv++ testFoldr1 :: Blind (Bool -> Bool -> Bool) -> BitVector -> Property+ testFoldr1 (Blind f) bv =+ (not . onull) bv ==> ofoldr1Ex f bv === (ofoldr1Ex f . otoList) bv++ testFoldl1 :: Blind (Bool -> Bool -> Bool) -> BitVector -> Property+ testFoldl1 (Blind f) bv =+ (not . onull) bv ==> ofoldl1Ex' f bv === (ofoldl1Ex' f . otoList) bv++ testAll :: Blind (Bool -> Bool) -> BitVector -> Property+ testAll (Blind f) bv =+ oall f bv === (getAll . ofoldMap (All . f)) bv++ testAny :: Blind (Bool -> Bool) -> BitVector -> Property+ testAny (Blind f) bv =+ oany f bv === (getAny . ofoldMap (Any . f)) bv++ testLength :: BitVector -> Property+ testLength bv =+ olength bv === (length . otoList) bv++ testNull :: BitVector -> Property+ testNull bv =+ onull bv === ((0 ==) . olength) bv++ testHead :: BitVector -> Property+ testHead bv =+ (not . onull) bv ==> headEx bv === (getFirst . ofoldMap1Ex First) bv++ testTail :: BitVector -> Property+ testTail bv =+ (not . onull) bv ==> lastEx bv === (getLast . ofoldMap1Ex Last) bv++ testInclusionConsistency :: (Bool, BitVector) -> Property+ testInclusionConsistency (e, bv) =+ oelem e bv === (not . onotElem e) bv+++monoidProperties :: TestTree+monoidProperties = testGroup "Properties of a Monoid"+ [ testProperty "left identity" leftIdentity+ , testProperty "right identity" rightIdentity+ , testProperty "mempty is associative" operationAssocativity+ , testProperty "mconcat === foldr (<>) mempty" foldableApplication+ ]+ where+ leftIdentity :: BitVector -> Property+ leftIdentity a =+ mempty `mappend` a === a++ rightIdentity :: BitVector -> Property+ rightIdentity a =+ a `mappend` mempty === a++ operationAssocativity :: BitVector -> BitVector -> BitVector -> Property+ operationAssocativity a b c =+ a `mappend` (b `mappend` c) === (a `mappend` b) `mappend` c++ foldableApplication :: [BitVector] -> Property+ foldableApplication bvs = + mconcat bvs === foldr mappend mempty bvs+++monoTraversableProperties :: TestTree+monoTraversableProperties = testGroup "Properties of MonoTraversable"+ [ 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+ ]+ where+ testNaturality :: Blind (Bool -> [Bool]) -> BitVector -> Property+ testNaturality (Blind f) bv =+ (headMay . otraverse f) bv === otraverse (headMay . f) bv++ testIdentity :: BitVector -> Property+ testIdentity bv =+ otraverse Identity bv === Identity bv++ testComposition :: Blind (Bool -> Either Word Bool) -> Blind (Bool -> Maybe Bool) -> BitVector -> Property+ testComposition (Blind f) (Blind g) bv =+ otraverse (Compose . fmap g . f) bv === (Compose . fmap (otraverse g) . otraverse f) bv+++orderingProperties :: TestTree+orderingProperties = testGroup "Properties of an Ordering"+ [ testProperty "ordering preserves symetry" symetry+ , testProperty "ordering is transitive (total)" transitivity+ ]+ where+ symetry :: BitVector -> BitVector -> Bool+ symetry lhs rhs =+ case (lhs `compare` rhs, rhs `compare` lhs) of+ (EQ, EQ) -> True+ (GT, LT) -> True+ (LT, GT) -> True+ _ -> False++ 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+++semigroupProperties :: TestTree+semigroupProperties = testGroup "Properties of a Semigroup"+ [ localOption (QuickCheckTests 10000)+ $ testProperty "(<>) is associative" operationAssocativity+ , testProperty "sconcat === foldr1 (<>)" foldableApplication+ , testProperty "stimes n === mconcat . replicate n" repeatedApplication+ ]+ where+ operationAssocativity :: BitVector -> BitVector -> BitVector -> Property+ operationAssocativity a b c =+ a <> (b <> c) === (a <> b) <> c++ foldableApplication :: NonEmptyList BitVector -> Property+ foldableApplication nel =+ sconcat bvs === foldr1 mappend bvs+ where+ -- We do this because there is currently no Arbitrary inctance for NonEmpty+ bvs = let x:xs = getNonEmpty nel+ in x:|xs++ repeatedApplication :: (NonNegative Int) -> BitVector -> Property+ repeatedApplication (NonNegative i) bv =+ stimes i bv === (mconcat . replicate i) bv+++bitVectorProperties :: TestTree+bitVectorProperties = testGroup "BitVector properties"+ [ testProperty "otoList === toBits" otoListTest+ , testProperty "dimension === length . toBits" dimensionAndToBits+ , testProperty "dimension === finiteBitSize" dimensionAndFiniteBitSize+ , testProperty "fromBits . toBits === id" toBitsFromBits+ , testCase "isZeroVector zeroBits" zeroBitsIsZeroVector+ , testProperty "isZeroVector === (0 ==) . popCount" popCountAndZeroVector+ , testProperty "isZeroVector === all not . toBits" zeroVectorAndAllBitsOff+ , testProperty "(0 ==) . toUnsignedNumber ==> isZeroVector" toUnsignedNumImpliesZeroVector+ , testProperty "toSignedNumber . fromNumber === id" bitVectorUnsignedNumIdentity+ , testProperty "isSigned == const False" noSignBitVector+ ]+ where+ otoListTest :: BitVector -> Property+ otoListTest bv =+ otoList bv === toBits bv++ dimensionAndToBits :: BitVector -> Property+ dimensionAndToBits bv =+ (fromEnum . dimension) bv === (length . toBits) bv++ dimensionAndFiniteBitSize :: BitVector -> Property+ dimensionAndFiniteBitSize bv =+ (fromEnum . dimension) bv === finiteBitSize bv++ toBitsFromBits :: BitVector -> Property+ toBitsFromBits bv =+ (fromBits . toBits) bv === bv++ zeroBitsIsZeroVector :: Assertion+ zeroBitsIsZeroVector =+ assertBool "zeroBits is not a 'zero vector'" $ isZeroVector zeroBits++ popCountAndZeroVector :: BitVector -> Property+ popCountAndZeroVector bv =+ isZeroVector bv === ((0 ==) . popCount) bv++ zeroVectorAndAllBitsOff :: BitVector -> Property+ zeroVectorAndAllBitsOff bv =+ isZeroVector bv === (all not . toBits) bv++ toUnsignedNumImpliesZeroVector :: BitVector -> Property+ toUnsignedNumImpliesZeroVector bv =+ ((0 ==) . (toUnsignedNumber :: BitVector -> Integer)) bv ==> isZeroVector bv++ bitVectorUnsignedNumIdentity :: Integer -> Property+ bitVectorUnsignedNumIdentity num =+ (toSignedNumber . fromNumber width) num === num+ where+ width = succ . succ . ceiling . logBase (2.0 :: Double) . fromIntegral $ abs num++ noSignBitVector :: BitVector -> Property+ noSignBitVector bv =+ isSigned bv === False