bitvec 0.2.0.1 → 1.0.0.0

raw patch · 23 files changed

+1661/−1212 lines, 23 filesdep +bits-extradep +gaugedep +ghc-primdep −HUnitdep −QuickCheckdep −test-frameworkdep ~basedep ~primitivedep ~vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: bits-extra, gauge, ghc-prim, semigroups, tasty, tasty-hunit, tasty-quickcheck

Dependencies removed: HUnit, QuickCheck, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependency ranges changed: base, primitive, vector

API changes (from Hackage documentation)

Files

• LICENSE +28/−3
• bench/Bench.hs +41/−0
• bitvec.cabal +82/−25
• changelog.md +6/−0
• src/Data/Bit.hs +62/−2
• src/Data/Bit/Immutable.hs +171/−0
• src/Data/Bit/ImmutableTS.hs +4/−0
• src/Data/Bit/Internal.hs +499/−122
• src/Data/Bit/InternalTS.hs +4/−0
• src/Data/Bit/Mutable.hs +239/−0
• src/Data/Bit/MutableTS.hs +4/−0
• src/Data/Bit/Select1.hs +147/−0
• src/Data/Bit/ThreadSafe.hs +4/−0
• src/Data/Bit/Utils.hs +153/−0
• src/Data/Vector/Unboxed/Bit.hs +0/−252
• src/Data/Vector/Unboxed/Bit/Internal.hs +0/−299
• src/Data/Vector/Unboxed/Mutable/Bit.hs +0/−290
• test/Main.hs +7/−5
• test/Support.hs +28/−14
• test/Tests/MVector.hs +31/−79
• test/Tests/MVectorTS.hs +4/−0
• test/Tests/SetOps.hs +71/−37
• test/Tests/Vector.hs +76/−84

@@ -1,5 +1,30 @@-I hereby release this code to the public domain.+Copyright (c) 2019 Andrew Lelechenko, 2012-2016 James Cook -If for some reason that's not possible or somehow gets revoked (the expected reason being the insanity of our lawyerocracy), I retain or immediately reclaim all rights and explicitly grant an unlimited, eternal and irrevocable license to everyone else, whether or not they are legally recognized as a sentient person, to do absolutely anything they want to do with this code, at no charge.+All rights reserved. -Furthermore, this code is provided as-is.  I explicitly decline to offer any warrantee, either express or implied, not even the so-called "implied warantees" of merchantability, fitness for a particular purpose, or any other crazy ideas the aforementioned lawyers have created in their unholy quest for ever-more money and/or power.  For that matter, I don't even warrant that the use of this code won't start a global thermonuclear war or runaway nanotechnology event (though if you're worried about such things, I can tell you off-the-record that it probably won't do either).+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.++    * The names of the contributors may not be used to endorse 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+OWNER 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.

@@ -0,0 +1,41 @@+module Main where++import Control.Monad+import Control.Monad.ST+import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.Vector.Unboxed.Mutable as MU+import Gauge.Main++main :: IO ()+main = defaultMain+  [ bgroup "randomWrite"   $ map benchRandomWrite   [5..10]+  , bgroup "randomWriteTS" $ map benchRandomWriteTS [5..10]+  ]++benchRandomWrite :: Int -> Benchmark+benchRandomWrite k = bench (show (2 ^ k)) $ nf doRandomWrite k++doRandomWrite :: Int -> Int+doRandomWrite k = runST $ do+  let n = 2 ^ k+      ixs = scanl xor 0 [0..n-1]+      vals = take 100 $ cycle [Bit True, Bit False]+  vec <- MU.new n+  forM_ vals $ \v -> forM_ ixs $ \i -> MU.unsafeWrite vec i v+  Bit i <- MU.unsafeRead vec 0+  pure $ if i then 1 else 0++benchRandomWriteTS :: Int -> Benchmark+benchRandomWriteTS k = bench (show (2 ^ k)) $ nf doRandomWriteTS k++doRandomWriteTS :: Int -> Int+doRandomWriteTS k = runST $ do+  let n = 2 ^ k+      ixs = scanl xor 0 [0..n-1]+      vals = take 100 $ cycle [TS.Bit True, TS.Bit False]+  vec <- MU.new n+  forM_ vals $ \v -> forM_ ixs $ \i -> MU.unsafeWrite vec i v+  TS.Bit i <- MU.unsafeRead vec 0+  pure $ if i then 1 else 0

@@ -1,26 +1,47 @@ name: bitvec-version: 0.2.0.1+version: 1.0.0.0 cabal-version: >=1.10 build-type: Simple-license: PublicDomain+license: BSD3 license-file: LICENSE+copyright: 2019 Andrew Lelechenko, 2012-2016 James Cook maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com> homepage: https://github.com/Bodigrim/bitvec synopsis: Unboxed bit vectors description:   Bit vectors library for Haskell.--  The current @vector@ package represents unboxed arrays of @Bool@+  .+  The current [vector](https://hackage.haskell.org/package/vector)+  package represents unboxed arrays of 'Bool'   allocating one byte per boolean, which might be considered wasteful.-  This library provides a newtype wrapper @Bit@ and a custom instance-  of unboxed @Vector@, which packs booleans densely.+  This library provides a newtype wrapper 'Data.Bit.Bit' and a custom instance+  of unboxed 'Data.Vector.Unboxed.Vector', which packs booleans densely.   It is a time-memory tradeoff: 8x less memory footprint   at the price of moderate performance penalty   (mostly, for random writes).+  .+  === Thread safety+  * "Data.Bit" is faster, but thread-unsafe. This is because+    naive updates are not atomic operations: read the whole word from memory,+    modify a bit, write the whole word back.+  * "Data.Bit.ThreadSafe" is slower (up to 2x), but thread-safe.+  .+  === Similar packages+  .+  * [bv](https://hackage.haskell.org/package/bv)+    and [bv-little](https://hackage.haskell.org/package/bv-little)+    offer only immutable size-polymorphic bit vectors.+    @bitvec@ provides an interface to mutable vectors as well.+  .+  * [array](https://hackage.haskell.org/package/array)+    is memory-efficient for 'Bool', but lacks+    a handy 'Vector' interface and is not thread-safe.+ category: Data, Bit Vectors-author: James Cook <mokus@deepbondi.net>,-        Andrew Lelechenko <andrew.lelechenko@gmail.com>-tested-with: GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.3 GHC ==8.6.3+author: Andrew Lelechenko <andrew.lelechenko@gmail.com>,+        James Cook <mokus@deepbondi.net>++tested-with: GHC ==7.10.3 GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.1 extra-source-files:   changelog.md @@ -28,41 +49,77 @@   type: git   location: git://github.com/Bodigrim/bitvec.git +flag bmi2+  description: Enable bmi2 instruction set+  manual: False+  default: False+ library   exposed-modules:     Data.Bit-    Data.Vector.Unboxed.Bit-    Data.Vector.Unboxed.Mutable.Bit+    Data.Bit.ThreadSafe   build-depends:     base >=4.8 && <5,-    primitive -any,-    vector >=0.8+    ghc-prim,+    primitive >=0.5,+    vector >=0.11+  if (flag(bmi2)) && (impl(ghc >=8.4.1))+    build-depends:+      bits-extra >=0.0.0.4 && <0.1+  if impl(ghc <8.0)+    build-depends:+      semigroups >=0.8   default-language: Haskell2010   hs-source-dirs: src   other-modules:+    Data.Bit.Immutable+    Data.Bit.ImmutableTS     Data.Bit.Internal-    Data.Vector.Unboxed.Bit.Internal-  ghc-options: -fwarn-unused-imports -fwarn-unused-binds -fwarn-type-defaults+    Data.Bit.InternalTS+    Data.Bit.Mutable+    Data.Bit.MutableTS+    Data.Bit.Select1+    Data.Bit.Utils+  ghc-options: -O2 -Wall+  include-dirs: src+  if (flag(bmi2)) && (impl(ghc >=8.4.1))+    ghc-options: -mbmi2 -msse4.2+    cpp-options: -DBMI2_ENABLED  test-suite bitvec-tests   type: exitcode-stdio-1.0   main-is: Main.hs   build-depends:     base >=4.8 && <5,-    bitvec -any,-    HUnit -any,-    primitive -any,-    vector >=0.8,-    test-framework -any,-    test-framework-hunit -any,-    test-framework-quickcheck2 -any,-    QuickCheck >=2.10,-    quickcheck-classes >=0.6.1+    bitvec,+    primitive >=0.5,+    quickcheck-classes >=0.6.1,+    vector >=0.11,+    tasty,+    tasty-hunit,+    tasty-quickcheck+  if impl(ghc <8.0)+    build-depends:+      semigroups >=0.8   default-language: Haskell2010   hs-source-dirs: test   other-modules:     Support     Tests.MVector+    Tests.MVectorTS     Tests.SetOps     Tests.Vector-  ghc-options: -threaded -fwarn-unused-imports -fwarn-unused-binds+  ghc-options: -Wall+  include-dirs: test++benchmark gauge+  build-depends:+    base,+    bitvec,+    gauge,+    vector+  type: exitcode-stdio-1.0+  main-is: Bench.hs+  default-language: Haskell2010+  hs-source-dirs: bench+  ghc-options: -O2 -Wall

@@ -1,3 +1,9 @@+# 1.0.0.0++* Redesign API from the scratch.+* Add a thread-safe implementation.+* Add 'nthBitIndex' function.+ # 0.2.0.1  * Fix 'Read' instance.

@@ -1,6 +1,66 @@+{-# LANGUAGE CPP #-}++#ifndef BITVEC_THREADSAFE+-- |+-- Module:      Data.Bit+-- Copyright:   (c) 2019 Andrew Lelechenko, 2012-2016 James Cook+-- Licence:     BSD3+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- This module exposes a faster, but thread-unsafe implementation.+-- Consider using "Data.Bit.ThreadSafe", which is thread-safe, but slower (up to 2x). module Data.Bit-    ( Bit(..)+#else+-- |+-- Module:      Data.Bit.ThreadSafe+-- Copyright:   (c) 2019 Andrew Lelechenko, 2012-2016 James Cook+-- Licence:     BSD3+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- This module exposes a slower (up to 2x), but thread-safe implementation.+-- Consider using "Data.Bit", which is faster, but thread-unsafe.+module Data.Bit.ThreadSafe+#endif+     ( Bit(..)++     , unsafeFlipBit+     , flipBit++     -- * Immutable conversions+     , castFromWords+     , castToWords+     , cloneToWords++     -- * Immutable operations+     , zipBits+     , bitIndex+     , nthBitIndex+     , countBits+     , listBits+     , selectBits+     , excludeBits++     -- * Mutable conversions+     , castFromWordsM+     , castToWordsM+     , cloneToWordsM++     -- * Mutable operations+     , invertInPlace+     , zipInPlace+     , selectBitsInPlace+     , excludeBitsInPlace+     , reverseInPlace     ) where +import Prelude hiding (and, or)++#ifndef BITVEC_THREADSAFE+import Data.Bit.Immutable import Data.Bit.Internal-import Data.Vector.Unboxed.Bit.Internal ({- instance Unbox Bit -})+import Data.Bit.Mutable+#else+import Data.Bit.ImmutableTS+import Data.Bit.InternalTS+import Data.Bit.MutableTS+#endif

@@ -0,0 +1,171 @@+{-# LANGUAGE CPP              #-}++{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes       #-}++#ifndef BITVEC_THREADSAFE+module Data.Bit.Immutable+#else+module Data.Bit.ImmutableTS+#endif+     ( castFromWords+     , castToWords+     , cloneToWords++     , zipBits++     , selectBits+     , excludeBits+     , bitIndex+     ) where++import           Control.Monad+import           Control.Monad.ST+import           Data.Bits+#ifndef BITVEC_THREADSAFE+import           Data.Bit.Internal+import qualified Data.Bit.Mutable                   as B+#else+import           Data.Bit.InternalTS+import qualified Data.Bit.MutableTS                   as B+#endif+import           Data.Bit.Utils+import qualified Data.Vector.Generic.Mutable       as MV+import qualified Data.Vector.Generic               as V+import           Data.Vector.Unboxed                as U+    hiding (and, or, any, all, reverse, findIndex)+import qualified Data.Vector.Unboxed                as Unsafe+import           Data.Word+import           Prelude                           as P+    hiding (and, or, any, all, reverse)++-- | Cast a vector of words to a vector of bits.+-- Cf. 'Data.Bit.castFromWordsM'.+--+-- >>> castFromWords (Data.Vector.Unboxed.singleton 123)+-- [1,1,0,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]+castFromWords+    :: U.Vector Word+    -> U.Vector Bit+castFromWords ws = BitVec 0 (nBits (V.length ws)) ws++-- | Try to cast a vector of bits to a vector of words.+-- It succeeds if a vector of bits is aligned.+-- Use 'cloneToWords' otherwise.+-- Cf. 'Data.Bit.castToWordsM'.+--+-- prop> castToWords (castFromWords v) == Just v+castToWords+    :: U.Vector Bit+    -> Maybe (U.Vector Word)+castToWords (BitVec s n ws)+    | aligned s+    , aligned n+    = Just $ V.slice (divWordSize s) (nWords n) ws+    | otherwise+    = Nothing++-- | Clone a vector of bits to a new unboxed vector of words.+-- If the bits don't completely fill the words, the last word will be zero-padded.+-- Cf. 'Data.Bit.cloneToWordsM'.+--+-- >>> cloneToWords (read "[1,1,0,1,1,1,1,0]")+-- [123]+cloneToWords+    :: U.Vector Bit+    -> U.Vector Word+cloneToWords v@(BitVec _ n _) = runST $ do+    ws <- MV.new (nWords n)+    let loop !i !j+            | i >= n    = return ()+            | otherwise = do+                MV.write ws j (indexWord v i)+                loop (i + wordSize) (j + 1)+    loop 0 0+    V.unsafeFreeze ws+{-# INLINE cloneToWords #-}++-- | Zip two vectors with the given function.+-- Similar to 'Data.Vector.Unboxed.zipWith', but much faster.+--+-- >>> import Data.Bits+-- >>> zipBits (.&.) (read "[1,1,0]") (read "[0,1,1]") -- intersection+-- [0,1,0]+-- >>> zipBits (.|.) (read "[1,1,0]") (read "[0,1,1]") -- union+-- [1,1,1]+-- >>> zipBits (\x y -> x .&. complement y) (read "[1,1,0]") (read "[0,1,1]") -- difference+-- [1,0,0]+-- >>> zipBits xor (read "[1,1,0]") (read "[0,1,1]") -- symmetric difference+-- [1,0,1]+zipBits+    :: (forall a. Bits a => a -> a -> a)+    -> U.Vector Bit+    -> U.Vector Bit+    -> U.Vector Bit+zipBits f xs ys+    | U.length xs >= U.length ys = zs+    | otherwise = U.slice 0 (U.length xs) zs+    where+        zs = U.modify (B.zipInPlace f xs) ys++-- | For each set bit of the first argument, deposit+-- the corresponding bit of the second argument+-- to the result. Similar to the parallel deposit instruction (PDEP).+--+-- >>> selectBits (read "[0,1,0,1,1]") (read "[1,1,0,0,1]")+-- [1,0,1]+--+-- Here is a reference (but slow) implementation:+--+-- > import qualified Data.Vector.Unboxed as U+-- > selectBits mask ws == U.map snd (U.filter (unBit . fst) (U.zip mask ws))+selectBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+selectBits is xs = runST $ do+    xs1 <- U.thaw xs+    n <- B.selectBitsInPlace is xs1+    Unsafe.unsafeFreeze (MV.take n xs1)++-- | For each unset bit of the first argument, deposit+-- the corresponding bit of the second argument+-- to the result.+--+-- >>> excludeBits (read "[0,1,0,1,1]") (read "[1,1,0,0,1]")+-- [1,0]+--+-- Here is a reference (but slow) implementation:+--+-- > import qualified Data.Vector.Unboxed as U+-- > excludeBits mask ws == U.map snd (U.filter (not . unBit . fst) (U.zip mask ws))+excludeBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+excludeBits is xs = runST $ do+    xs1 <- U.thaw xs+    n <- B.excludeBitsInPlace is xs1+    Unsafe.unsafeFreeze (MV.take n xs1)++-- | Return the index of the first bit in the vector+-- with the specified value, if any.+-- Similar to 'Data.Vector.Unboxed.elemIndex', but much faster.+--+-- >>> bitIndex (Bit True) (read "[0,0,1,0,1]")+-- Just 2+-- >>> bitIndex (Bit True) (read "[0,0,0,0,0]")+-- Nothing+--+-- prop> bitIndex bit == nthBitIndex bit 1+--+-- One can also use it to reduce a vector with disjunction or conjunction:+--+-- >>> import Data.Maybe+-- >>> isAnyBitSet   = isJust    . bitIndex (Bit True)+-- >>> areAllBitsSet = isNothing . bitIndex (Bit False)+bitIndex :: Bit -> U.Vector Bit -> Maybe Int+bitIndex b xs = mfilter (< n) (loop 0)+    where+        !n = V.length xs+        !ff | unBit b   = ffs+            | otherwise = ffs . complement++        loop !i+            | i >= n    = Nothing+            | otherwise = fmap (i +) (ff (indexWord xs i)) `mplus` loop (i + wordSize)

@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Data/Bit/Immutable.hs"

@@ -1,13 +1,53 @@+{-# LANGUAGE CPP                        #-}+ {-# LANGUAGE BangPatterns               #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE ViewPatterns               #-} -module Data.Bit.Internal where+#ifndef BITVEC_THREADSAFE+module Data.Bit.Internal+#else+module Data.Bit.InternalTS+#endif+    ( Bit(..)+    , U.Vector(BitVec)+    , U.MVector(BitMVec)+    , indexWord+    , readWord+    , writeWord +    , unsafeFlipBit+    , flipBit++    , nthBitIndex+    , countBits+    , listBits+    ) where++#include "vector.h"++import Control.Monad+import Control.Monad.Primitive+import Data.Bit.Select1+import Data.Bit.Utils import Data.Bits-import Data.List import Data.Typeable+import qualified Data.Vector.Generic         as V+import qualified Data.Vector.Generic.Mutable as MV+import qualified Data.Vector.Unboxed         as U +#ifdef BITVEC_THREADSAFE+import Data.Primitive.ByteArray+import qualified Data.Vector.Primitive       as P+import GHC.Exts+#endif+ -- | A newtype wrapper with a custom instance -- of "Data.Vector.Unboxed", which packs booleans -- as efficient as possible (8 values per byte).@@ -15,17 +55,9 @@ -- than vectors of 'Bool' (which stores one value per byte), -- but random writes -- are slightly slower.------ In addition to "Data.Vector.Unboxed" interface,--- one can also find assorted utilities--- from "Data.Vector.Unboxed.Bit"--- and "Data.Vector.Unboxed.Mutable.Bit". newtype Bit = Bit { unBit :: Bool }     deriving (Bounded, Enum, Eq, Ord, FiniteBits, Bits, Typeable) -fromBool :: Bool -> Bit-fromBool b = Bit b- instance Show Bit where     showsPrec _ (Bit False) = showString "0"     showsPrec _ (Bit True ) = showString "1"@@ -36,148 +68,493 @@     readsPrec _ ('1':rest) = [(Bit True, rest)]     readsPrec _ _ = [] --- various internal utility functions and constants+instance U.Unbox Bit -lg2 :: Int -> Int-lg2 n = i-    where Just i = findIndex (>= toInteger n) (iterate (`shiftL` 1) 1)+-- Ints are offset and length in bits+data instance U.MVector s Bit = BitMVec !Int !Int !(U.MVector s Word)+data instance U.Vector    Bit = BitVec  !Int !Int !(U.Vector    Word) +readBit :: Int -> Word -> Bit+readBit i w = Bit (w .&. (1 `unsafeShiftL` i) /= 0)+{-# INLINE readBit #-} --- |The number of 'Bit's in a 'Word'.  A handy constant to have around when defining 'Word'-based bulk operations on bit vectors.-wordSize :: Int-wordSize = finiteBitSize (0 :: Word)+extendToWord :: Bit -> Word+extendToWord (Bit False) = 0+extendToWord (Bit True)  = complement 0 -lgWordSize, wordSizeMask, wordSizeMaskC :: Int-lgWordSize = case wordSize of-    32 -> 5-    64 -> 6-    _  -> lg2 wordSize+-- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.).  If the offset is such that the word extends past the end of the vector, the result is zero-padded.+indexWord :: U.Vector Bit -> Int -> Word+indexWord (BitVec 0 n v) i+    | aligned i         = masked b lo+    | j + 1 == nWords n = masked b (extractWord k lo 0 )+    | otherwise         = masked b (extractWord k lo hi)+        where+            b = n - i+            j  = divWordSize i+            k  = modWordSize i+            lo = v V.!  j+            hi = v V.! (j+1)+indexWord (BitVec s n v) i = indexWord (BitVec 0 (n + s) v) (i + s) -wordSizeMask = wordSize - 1-wordSizeMaskC = complement wordSizeMask+-- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.).  If the offset is such that the word extends past the end of the vector, the result is zero-padded.+readWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m Word+readWord (BitMVec 0 n v) i+    | aligned i         = liftM (masked b) lo+    | j + 1 == nWords n = liftM (masked b) (liftM2 (extractWord k) lo (return 0))+    | otherwise         = liftM (masked b) (liftM2 (extractWord k) lo hi)+        where+            b = n - i+            j = divWordSize i+            k = modWordSize i+            lo = MV.read v  j+            hi = MV.read v (j+1)+readWord (BitMVec s n v) i = readWord (BitMVec 0 (n + s) v) (i + s) -divWordSize :: Bits a => a -> a-divWordSize x = shiftR x lgWordSize+-- | write a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.).  If the offset is such that the word extends past the end of the vector, the word is truncated and as many low-order bits as possible are written.+writeWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> Word -> m ()+writeWord (BitMVec 0 n v) i x+    | aligned i    =+        if b < wordSize+            then do+                y <- MV.read v j+                MV.write v j (meld b x y)+            else MV.write v j x+    | j + 1 == nWords n = do+        lo <- MV.read v  j+        let x' = if b < wordSize+                    then meld b x (extractWord k lo 0)+                    else x+            (lo', _hi) = spliceWord k lo 0 x'+        MV.write v  j    lo'+    | otherwise    = do+        lo <- MV.read v  j+        hi <- if j + 1 == nWords n+            then return 0+            else MV.read v (j+1)+        let x' = if b < wordSize+                    then meld b x (extractWord k lo hi)+                    else x+            (lo', hi') = spliceWord k lo hi x'+        MV.write v  j    lo'+        MV.write v (j+1) hi'+    where+        b = n - i+        j  = divWordSize i+        k  = modWordSize i+writeWord (BitMVec s n v) i x = writeWord (BitMVec 0 (n + s) v) (i + s) x -modWordSize :: Int -> Int-modWordSize x = x .&. (wordSize - 1)+instance MV.MVector U.MVector Bit where+    {-# INLINE basicInitialize #-}+    basicInitialize (BitMVec _ 0 _) = pure ()+    basicInitialize (BitMVec 0 n v) = case modWordSize n of+        0 -> MV.basicInitialize v+        nMod -> do+            let vLen = MV.basicLength v+            MV.basicInitialize (MV.slice 0 (vLen - 1) v)+            MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1)+    basicInitialize (BitMVec s n v) = case modWordSize (s + n) of+        0 -> do+            let vLen = MV.basicLength v+            MV.basicInitialize (MV.slice 1 (vLen - 1) v)+            MV.modify v (\val -> val .&. loMask s) 0+        nMod -> do+            let vLen = MV.basicLength v+                lohiMask = loMask s .|. hiMask nMod+            if vLen == 1+                then MV.modify v (\val -> val .&. lohiMask) 0+                else do+                    MV.basicInitialize (MV.slice 1 (vLen - 2) v)+                    MV.modify v (\val -> val .&. loMask s) 0+                    MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1) -mulWordSize :: Bits a => a -> a-mulWordSize x = shiftL x lgWordSize+    {-# INLINE basicUnsafeNew #-}+    basicUnsafeNew       n   = liftM (BitMVec 0 n) (MV.basicUnsafeNew       (nWords n)) --- number of words needed to store n bits-nWords :: Int -> Int-nWords ns = divWordSize (ns + wordSize - 1)+    {-# INLINE basicUnsafeReplicate #-}+    basicUnsafeReplicate n x = liftM (BitMVec 0 n) (MV.basicUnsafeReplicate (nWords n) (extendToWord x)) --- number of bits storable in n words-nBits :: Bits a => a -> a-nBits ns = mulWordSize ns+    {-# INLINE basicOverlaps #-}+    basicOverlaps (BitMVec _ _ v1) (BitMVec _ _ v2) = MV.basicOverlaps v1 v2 -aligned :: Int -> Bool-aligned    x = (x .&. wordSizeMask == 0)+    {-# INLINE basicLength #-}+    basicLength      (BitMVec _ n _)     = n -notAligned :: Int -> Bool-notAligned x = x /= alignDown x+    {-# INLINE basicUnsafeRead #-}+    basicUnsafeRead  (BitMVec s _ v) !i'   = let i = s + i' in liftM (readBit (modWordSize i)) (MV.basicUnsafeRead v (divWordSize i)) --- round a number of bits up to the nearest multiple of word size-alignUp :: Int -> Int-alignUp x-    | x == x'   = x'-    | otherwise = x' + wordSize-    where x' = alignDown x+    {-# INLINE basicUnsafeWrite #-}+#ifndef BITVEC_THREADSAFE+    basicUnsafeWrite (BitMVec s _ v) !i' !x = do+        let i = s + i'+        let j = divWordSize i; k = modWordSize i; kk = 1 `unsafeShiftL` k+        w <- MV.basicUnsafeRead v j+        when (Bit (w .&. kk /= 0) /= x) $+            MV.basicUnsafeWrite v j (w `xor` kk)+#else+    basicUnsafeWrite (BitMVec s _ (U.MV_Word (P.MVector o _ (MutableByteArray mba)))) !i' (Bit b) = do+        let i       = s + i'+            !(I# j) = o + divWordSize i+            !(I# k) = 1 `unsafeShiftL` modWordSize i+        primitive $ \state ->+            let !(# state', _ #) = (if b then fetchOrIntArray# mba j k state else fetchAndIntArray# mba j (notI# k) state) in+                (# state', () #)+#endif --- round a number of bits down to the nearest multiple of word size-alignDown :: Int -> Int-alignDown x = x .&. wordSizeMaskC+    {-# INLINE basicClear #-}+    basicClear _ = pure () -readBit :: Int -> Word -> Bit-readBit i w = fromBool (w .&. (1 `unsafeShiftL` i) /= 0)+    {-# INLINE basicSet #-}+    basicSet (BitMVec _ 0 _) _ = pure ()+    basicSet (BitMVec 0 n v) (extendToWord -> x) = case modWordSize n of+        0 ->  MV.basicSet v x+        nMod -> do+            let vLen = MV.basicLength v+            MV.basicSet (MV.slice 0 (vLen - 1) v) x+            MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1)+    basicSet (BitMVec s n v) (extendToWord -> x) = case modWordSize (s + n) of+        0 -> do+            let vLen = MV.basicLength v+            MV.basicSet (MV.slice 1 (vLen - 1) v) x+            MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0+        nMod -> do+            let vLen = MV.basicLength v+                lohiMask = loMask s .|. hiMask nMod+            if vLen == 1+                then MV.modify v (\val -> val .&. lohiMask .|. x .&. complement lohiMask) 0+                else do+                    MV.basicSet (MV.slice 1 (vLen - 2) v) x+                    MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0+                    MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1) -extendToWord :: Bit -> Word-extendToWord (Bit False) = 0-extendToWord (Bit True)  = complement 0+    {-# INLINE basicUnsafeCopy #-}+    basicUnsafeCopy _ (BitMVec _ 0 _) = pure ()+    basicUnsafeCopy (BitMVec 0 _ dst) (BitMVec 0 n src) = case modWordSize n of+        0 -> MV.basicUnsafeCopy dst src+        nMod -> do+            let vLen = MV.basicLength src+            MV.basicUnsafeCopy (MV.slice 0 (vLen - 1) dst) (MV.slice 0 (vLen - 1) src)+            valSrc <- MV.basicUnsafeRead src (vLen - 1)+            MV.modify dst (\val -> val .&. hiMask nMod .|. valSrc .&. loMask nMod) (vLen - 1)+    basicUnsafeCopy (BitMVec dstShift _ dst) (BitMVec s n src)+        | dstShift == s = case modWordSize (s + n) of+            0 -> do+                let vLen = MV.basicLength src+                MV.basicUnsafeCopy (MV.slice 1 (vLen - 1) dst) (MV.slice 1 (vLen - 1) src)+                valSrc <- MV.basicUnsafeRead src 0+                MV.modify dst (\val -> val .&. loMask s .|. valSrc .&. hiMask s) 0+            nMod -> do+                let vLen = MV.basicLength src+                    lohiMask = loMask s .|. hiMask nMod+                if vLen == 1+                    then do+                        valSrc <- MV.basicUnsafeRead src 0+                        MV.modify dst (\val -> val .&. lohiMask .|. valSrc .&. complement lohiMask) 0+                    else do+                        MV.basicUnsafeCopy (MV.slice 1 (vLen - 2) dst) (MV.slice 1 (vLen - 2) src)+                        valSrcFirst <- MV.basicUnsafeRead src 0+                        MV.modify dst (\val -> val .&. loMask s .|. valSrcFirst .&. hiMask s) 0+                        valSrcLast <- MV.basicUnsafeRead src (vLen - 1)+                        MV.modify dst (\val -> val .&. hiMask nMod .|. valSrcLast .&. loMask nMod) (vLen - 1) --- create a mask consisting of the lower n bits-mask :: Int -> Word-mask b = m-    where-        m   | b >= finiteBitSize m = complement 0-            | b < 0                = 0-            | otherwise            = bit b - 1+    basicUnsafeCopy dst@(BitMVec _ len _) src = do_copy 0+      where+        n = alignUp len -masked :: Int -> Word -> Word-masked b x = x .&. mask b+        do_copy i+            | i < n = do+                x <- readWord src i+                writeWord dst i x+                do_copy (i+wordSize)+            | otherwise = return () -isMasked :: Int -> Word -> Bool-isMasked b x = (masked b x == x)+    {-# INLINE basicUnsafeMove #-}+    basicUnsafeMove !dst !src@(BitMVec srcShift srcLen _)+        | MV.basicOverlaps dst src = do+            -- Align shifts of src and srcCopy to speed up basicUnsafeCopy srcCopy src+            -- TODO write tests on copy and move inside array+            srcCopy <- BitMVec srcShift srcLen <$> MV.basicUnsafeNew (nWords (srcShift + srcLen))+            MV.basicUnsafeCopy srcCopy src+            MV.basicUnsafeCopy dst srcCopy+        | otherwise = MV.basicUnsafeCopy dst src --- meld 2 words by taking the low 'b' bits from 'lo' and the rest from 'hi'-meld :: Int -> Word -> Word -> Word-meld b lo hi = (lo .&. m) .|. (hi .&. complement m)-    where m = mask b+    {-# INLINE basicUnsafeSlice #-}+    basicUnsafeSlice offset n (BitMVec s _ v) =+        BitMVec relStartBit n (MV.basicUnsafeSlice startWord (endWord - startWord) v)+            where+                absStartBit = s + offset+                relStartBit = modWordSize absStartBit+                absEndBit   = absStartBit + n+                endWord     = nWords absEndBit+                startWord   = divWordSize absStartBit --- given a bit offset 'k' and 2 words, extract a word by taking the 'k' highest bits of the first word and the 'wordSize - k' lowest bits of the second word.-{-# INLINE extractWord #-}-extractWord :: Int -> Word -> Word -> Word-extractWord k lo hi = (lo `shiftR` k) .|. (hi `shiftL` (wordSize - k))+    {-# INLINE basicUnsafeGrow #-}+    basicUnsafeGrow (BitMVec s n v) by =+        BitMVec s (n + by) <$> if delta == 0 then pure v else MV.basicUnsafeGrow v delta+        where+            delta = nWords (s + n + by) - nWords (s + n) --- given a bit offset 'k', 2 words 'lo' and 'hi' and a word 'x', overlay 'x' onto 'lo' and 'hi' at the position such that (k `elem` [0..wordSize] ==> uncurry (extractWord k) (spliceWord k lo hi x) == x) and (k `elem` [0..wordSize] ==> spliceWord k lo hi (extractWord k lo hi) == (lo,hi))-{-# INLINE spliceWord #-}-spliceWord :: Int -> Word -> Word -> Word -> (Word, Word)-spliceWord k lo hi x =-    ( meld k lo (x `shiftL` k)-    , meld k (x `shiftR` (wordSize - k)) hi-    )+#ifndef BITVEC_THREADSAFE --- this could be given a more general type, but it would be wrong; it works for any fixed word size, but only for unsigned types-reverseWord :: Word -> Word-reverseWord xx = foldr swap xx masks-    where-        nextMask (d, x) = (d', x `xor` shift x d')-            where !d' = d `shiftR` 1+-- | Flip the bit at the given position.+-- No bounds checks are performed.+-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.unsafeModify' 'Data.Bits.complement',+-- but slightly faster.+--+-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.unsafeModify' bit vectors:+-- either you modify it with 'id' (which is 'id' altogether)+-- or with 'Data.Bits.complement' (which is 'unsafeFlipBit').+--+-- >>> Data.Vector.Unboxed.modify (\v -> unsafeFlipBit v 1) (read "[1,1,1]")+-- [1,0,1]+unsafeFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()+unsafeFlipBit (BitMVec s _ v) !i' = do+    let i = s + i'+    let j = divWordSize i; k = modWordSize i; kk = 1 `unsafeShiftL` k+    w <- MV.basicUnsafeRead v j+    MV.basicUnsafeWrite v j (w `xor` kk)+{-# INLINE unsafeFlipBit #-} -        !(_:masks) =-            takeWhile ((0 /=) . snd)-            (iterate nextMask (finiteBitSize xx, maxBound))+-- | Flip the bit at the given position.+-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.modify' 'Data.Bits.complement',+-- but slightly faster.+--+-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.modify' bit vectors:+-- either you modify it with 'id' (which is 'id' altogether)+-- or with 'Data.Bits.complement' (which is 'flipBit').+--+-- >>> Data.Vector.Unboxed.modify (\v -> flipBit v 1) (read "[1,1,1]")+-- [1,0,1]+flipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()+flipBit v i = BOUNDS_CHECK(checkIndex) "flipBit" i (MV.length v) $ unsafeFlipBit v i+{-# INLINE flipBit #-} -        swap (n, m) x = ((x .&. m) `shiftL`  n) .|. ((x .&. complement m) `shiftR`  n)+#else -        -- TODO: is an unrolled version like "loop lgWordSize" faster than the generic implementation above?  If so, can that be fixed?-        -- loop 0 x = x-        -- loop 1 x = loop 0 (((x .&. 0x5555555555555555) `shiftL`  1) .|. ((x .&. 0xAAAAAAAAAAAAAAAA) `shiftR`  1))-        -- loop 2 x = loop 1 (((x .&. 0x3333333333333333) `shiftL`  2) .|. ((x .&. 0xCCCCCCCCCCCCCCCC) `shiftR`  2))-        -- loop 3 x = loop 2 (((x .&. 0x0F0F0F0F0F0F0F0F) `shiftL`  4) .|. ((x .&. 0xF0F0F0F0F0F0F0F0) `shiftR`  4))-        -- loop 4 x = loop 3 (((x .&. 0x00FF00FF00FF00FF) `shiftL`  8) .|. ((x .&. 0xFF00FF00FF00FF00) `shiftR`  8))-        -- loop 5 x = loop 4 (((x .&. 0x0000FFFF0000FFFF) `shiftL` 16) .|. ((x .&. 0xFFFF0000FFFF0000) `shiftR` 16))-        -- loop 6 x = loop 5 (((x .&. 0x00000000FFFFFFFF) `shiftL` 32) .|. ((x .&. 0xFFFFFFFF00000000) `shiftR` 32))-        -- loop _ _ = error "reverseWord only implemented for up to 64 bit words!"+-- | Flip the bit at the given position.+-- No bounds checks are performed.+-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.unsafeModify' 'Data.Bits.complement',+-- but slightly faster and atomic.+--+-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.unsafeModify' bit vectors:+-- either you modify it with 'id' (which is 'id' altogether)+-- or with 'Data.Bits.complement' (which is 'unsafeFlipBit').+--+-- >>> Data.Vector.Unboxed.modify (\v -> unsafeFlipBit v 1) (read "[1,1,1]")+-- [1,0,1]+unsafeFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()+unsafeFlipBit (BitMVec s _ (U.MV_Word (P.MVector o _ (MutableByteArray mba)))) !i' = do+    let i       = s + i'+        !(I# j) = o + divWordSize i+        !(I# k) = 1 `unsafeShiftL` modWordSize i+    primitive $ \state ->+        let !(# state', _ #) = fetchXorIntArray# mba j k state in+            (# state', () #)+{-# INLINE unsafeFlipBit #-} -reversePartialWord :: Int -> Word -> Word-reversePartialWord n w-    | n >= wordSize = reverseWord w-    | otherwise     = reverseWord w `shiftR` (wordSize - n)+-- | Flip the bit at the given position.+-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.modify' 'Data.Bits.complement',+-- but slightly faster and atomic+--+-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.modify' bit vectors:+-- either you modify it with 'id' (which is 'id' altogether)+-- or with 'Data.Bits.complement' (which is 'flipBit').+--+-- >>> Data.Vector.Unboxed.modify (\v -> flipBit v 1) (read "[1,1,1]")+-- [1,0,1]+flipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()+flipBit v i = BOUNDS_CHECK(checkIndex) "flipBit" i (MV.length v) $ unsafeFlipBit v i+{-# INLINE flipBit #-} -diff :: Word -> Word -> Word-diff w1 w2 = w1 .&. complement w2+#endif -ffs :: Word -> Maybe Int-ffs 0 = Nothing-ffs x = Just $! (popCount (x `xor` complement (-x)) - 1)+instance V.Vector U.Vector Bit where+    basicUnsafeFreeze (BitMVec s n v) = liftM (BitVec  s n) (V.basicUnsafeFreeze v)+    basicUnsafeThaw   (BitVec  s n v) = liftM (BitMVec s n) (V.basicUnsafeThaw   v)+    basicLength       (BitVec  _ n _) = n --- TODO: this can probably be faster--- the interface is very specialized here; 'j' is an offset to add to every bit index and the result is a difference list-bitsInWord :: Int -> Word -> [Int] -> [Int]-bitsInWord j = loop id+    basicUnsafeIndexM (BitVec s _ v) !i' = let i = s + i' in liftM (readBit (modWordSize i)) (V.basicUnsafeIndexM v (divWordSize i))++    basicUnsafeCopy dst src = do+        src1 <- V.basicUnsafeThaw src+        MV.basicUnsafeCopy dst src1++    {-# INLINE basicUnsafeSlice #-}+    basicUnsafeSlice offset n (BitVec s _ v) =+        BitVec relStartBit n (V.basicUnsafeSlice startWord (endWord - startWord) v)+            where+                absStartBit = s + offset+                relStartBit = modWordSize absStartBit+                absEndBit   = absStartBit + n+                endWord     = nWords absEndBit+                startWord   = divWordSize absStartBit++-- | Return the index of the @n@-th bit in the vector+-- with the specified value, if any.+-- Here @n@ is 1-based and the index is 0-based.+-- Non-positive @n@ results in an error.+--+-- >>> nthBitIndex (Bit True) 2 (read "[0,1,0,1,1,1,0]")+-- Just 3+-- >>> nthBitIndex (Bit True) 5 (read "[0,1,0,1,1,1,0]")+-- Nothing+--+-- One can use 'nthBitIndex' to implement+-- to implement @select{0,1}@ queries+-- for <https://en.wikipedia.org/wiki/Succinct_data_structure succinct dictionaries>.+nthBitIndex :: Bit -> Int -> U.Vector Bit -> Maybe Int+nthBitIndex _ k+    | k <= 0 = error "nthBitIndex: n must be positive"+nthBitIndex (Bit True) k = \case+    BitVec _ 0 _ -> Nothing+    BitVec 0 n v -> let l = V.basicLength v in case modWordSize n of+        0 -> case nth1InWords k v of+            Right x -> Just x+            Left{}  -> Nothing+        nMod -> case nth1InWords k (V.slice 0 (l - 1) v) of+            Right x -> Just x+            Left k' -> case nth1 k' (V.last v .&. loMask nMod) of+                Right x -> Just $ mulWordSize (l - 1) + x+                Left{}  -> Nothing+    BitVec s n v -> let l = V.basicLength v in case modWordSize (s + n) of+        0 -> case nth1 k (V.head v `unsafeShiftR` s) of+            Right x -> Just x+            Left k' -> case nth1InWords k' (V.slice 1 (l - 1) v) of+                Right x -> Just $ wordSize - s + x+                Left {} -> Nothing+        nMod -> case l of+            1 -> case nth1 k ((V.head v `unsafeShiftR` s) .&. loMask n) of+                Right x -> Just x+                Left{}  -> Nothing+            _ -> case nth1 k (V.head v `unsafeShiftR` s) of+                Right x -> Just x+                Left k' -> case nth1InWords k' (V.slice 1 (l - 2) v) of+                    Right x  -> Just $ wordSize - s + x+                    Left k'' -> case nth1 k'' (V.last v .&. loMask nMod) of+                        Right x -> Just $ mulWordSize (l - 1) - s + x+                        Left{}  -> Nothing+nthBitIndex (Bit False) k = \case+    BitVec _ 0 _ -> Nothing+    BitVec 0 n v -> let l = V.basicLength v in case modWordSize n of+        0 -> case nth0InWords k v of+            Right x -> Just x+            Left{}  -> Nothing+        nMod -> case nth0InWords k (V.slice 0 (l - 1) v) of+            Right x -> Just x+            Left k' -> case nth0 k' (V.last v .|. hiMask nMod) of+                Right x -> Just $ mulWordSize (l - 1) + x+                Left{}  -> Nothing+    BitVec s n v -> let l = V.basicLength v in case modWordSize (s + n) of+        0 -> case nth0 k (V.head v `unsafeShiftR` s .|. hiMask (wordSize - s)) of+            Right x -> Just x+            Left k' -> case nth0InWords k' (V.slice 1 (l - 1) v) of+                Right x -> Just $ wordSize - s + x+                Left {} -> Nothing+        nMod -> case l of+            1 -> case nth0 k ((V.head v `unsafeShiftR` s) .|. hiMask n) of+                Right x -> Just x+                Left{}  -> Nothing+            _ -> case nth0 k ((V.head v `unsafeShiftR` s) .|. hiMask (wordSize - s)) of+                Right x -> Just x+                Left k' -> case nth0InWords k' (V.slice 1 (l - 2) v) of+                    Right x  -> Just $ wordSize - s + x+                    Left k'' -> case nth0 k'' (V.last v .|. hiMask nMod) of+                        Right x -> Just $ mulWordSize (l - 1) - s + x+                        Left{}  -> Nothing++nth0 :: Int -> Word -> Either Int Int+nth0 k v = if k > c then Left (k - c) else Right (select1 w k - 1)     where-        loop is !w = case ffs w of-            Nothing -> is-            Just i  -> loop (is . (j + i :)) (clearBit w i)+        w = complement v+        c = popCount w --- TODO: faster!-selectWord :: Word -> Word -> (Int, Word)-selectWord m x = loop 0 0 0+nth1 :: Int -> Word -> Either Int Int+nth1 k w = if k > c then Left (k - c) else Right (select1 w k - 1)     where-        loop !i !ct !y-            | i >= wordSize = (ct, y)-            | testBit m i   = loop (i+1) (ct+1) (if testBit x i then setBit y ct else y)-            | otherwise     = loop (i+1) ct y+        c = popCount w++nth0InWords :: Int -> U.Vector Word -> Either Int Int+nth0InWords k vec = go 0 k+    where+        go n l+            | n >= U.length vec = Left l+            | otherwise = if l > c then go (n + 1) (l - c) else Right (mulWordSize n + select1 w l - 1)+            where+                w = complement (vec U.! n)+                c = popCount w++nth1InWords :: Int -> U.Vector Word -> Either Int Int+nth1InWords k vec = go 0 k+    where+        go n l+            | n >= U.length vec = Left l+            | otherwise = if l > c then go (n + 1) (l - c) else Right (mulWordSize n + select1 w l - 1)+            where+                w = vec U.! n+                c = popCount w++-- | Return the number of set bits in a vector (population count, popcount).+--+-- >>> countBits (read "[1,1,0,1,0,1]")+-- 4+--+-- One can combine 'countBits' with 'Data.Vector.Unboxed.take'+-- to implement @rank{0,1}@ queries+-- for <https://en.wikipedia.org/wiki/Succinct_data_structure succinct dictionaries>.+countBits :: U.Vector Bit -> Int+countBits (BitVec _ 0 _) = 0+countBits (BitVec 0 n v) = case modWordSize n of+    0    -> countBitsInWords v+    nMod -> countBitsInWords (V.slice 0 (l - 1) v) ++            popCount (V.last v .&. loMask nMod)+    where+        l = V.basicLength v+countBits (BitVec s n v) = case modWordSize (s + n) of+    0    -> popCount (V.head v `unsafeShiftR` s) ++            countBitsInWords (V.slice 1 (l - 1) v)+    nMod -> case l of+        1 -> popCount ((V.head v `unsafeShiftR` s) .&. loMask n)+        _ ->+            popCount (V.head v `unsafeShiftR` s) ++            countBitsInWords (V.slice 1 (l - 2) v) ++            popCount (V.last v .&. loMask nMod)+    where+        l = V.basicLength v++countBitsInWords :: U.Vector Word -> Int+countBitsInWords = U.foldl' (\acc word -> popCount word + acc) 0++-- | Return the indices of set bits in a vector.+--+-- >>> listBits (read "[1,1,0,1,0,1]")+-- [0,1,3,5]+listBits :: U.Vector Bit -> [Int]+listBits (BitVec _ 0 _) = []+listBits (BitVec 0 n v) = case modWordSize n of+    0    -> listBitsInWords 0 v []+    nMod -> listBitsInWords 0 (V.slice 0 (l - 1) v) $+            map (+ mulWordSize (l - 1)) $+            filter (testBit $ V.last v) [0 .. nMod - 1]+    where+        l = V.basicLength v+listBits (BitVec s n v) = case modWordSize (s + n) of+    0    -> filter (testBit $ V.head v `unsafeShiftR` s) [0 .. wordSize - s - 1] +++            listBitsInWords (wordSize - s) (V.slice 1 (l - 1) v) []+    nMod -> case l of+        1 -> filter (testBit $ V.head v `unsafeShiftR` s) [0 .. n - 1]+        _ ->+            filter (testBit $ V.head v `unsafeShiftR` s) [0 .. wordSize - s - 1] +++            (listBitsInWords (wordSize - s) (V.slice 1 (l - 2) v) $+            map (+ (mulWordSize (l - 1) - s)) $+            filter (testBit $ V.last v) [0 .. nMod - 1])+    where+        l = V.basicLength v++listBitsInWord :: Int -> Word -> [Int]+listBitsInWord offset word+    = map (+ offset)+    $ filter (testBit word)+    $ [0 .. wordSize - 1]++listBitsInWords :: Int -> U.Vector Word -> [Int] -> [Int]+listBitsInWords offset = flip $ U.ifoldr+    (\i word acc -> listBitsInWord (offset + mulWordSize i) word ++ acc)

@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Data/Bit/Internal.hs"

@@ -0,0 +1,239 @@+{-# LANGUAGE CPP              #-}++{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes       #-}++#ifndef BITVEC_THREADSAFE+module Data.Bit.Mutable+#else+module Data.Bit.MutableTS+#endif+     ( castFromWordsM+     , castToWordsM+     , cloneToWordsM++     , zipInPlace++     , invertInPlace+     , selectBitsInPlace+     , excludeBitsInPlace++     , reverseInPlace+     ) where++import           Control.Monad+import           Control.Monad.Primitive+#ifndef BITVEC_THREADSAFE+import           Data.Bit.Internal+#else+import           Data.Bit.InternalTS+#endif+import           Data.Bit.Utils+import           Data.Bits+import qualified Data.Vector.Generic.Mutable       as MV+import qualified Data.Vector.Generic               as V+import qualified Data.Vector.Unboxed               as U (Vector)+import           Data.Vector.Unboxed.Mutable       as U+import           Data.Word+import           Prelude                           as P+    hiding (and, or, any, all, reverse)++-- | Cast a vector of words to a vector of bits.+-- Cf. 'Data.Bit.castFromWords'.+castFromWordsM+    :: U.MVector s Word+    -> U.MVector s Bit+castFromWordsM ws = BitMVec 0 (nBits (MV.length ws)) ws++-- | Try to cast a vector of bits to a vector of words.+-- It succeeds if a vector of bits is aligned.+-- Use 'cloneToWordsM' otherwise.+-- Cf. 'Data.Bit.castToWords'.+castToWordsM+    :: U.MVector s Bit+    -> Maybe (U.MVector s Word)+castToWordsM (BitMVec s n ws)+    | aligned s+    , aligned n+    = Just $ MV.slice (divWordSize s) (nWords n) ws+    | otherwise+    = Nothing++-- | Clone a vector of bits to a new unboxed vector of words.+-- If the bits don't completely fill the words, the last word will be zero-padded.+-- Cf. 'Data.Bit.cloneToWords'.+cloneToWordsM+    :: PrimMonad m+    => U.MVector (PrimState m) Bit+    -> m (U.MVector (PrimState m) Word)+cloneToWordsM v@(BitMVec _ n _) = do+    ws <- MV.new (nWords n)+    let loop !i !j+            | i >= n    = return ()+            | otherwise = do+                readWord v i >>= MV.write ws j+                loop (i + wordSize) (j + 1)+    loop 0 0+    return ws+{-# INLINE cloneToWordsM #-}++-- |Map a function over a bit vector one 'Word' at a time ('wordSize' bits at a time).  The function will be passed the bit index (which will always be 'wordSize'-aligned) and the current value of the corresponding word.  The returned word will be written back to the vector.  If there is a partial word at the end of the vector, it will be zero-padded when passed to the function and truncated when the result is written back to the array.+{-# INLINE mapMInPlaceWithIndex #-}+mapMInPlaceWithIndex ::+    PrimMonad m =>+        (Int -> Word -> m Word)+     -> U.MVector (PrimState m) Bit -> m ()+mapMInPlaceWithIndex f xs@(BitMVec 0 _ v) = loop 0 0+    where+        !n_ = alignDown (MV.length xs)+        loop !i !j+            | i >= n_   = when (n_ /= MV.length xs) $ do+                readWord xs i >>= f i >>= writeWord xs i++            | otherwise = do+                MV.read v j >>= f i >>= MV.write v j+                loop (i + wordSize) (j + 1)+mapMInPlaceWithIndex f xs = loop 0+    where+        !n = MV.length xs+        loop !i+            | i >= n    = return ()+            | otherwise = do+                readWord xs i >>= f i >>= writeWord xs i+                loop (i + wordSize)++{-# INLINE mapInPlaceWithIndex #-}+mapInPlaceWithIndex ::+    PrimMonad m =>+        (Int -> Word -> Word)+     -> U.MVector (PrimState m) Bit -> m ()+mapInPlaceWithIndex f = mapMInPlaceWithIndex g+    where+        {-# INLINE g #-}+        g i x = return $! f i x++{-# INLINE mapInPlace #-}+mapInPlace :: PrimMonad m => (Word -> Word) -> U.MVector (PrimState m) Bit -> m ()+mapInPlace f = mapMInPlaceWithIndex (\_ x -> return (f x))++-- | Zip two vectors with the given function.+-- rewriting contents of the second argument.+-- Cf. 'Data.Bit.zipBits'.+--+-- >>> import Data.Bits+-- >>> modify (zipInPlace (.&.) (read "[1,1,0]")) (read "[0,1,1]")+-- [0,1,0]+--+-- __Warning__: if the immutable vector is shorter than the mutable one,+-- it is a caller's responsibility to trim the result:+--+-- >>> import Data.Bits+-- >>> modify (zipInPlace (.&.) (read "[1,1,0]")) (read "[0,1,1,1,1,1]")+-- [0,1,0,1,1,1] -- note trailing garbage+zipInPlace+    :: PrimMonad m+    => (forall a. Bits a => a -> a -> a)+    -> U.Vector Bit+    -> U.MVector (PrimState m) Bit+    -> m ()+zipInPlace f ys@(BitVec 0 n2 v) xs =+    mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs)+    where+        -- WARNING: relies on guarantee by mapMInPlaceWithIndex that index will always be aligned!+        !n = min (MV.length xs) (V.length ys)+        {-# INLINE g #-}+        g !i !x =+            let !w = masked (n2 - i) (v V.! divWordSize i)+             in f w x+zipInPlace f ys xs =+    mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs)+    where+        !n = min (MV.length xs) (V.length ys)+        {-# INLINE g #-}+        g !i !x =+            let !w = indexWord ys i+             in f w x+{-# INLINE zipInPlace #-}++-- | Invert (flip) all bits in-place.+--+-- Combine with 'Data.Vector.Unboxed.modify'+-- to operate on immutable vectors.+--+-- >>> Data.Vector.Unboxed.modify invertInPlace (read "[0,1,0,1,0]")+-- [1,0,1,0,1]+invertInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()+invertInPlace = mapInPlace complement++-- | Same as 'Data.Bit.selectBits', but deposit+-- selected bits in-place. Returns a number of selected bits.+-- It is caller's resposibility to trim the result to this number.+selectBitsInPlace+    :: PrimMonad m+    => U.Vector Bit+    -> U.MVector (PrimState m) Bit+    -> m Int+selectBitsInPlace is xs = loop 0 0+    where+        !n = min (V.length is) (MV.length xs)+        loop !i !ct+            | i >= n    = return ct+            | otherwise = do+                x <- readWord xs i+                let !(nSet, x') = selectWord (masked (n - i) (indexWord is i)) x+                writeWord xs ct x'+                loop (i + wordSize) (ct + nSet)++-- | Same as 'Data.Bit.excludeBits', but deposit+-- excluded bits in-place. Returns a number of excluded bits.+-- It is caller's resposibility to trim the result to this number.+excludeBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int+excludeBitsInPlace is xs = loop 0 0+    where+        !n = min (V.length is) (MV.length xs)+        loop !i !ct+            | i >= n    = return ct+            | otherwise = do+                x <- readWord xs i+                let !(nSet, x') = selectWord (masked (n - i) (complement (indexWord is i))) x+                writeWord xs ct x'+                loop (i + wordSize) (ct + nSet)++-- | Reverse the order of bits in-place.+--+-- Combine with 'Data.Vector.Unboxed.modify'+-- to operate on immutable vectors.+--+-- >>> Data.Vector.Unboxed.modify reverseInPlace (read "[1,1,0,1,0]")+-- [0,1,0,1,1]+reverseInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()+reverseInPlace xs = loop 0 (MV.length xs)+    where+        loop !i !j+            | i' <= j'  = do+                x <- readWord xs i+                y <- readWord xs j'++                writeWord xs i  (reverseWord y)+                writeWord xs j' (reverseWord x)++                loop i' j'+            | i' < j    = do+                let w = (j - i) `shiftR` 1+                    k  = j - w+                x <- readWord xs i+                y <- readWord xs k++                writeWord xs i (meld w (reversePartialWord w y) x)+                writeWord xs k (meld w (reversePartialWord w x) y)++                loop i' j'+            | i  < j    = do+                let w = j - i+                x <- readWord xs i+                writeWord xs i (meld w (reversePartialWord w x) x)+            | otherwise = return ()+            where+                !i' = i + wordSize+                !j' = j - wordSize

@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Data/Bit/Mutable.hs"

@@ -0,0 +1,147 @@+-- |+-- Module:      Data.Bit.Select1+-- Copyright:   (c) 2016 John Ky+-- Licence:     BSD3+--+-- This is a modification of "HaskellWorks.Data.RankSelect.Base.Internal"+-- from hw-rankselect-base package.++{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+#endif++module Data.Bit.Select1+    ( select1+    ) where++#include "MachDeps.h"++import Data.Bits+#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED)+import Data.Bits.Pdep+import Data.Int+#endif+import Data.Word++infixl 8 .>.+(.>.) :: Bits a => a -> Int -> a+(.>.) = shiftR++infixl 8 .<.+(.<.) :: Bits a => a -> Int -> a+(.<.) = shiftL++#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED)++select1Word64Bmi2Base0 :: Word64 -> Word64 -> Word64+select1Word64Bmi2Base0 w r = fromIntegral (countTrailingZeros (pdep (1 .<. fromIntegral r) w))+{-# INLINE select1Word64Bmi2Base0 #-}++select1Word64Bmi2 :: Word64 -> Word64 -> Word64+select1Word64Bmi2 w r =+  let zeros = countTrailingZeros (pdep (1 .<. fromIntegral (r - 1)) w) :: Int+      mask  = fromIntegral ((fromIntegral (zeros .<. 57) :: Int64) `shiftR` 63) :: Word64+  in (fromIntegral zeros .|. mask) + 1+{-# INLINE select1Word64Bmi2 #-}++select1Word32Bmi2 :: Word32 -> Word64 -> Word64+select1Word32Bmi2 w r =+  let zeros = countTrailingZeros (pdep (1 .<. fromIntegral (r - 1)) w) :: Int+      mask  = fromIntegral ((fromIntegral (zeros .<. 58) :: Int64) `shiftR` 63) :: Word64+  in (fromIntegral zeros .|. mask) + 1+{-# INLINE select1Word32Bmi2 #-}++#endif++select1Word64Broadword :: Word64 -> Word64 -> Word64+select1Word64Broadword _ 0 = 0+select1Word64Broadword v rn =+  -- Do a normal parallel bit count for a 64-bit integer,+  -- but store all intermediate steps.+  let a = (v .&. 0x5555555555555555) + ((v .>.  1) .&. 0x5555555555555555)    in+  let b = (a .&. 0x3333333333333333) + ((a .>.  2) .&. 0x3333333333333333)    in+  let c = (b .&. 0x0f0f0f0f0f0f0f0f) + ((b .>.  4) .&. 0x0f0f0f0f0f0f0f0f)    in+  let d = (c .&. 0x00ff00ff00ff00ff) + ((c .>.  8) .&. 0x00ff00ff00ff00ff)    in+  let e = (d .&. 0x0000ffff0000ffff) + ((d .>. 16) .&. 0x0000ffff0000ffff)    in+  let f = (e .&. 0x00000000ffffffff) + ((e .>. 32) .&. 0x00000000ffffffff)    in+  -- Now do branchless select!+  let r0 = f + 1 - fromIntegral rn                                            in+  let s0 = 64 :: Word64                                                       in+  let t0 = (d .>. 32) + (d .>. 48)                                            in+  let s1 = s0 - ((t0 - r0) .&. 256) .>. 3                                     in+  let r1 = r0 - (t0 .&. ((t0 - r0) .>. 8))                                    in+  let t1 =      (d .>. fromIntegral (s1 - 16)) .&. 0xff                       in+  let s2 = s1 - ((t1 - r1) .&. 256) .>. 4                                     in+  let r2 = r1 - (t1 .&. ((t1 - r1) .>. 8))                                    in+  let t2 =      (c .>. fromIntegral (s2 - 8))  .&. 0xf                        in+  let s3 = s2 - ((t2 - r2) .&. 256) .>. 5                                     in+  let r3 = r2 - (t2 .&. ((t2 - r2) .>. 8))                                    in+  let t3 =      (b .>. fromIntegral (s3 - 4))  .&. 0x7                        in+  let s4 = s3 - ((t3 - r3) .&. 256) .>. 6                                     in+  let r4 = r3 - (t3 .&. ((t3 - r3) .>. 8))                                    in+  let t4 =      (a .>. fromIntegral (s4 - 2))  .&. 0x3                        in+  let s5 = s4 - ((t4 - r4) .&. 256) .>. 7                                     in+  let r5 = r4 - (t4 .&. ((t4 - r4) .>. 8))                                    in+  let t5 =      (v .>. fromIntegral (s5 - 1))  .&. 0x1                        in+  let s6 = s5 - ((t5 - r5) .&. 256) .>. 8                                     in+  fromIntegral s6+{-# INLINE select1Word64Broadword #-}++select1Word32Broadword :: Word32 -> Word64 -> Word64+select1Word32Broadword _ 0 = 0+select1Word32Broadword v rn =+  -- Do a normal parallel bit count for a 64-bit integer,+  -- but store all intermediate steps.+  let a = (v .&. 0x55555555) + ((v .>.  1) .&. 0x55555555)    in+  let b = (a .&. 0x33333333) + ((a .>.  2) .&. 0x33333333)    in+  let c = (b .&. 0x0f0f0f0f) + ((b .>.  4) .&. 0x0f0f0f0f)    in+  let d = (c .&. 0x00ff00ff) + ((c .>.  8) .&. 0x00ff00ff)    in+  let e = (d .&. 0x000000ff) + ((d .>. 16) .&. 0x000000ff)    in+  -- Now do branchless select!+  let r0 = e + 1 - fromIntegral rn                                            in+  let s0 = 64 :: Word32                                                       in+  let t0 = (d .>. 32) + (d .>. 48)                                            in+  let s1 = s0 - ((t0 - r0) .&. 256) .>. 3                                     in+  let r1 = r0 - (t0 .&. ((t0 - r0) .>. 8))                                    in+  let t1 =      (d .>. fromIntegral (s1 - 16)) .&. 0xff                       in+  let s2 = s1 - ((t1 - r1) .&. 256) .>. 4                                     in+  let r2 = r1 - (t1 .&. ((t1 - r1) .>. 8))                                    in+  let t2 =      (c .>. fromIntegral (s2 - 8))  .&. 0xf                        in+  let s3 = s2 - ((t2 - r2) .&. 256) .>. 5                                     in+  let r3 = r2 - (t2 .&. ((t2 - r2) .>. 8))                                    in+  let t3 =      (b .>. fromIntegral (s3 - 4))  .&. 0x7                        in+  let s4 = s3 - ((t3 - r3) .&. 256) .>. 6                                     in+  let r4 = r3 - (t3 .&. ((t3 - r3) .>. 8))                                    in+  let t4 =      (a .>. fromIntegral (s4 - 2))  .&. 0x3                        in+  let s5 = s4 - ((t4 - r4) .&. 256) .>. 7                                     in+  let r5 = r4 - (t4 .&. ((t4 - r4) .>. 8))                                    in+  let t5 =      (v .>. fromIntegral (s5 - 1))  .&. 0x1                        in+  let s6 = s5 - ((t5 - r5) .&. 256) .>. 8                                     in+  fromIntegral s6+{-# INLINE select1Word32Broadword #-}++select1Word64 :: Word64 -> Word64 -> Word64+#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED)+select1Word64 = select1Word64Bmi2+#else+select1Word64 = select1Word64Broadword+#endif+{-# INLINE select1Word64 #-}++select1Word32 :: Word32 -> Word64 -> Word64+#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED)+select1Word32 = select1Word32Bmi2+#else+select1Word32 = select1Word32Broadword+#endif+{-# INLINE select1Word32 #-}++select1 :: Word -> Int -> Int+#if WORD_SIZE_IN_BITS == 64+select1 w i = fromIntegral $ select1Word64 (fromIntegral w) (fromIntegral i)+#else+select1 w i = fromIntegral $ select1Word32 (fromIntegral w) (fromIntegral i)+#endif+{-# INLINE select1 #-}

@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Data/Bit.hs"

@@ -0,0 +1,153 @@+{-# LANGUAGE BangPatterns               #-}++module Data.Bit.Utils where++import Data.Bits+import Data.List++-- various internal utility functions and constants++lg2 :: Int -> Int+lg2 n = i+    where Just i = findIndex (>= toInteger n) (iterate (`shiftL` 1) 1)+++-- |The number of bits in a 'Word'.  A handy constant to have around when defining 'Word'-based bulk operations on bit vectors.+wordSize :: Int+wordSize = finiteBitSize (0 :: Word)++lgWordSize, wordSizeMask, wordSizeMaskC :: Int+lgWordSize = case wordSize of+    32 -> 5+    64 -> 6+    _  -> lg2 wordSize++wordSizeMask = wordSize - 1+wordSizeMaskC = complement wordSizeMask++divWordSize :: Bits a => a -> a+divWordSize x = unsafeShiftR x lgWordSize+{-# INLINE divWordSize #-}++modWordSize :: Int -> Int+modWordSize x = x .&. (wordSize - 1)+{-# INLINE modWordSize #-}++mulWordSize :: Bits a => a -> a+mulWordSize x = unsafeShiftL x lgWordSize++-- number of words needed to store n bits+nWords :: Int -> Int+nWords ns = divWordSize (ns + wordSize - 1)++-- number of bits storable in n words+nBits :: Bits a => a -> a+nBits ns = mulWordSize ns++aligned :: Int -> Bool+aligned    x = (x .&. wordSizeMask == 0)++notAligned :: Int -> Bool+notAligned x = x /= alignDown x++-- round a number of bits up to the nearest multiple of word size+alignUp :: Int -> Int+alignUp x+    | x == x'   = x'+    | otherwise = x' + wordSize+    where x' = alignDown x++-- round a number of bits down to the nearest multiple of word size+alignDown :: Int -> Int+alignDown x = x .&. wordSizeMaskC++-- create a mask consisting of the lower n bits+mask :: Int -> Word+mask b = m+    where+        m   | b >= finiteBitSize m = complement 0+            | b < 0                = 0+            | otherwise            = bit b - 1++masked :: Int -> Word -> Word+masked b x = x .&. mask b++isMasked :: Int -> Word -> Bool+isMasked b x = (masked b x == x)++-- meld 2 words by taking the low 'b' bits from 'lo' and the rest from 'hi'+meld :: Int -> Word -> Word -> Word+meld b lo hi = (lo .&. m) .|. (hi .&. complement m)+    where m = mask b++-- given a bit offset 'k' and 2 words, extract a word by taking the 'k' highest bits of the first word and the 'wordSize - k' lowest bits of the second word.+{-# INLINE extractWord #-}+extractWord :: Int -> Word -> Word -> Word+extractWord k lo hi = (lo `shiftR` k) .|. (hi `shiftL` (wordSize - k))++-- given a bit offset 'k', 2 words 'lo' and 'hi' and a word 'x', overlay 'x' onto 'lo' and 'hi' at the position such that (k `elem` [0..wordSize] ==> uncurry (extractWord k) (spliceWord k lo hi x) == x) and (k `elem` [0..wordSize] ==> spliceWord k lo hi (extractWord k lo hi) == (lo,hi))+{-# INLINE spliceWord #-}+spliceWord :: Int -> Word -> Word -> Word -> (Word, Word)+spliceWord k lo hi x =+    ( meld k lo (x `shiftL` k)+    , meld k (x `shiftR` (wordSize - k)) hi+    )++-- this could be given a more general type, but it would be wrong; it works for any fixed word size, but only for unsigned types+reverseWord :: Word -> Word+reverseWord xx = foldr swap xx masks+    where+        nextMask (d, x) = (d', x `xor` shift x d')+            where !d' = d `shiftR` 1++        !(_:masks) =+            takeWhile ((0 /=) . snd)+            (iterate nextMask (finiteBitSize xx, maxBound))++        swap (n, m) x = ((x .&. m) `shiftL`  n) .|. ((x .&. complement m) `shiftR`  n)++        -- TODO: is an unrolled version like "loop lgWordSize" faster than the generic implementation above?  If so, can that be fixed?+        -- loop 0 x = x+        -- loop 1 x = loop 0 (((x .&. 0x5555555555555555) `shiftL`  1) .|. ((x .&. 0xAAAAAAAAAAAAAAAA) `shiftR`  1))+        -- loop 2 x = loop 1 (((x .&. 0x3333333333333333) `shiftL`  2) .|. ((x .&. 0xCCCCCCCCCCCCCCCC) `shiftR`  2))+        -- loop 3 x = loop 2 (((x .&. 0x0F0F0F0F0F0F0F0F) `shiftL`  4) .|. ((x .&. 0xF0F0F0F0F0F0F0F0) `shiftR`  4))+        -- loop 4 x = loop 3 (((x .&. 0x00FF00FF00FF00FF) `shiftL`  8) .|. ((x .&. 0xFF00FF00FF00FF00) `shiftR`  8))+        -- loop 5 x = loop 4 (((x .&. 0x0000FFFF0000FFFF) `shiftL` 16) .|. ((x .&. 0xFFFF0000FFFF0000) `shiftR` 16))+        -- loop 6 x = loop 5 (((x .&. 0x00000000FFFFFFFF) `shiftL` 32) .|. ((x .&. 0xFFFFFFFF00000000) `shiftR` 32))+        -- loop _ _ = error "reverseWord only implemented for up to 64 bit words!"++reversePartialWord :: Int -> Word -> Word+reversePartialWord n w+    | n >= wordSize = reverseWord w+    | otherwise     = reverseWord w `shiftR` (wordSize - n)++diff :: Bits a => a -> a -> a+diff w1 w2 = w1 .&. complement w2++ffs :: Word -> Maybe Int+ffs 0 = Nothing+ffs x = Just $! (popCount (x `xor` complement (-x)) - 1)++-- TODO: this can probably be faster+-- the interface is very specialized here; 'j' is an offset to add to every bit index and the result is a difference list+bitsInWord :: Int -> Word -> [Int] -> [Int]+bitsInWord j = loop id+    where+        loop is !w = case ffs w of+            Nothing -> is+            Just i  -> loop (is . (j + i :)) (clearBit w i)++-- TODO: faster!+selectWord :: Word -> Word -> (Int, Word)+selectWord m x = loop 0 0 0+    where+        loop !i !ct !y+            | i >= wordSize = (ct, y)+            | testBit m i   = loop (i+1) (ct+1) (if testBit x i then setBit y ct else y)+            | otherwise     = loop (i+1) ct y++loMask :: Int -> Word+loMask n = 1 `shiftL` n - 1++hiMask :: Int -> Word+hiMask n = complement (1 `shiftL` n - 1)

@@ -1,252 +0,0 @@-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE BangPatterns               #-}--module Data.Vector.Unboxed.Bit-     ( wordSize-     , wordLength-     , fromWords-     , toWords-     , indexWord--     , pad-     , padWith--     , zipWords--     , union-     , unions--     , intersection-     , intersections-     , difference-     , symDiff--     , invert--     , select-     , selectBits--     , exclude-     , excludeBits--     , countBits-     , listBits--     , and-     , or--     , any-     , anyBits-     , all-     , allBits--     , reverse--     , first-     , findIndex-     ) where--import           Control.Monad-import           Control.Monad.ST-import           Data.Bit.Internal-import           Data.Bits-import qualified Data.List                          as L-import qualified Data.Vector.Generic                as V-import qualified Data.Vector.Generic.Mutable        as MV-import           Data.Vector.Unboxed                as U-    hiding (and, or, any, all, reverse, findIndex)-import qualified Data.Vector.Unboxed                as Unsafe-import qualified Data.Vector.Unboxed.Mutable.Bit    as B-import           Data.Vector.Unboxed.Bit.Internal-import           Data.Word-import           Prelude                            as P-    hiding (and, or, any, all, reverse)--wordLength :: U.Vector Bit -> Int-wordLength = nWords . U.length---- |Given a number of bits and a vector of words, concatenate them to a vector of bits (interpreting the words in little-endian order, as described at 'indexWord').  If there are not enough words for the number of bits requested, the vector will be zero-padded.-fromWords :: Int -> U.Vector Word -> U.Vector Bit-fromWords n ws-    | n <= m    = BitVec 0 n (V.take (nWords n) ws)-    | otherwise = pad n (BitVec 0 m ws)-    where-         m = nBits (V.length ws)---- |Given a vector of bits, extract an unboxed vector of words.  If the bits don't completely fill the words, the last word will be zero-padded.-toWords :: U.Vector Bit -> U.Vector Word-toWords v@(BitVec s n ws)-    | aligned s && (aligned n || isMasked (modWordSize n) (ws V.! divWordSize n))-         = V.slice (divWordSize s) (nWords n) ws-    | otherwise = runST (Unsafe.unsafeThaw v >>= cloneWords >>= Unsafe.unsafeFreeze)---- | @zipWords f xs ys@ = @fromWords (min (length xs) (length ys)) (zipWith f (toWords xs) (toWords ys))@-{-# INLINE zipWords #-}-zipWords :: (Word -> Word -> Word) -> U.Vector Bit -> U.Vector Bit -> U.Vector Bit-zipWords op xs ys-    | V.length xs > V.length ys =-        zipWords (flip op) ys xs-    | otherwise =  runST $ do-        -- TODO: eliminate this extra traversal-        xs1 <- V.thaw xs-        B.zipInPlace op xs1 ys-        Unsafe.unsafeFreeze xs1---- |(internal) N-ary 'zipWords' with specified output length.  Makes all kinds of assumptions; mainly only valid for union and intersection.-{-# INLINE zipMany #-}-zipMany :: Word -> (Word -> Word -> Word) -> Int -> [U.Vector Bit] -> U.Vector Bit-zipMany z op n xss = runST $ do-    ys <- MV.new n-    B.mapInPlace (const z) ys-    P.mapM_ (B.zipInPlace op ys) xss-    Unsafe.unsafeFreeze ys--union :: Vector Bit -> Vector Bit -> Vector Bit-union = zipWords (.|.)--intersection :: Vector Bit -> Vector Bit -> Vector Bit-intersection = zipWords (.&.)--difference :: Vector Bit -> Vector Bit -> Vector Bit-difference = zipWords diff--symDiff :: Vector Bit -> Vector Bit -> Vector Bit-symDiff = zipWords xor--unions :: Int -> [U.Vector Bit] -> U.Vector Bit-unions = zipMany 0 (.|.)--intersections :: Int -> [U.Vector Bit] -> U.Vector Bit-intersections = zipMany (complement 0) (.&.)---- |Flip every bit in the given vector-invert :: U.Vector Bit -> U.Vector Bit-invert xs = runST $ do-    ys <- MV.new (V.length xs)-    let f i _ = complement (indexWord xs i)-    B.mapInPlaceWithIndex f ys-    Unsafe.unsafeFreeze ys---- | Given a vector of bits and a vector of things, extract those things for which the corresponding bit is set.------ For example, @select (V.map (fromBool . p) x) x == V.filter p x@.-select :: (V.Vector v1 Bit, V.Vector v2 t) => v1 Bit -> v2 t -> [t]-select is xs = L.unfoldr next 0-    where-        n = min (V.length is) (V.length xs)--        next j-            | j >= n           = Nothing-            | unBit (is V.! j) = Just (xs V.! j, j + 1)-            | otherwise        = next           (j + 1)---- | Given a vector of bits and a vector of things, extract those things for which the corresponding bit is unset.------ For example, @exclude (V.map (fromBool . p) x) x == V.filter (not . p) x@.-exclude :: (V.Vector v1 Bit, V.Vector v2 t) => v1 Bit -> v2 t -> [t]-exclude is xs = L.unfoldr next 0-    where-        n = min (V.length is) (V.length xs)--        next j-            | j >= n           = Nothing-            | unBit (is V.! j) = next           (j + 1)-            | otherwise        = Just (xs V.! j, j + 1)--selectBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit-selectBits is xs = runST $ do-    xs1 <- U.thaw xs-    n <- B.selectBitsInPlace is xs1-    Unsafe.unsafeFreeze (MV.take n xs1)--excludeBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit-excludeBits is xs = runST $ do-    xs1 <- U.thaw xs-    n <- B.excludeBitsInPlace is xs1-    Unsafe.unsafeFreeze (MV.take n xs1)---- |return the number of ones in a bit vector-countBits :: U.Vector Bit -> Int-countBits v = loop 0 0-    where-        !n = alignUp (V.length v)-        loop !s !i-            | i >= n    = s-            | otherwise = loop (s + popCount (indexWord v i)) (i + wordSize)--listBits :: U.Vector Bit -> [Int]-listBits v = loop id 0-    where-        !n = V.length v-        loop bs !i-            | i >= n    = bs []-            | otherwise =-                loop (bs . bitsInWord i (indexWord v i)) (i + wordSize)---- | 'True' if all bits in the vector are set-and :: U.Vector Bit -> Bool-and v = loop 0-    where-        !n = V.length v-        loop !i-            | i >= n    = True-            | otherwise = (indexWord v i == mask (n-i))-                        && loop (i + wordSize)---- | 'True' if any bit in the vector is set-or :: U.Vector Bit -> Bool-or v = loop 0-    where-        !n = V.length v-        loop !i-            | i >= n    = False-            | otherwise = (indexWord v i /= 0)-                        || loop (i + wordSize)--all :: (Bit -> Bool) -> Vector Bit -> Bool-all p = case (p (Bit False), p (Bit True)) of-    (False, False) -> U.null-    (False,  True) -> allBits (Bit True)-    (True,  False) -> allBits (Bit False)-    (True,   True) -> flip seq True--any :: (Bit -> Bool) -> Vector Bit -> Bool-any p = case (p (Bit False), p (Bit True)) of-    (False, False) -> flip seq False-    (False,  True) -> anyBits (Bit True)-    (True,  False) -> anyBits (Bit False)-    (True,   True) -> not . U.null--allBits, anyBits :: Bit -> U.Vector Bit -> Bool-allBits (Bit False) = not . or-allBits (Bit True) = and--anyBits (Bit False) = not . and-anyBits (Bit True) = or--reverse :: U.Vector Bit -> U.Vector Bit-reverse xs = runST $ do-    let !n = V.length xs-        f i _ = reversePartialWord (n - i) (indexWord xs (max 0 (n - i - wordSize)))-    ys <- MV.new n-    B.mapInPlaceWithIndex f ys-    Unsafe.unsafeFreeze ys---- |Return the address of the first bit in the vector with the specified value, if any-first :: Bit -> U.Vector Bit -> Maybe Int-first b xs = mfilter (< n) (loop 0)-    where-        !n = V.length xs-        !ff | unBit b   = ffs-            | otherwise = ffs . complement--        loop !i-            | i >= n    = Nothing-            | otherwise = fmap (i +) (ff (indexWord xs i)) `mplus` loop (i + wordSize)--findIndex :: (Bit -> Bool) -> Vector Bit -> Maybe Int-findIndex p xs = case (p (Bit False), p (Bit True)) of-    (False, False) -> Nothing-    (False,  True) -> first (Bit True)  xs-    (True,  False) -> first (Bit False) xs-    (True,   True) -> if V.null xs then Nothing else Just 0

@@ -1,299 +0,0 @@-{-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE ViewPatterns          #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Data.Vector.Unboxed.Bit.Internal-     ( Bit-     , U.Vector(BitVec)-     , U.MVector(BitMVec)--     , padWith-     , pad--     , indexWord-     , readWord-     , writeWord-     , cloneWords-     ) where--import           Control.Monad-import           Control.Monad.ST-import           Control.Monad.Primitive-import           Data.Bit.Internal-import           Data.Bits-import qualified Data.Vector.Generic         as V-import qualified Data.Vector.Generic.Mutable as MV-import qualified Data.Vector.Unboxed         as U---- Ints are offset and length in bits-data instance U.MVector s Bit = BitMVec !Int !Int !(U.MVector s Word)-data instance U.Vector    Bit = BitVec  !Int !Int !(U.Vector    Word)---- TODO: allow partial words to be read/written at beginning?---- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.).  If the offset is such that the word extends past the end of the vector, the result is zero-padded.-indexWord :: U.Vector Bit -> Int -> Word-indexWord (BitVec 0 n v) i-    | aligned i         = masked b lo-    | j + 1 == nWords n = masked b (extractWord k lo 0 )-    | otherwise         = masked b (extractWord k lo hi)-        where-            b = n - i-            j  = divWordSize i-            k  = modWordSize i-            lo = v V.!  j-            hi = v V.! (j+1)-indexWord (BitVec s n v) i = indexWord (BitVec 0 (n + s) v) (i + s)---- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.).  If the offset is such that the word extends past the end of the vector, the result is zero-padded.-readWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m Word-readWord (BitMVec 0 n v) i-    | aligned i         = liftM (masked b) lo-    | j + 1 == nWords n = liftM (masked b) (liftM2 (extractWord k) lo (return 0))-    | otherwise         = liftM (masked b) (liftM2 (extractWord k) lo hi)-        where-            b = n - i-            j = divWordSize i-            k = modWordSize i-            lo = MV.read v  j-            hi = MV.read v (j+1)-readWord (BitMVec s n v) i = readWord (BitMVec 0 (n + s) v) (i + s)---- | write a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.).  If the offset is such that the word extends past the end of the vector, the word is truncated and as many low-order bits as possible are written.-writeWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> Word -> m ()-writeWord (BitMVec 0 n v) i x-    | aligned i    =-        if b < wordSize-            then do-                y <- MV.read v j-                MV.write v j (meld b x y)-            else MV.write v j x-    | j + 1 == nWords n = do-        lo <- MV.read v  j-        let x' = if b < wordSize-                    then meld b x (extractWord k lo 0)-                    else x-            (lo', _hi) = spliceWord k lo 0 x'-        MV.write v  j    lo'-    | otherwise    = do-        lo <- MV.read v  j-        hi <- if j + 1 == nWords n-            then return 0-            else MV.read v (j+1)-        let x' = if b < wordSize-                    then meld b x (extractWord k lo hi)-                    else x-            (lo', hi') = spliceWord k lo hi x'-        MV.write v  j    lo'-        MV.write v (j+1) hi'-    where-        b = n - i-        j  = divWordSize i-        k  = modWordSize i-writeWord (BitMVec s n v) i x = writeWord (BitMVec 0 (n + s) v) (i + s) x---- clone words from a bit-array into a new word array, without attempting any shortcuts (such as recognizing that they are already aligned, etc.)-{-# INLINE cloneWords #-}-cloneWords :: PrimMonad m => U.MVector (PrimState m) Bit -> m (U.MVector (PrimState m) Word)-cloneWords v@(BitMVec _ n _) = do-    ws <- MV.new (nWords n)-    let loop !i !j-            | i >= n    = return ()-            | otherwise = do-                readWord v i >>= MV.write ws j-                loop (i + wordSize) (j + 1)-    loop 0 0-    return ws--instance U.Unbox Bit--loMask :: Int -> Word-loMask n = 1 `shiftL` n - 1--hiMask :: Int -> Word-hiMask n = complement (1 `shiftL` n - 1)--instance MV.MVector U.MVector Bit where-    {-# INLINE basicInitialize #-}-    basicInitialize (BitMVec _ 0 _) = pure ()-    basicInitialize (BitMVec 0 n v) = case modWordSize n of-        0 -> MV.basicInitialize v-        nMod -> do-            let vLen = MV.basicLength v-            MV.basicInitialize (MV.slice 0 (vLen - 1) v)-            MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1)-    basicInitialize (BitMVec s n v) = case modWordSize (s + n) of-        0 -> do-            let vLen = MV.basicLength v-            MV.basicInitialize (MV.slice 1 (vLen - 1) v)-            MV.modify v (\val -> val .&. loMask s) 0-        nMod -> do-            let vLen = MV.basicLength v-                lohiMask = loMask s .|. hiMask nMod-            if vLen == 1-                then MV.modify v (\val -> val .&. lohiMask) 0-                else do-                    MV.basicInitialize (MV.slice 1 (vLen - 2) v)-                    MV.modify v (\val -> val .&. loMask s) 0-                    MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1)--    {-# INLINE basicUnsafeNew #-}-    basicUnsafeNew       n   = liftM (BitMVec 0 n) (MV.basicUnsafeNew       (nWords n))--    {-# INLINE basicUnsafeReplicate #-}-    basicUnsafeReplicate n x = liftM (BitMVec 0 n) (MV.basicUnsafeReplicate (nWords n) (extendToWord x))--    {-# INLINE basicOverlaps #-}-    basicOverlaps (BitMVec _ _ v1) (BitMVec _ _ v2) = MV.basicOverlaps v1 v2--    {-# INLINE basicLength #-}-    basicLength      (BitMVec _ n _)     = n--    {-# INLINE basicUnsafeRead #-}-    basicUnsafeRead  (BitMVec s _ v) !i'   = let i = s + i' in liftM (readBit (modWordSize i)) (MV.basicUnsafeRead v (divWordSize i))--    {-# INLINE basicUnsafeWrite #-}-    basicUnsafeWrite (BitMVec s _ v) !i' !x = do-        let i = s + i'-        let j = divWordSize i; k = modWordSize i; kk = 1 `unsafeShiftL` k-        w <- MV.basicUnsafeRead v j-        when (fromBool (w .&. kk /= 0) /= x) $-            MV.basicUnsafeWrite v j (w `xor` kk)--    {-# INLINE basicClear #-}-    basicClear _ = pure ()--    {-# INLINE basicSet #-}-    basicSet (BitMVec _ 0 _) _ = pure ()-    basicSet (BitMVec 0 n v) (extendToWord -> x) = case modWordSize n of-        0 ->  MV.basicSet v x-        nMod -> do-            let vLen = MV.basicLength v-            MV.basicSet (MV.slice 0 (vLen - 1) v) x-            MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1)-    basicSet (BitMVec s n v) (extendToWord -> x) = case modWordSize (s + n) of-        0 -> do-            let vLen = MV.basicLength v-            MV.basicSet (MV.slice 1 (vLen - 1) v) x-            MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0-        nMod -> do-            let vLen = MV.basicLength v-                lohiMask = loMask s .|. hiMask nMod-            if vLen == 1-                then MV.modify v (\val -> val .&. lohiMask .|. x .&. complement lohiMask) 0-                else do-                    MV.basicSet (MV.slice 1 (vLen - 2) v) x-                    MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0-                    MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1)--    {-# INLINE basicUnsafeCopy #-}-    basicUnsafeCopy _ (BitMVec _ 0 _) = pure ()-    basicUnsafeCopy (BitMVec 0 _ dst) (BitMVec 0 n src) = case modWordSize n of-        0 -> MV.basicUnsafeCopy dst src-        nMod -> do-            let vLen = MV.basicLength src-            MV.basicUnsafeCopy (MV.slice 0 (vLen - 1) dst) (MV.slice 0 (vLen - 1) src)-            valSrc <- MV.basicUnsafeRead src (vLen - 1)-            MV.modify dst (\val -> val .&. hiMask nMod .|. valSrc .&. loMask nMod) (vLen - 1)-    basicUnsafeCopy (BitMVec dstShift _ dst) (BitMVec s n src)-        | dstShift == s = case modWordSize (s + n) of-            0 -> do-                let vLen = MV.basicLength src-                MV.basicUnsafeCopy (MV.slice 1 (vLen - 1) dst) (MV.slice 1 (vLen - 1) src)-                valSrc <- MV.basicUnsafeRead src 0-                MV.modify dst (\val -> val .&. loMask s .|. valSrc .&. hiMask s) 0-            nMod -> do-                let vLen = MV.basicLength src-                    lohiMask = loMask s .|. hiMask nMod-                if vLen == 1-                    then do-                        valSrc <- MV.basicUnsafeRead src 0-                        MV.modify dst (\val -> val .&. lohiMask .|. valSrc .&. complement lohiMask) 0-                    else do-                        MV.basicUnsafeCopy (MV.slice 1 (vLen - 2) dst) (MV.slice 1 (vLen - 2) src)-                        valSrcFirst <- MV.basicUnsafeRead src 0-                        MV.modify dst (\val -> val .&. loMask s .|. valSrcFirst .&. hiMask s) 0-                        valSrcLast <- MV.basicUnsafeRead src (vLen - 1)-                        MV.modify dst (\val -> val .&. hiMask nMod .|. valSrcLast .&. loMask nMod) (vLen - 1)--    basicUnsafeCopy dst@(BitMVec _ len _) src = do_copy 0-      where-        n = alignUp len--        do_copy i-            | i < n = do-                x <- readWord src i-                writeWord dst i x-                do_copy (i+wordSize)-            | otherwise = return ()--    {-# INLINE basicUnsafeMove #-}-    basicUnsafeMove !dst !src@(BitMVec srcShift srcLen _)-        | MV.basicOverlaps dst src = do-            -- Align shifts of src and srcCopy to speed up basicUnsafeCopy srcCopy src-            -- TODO write tests on copy and move inside array-            srcCopy <- BitMVec srcShift srcLen <$> MV.basicUnsafeNew (nWords (srcShift + srcLen))-            MV.basicUnsafeCopy srcCopy src-            MV.basicUnsafeCopy dst srcCopy-        | otherwise = MV.basicUnsafeCopy dst src--    {-# INLINE basicUnsafeSlice #-}-    basicUnsafeSlice offset n (BitMVec s _ v) =-        BitMVec relStartBit n (MV.basicUnsafeSlice startWord (endWord - startWord) v)-            where-                absStartBit = s + offset-                relStartBit = modWordSize absStartBit-                absEndBit   = absStartBit + n-                endWord     = nWords absEndBit-                startWord   = divWordSize absStartBit--    {-# INLINE basicUnsafeGrow #-}-    basicUnsafeGrow (BitMVec s n v) by =-        BitMVec s (n + by) <$> if delta == 0 then pure v else MV.basicUnsafeGrow v delta-        where-            delta = nWords (s + n + by) - nWords (s + n)---instance V.Vector U.Vector Bit where-    basicUnsafeFreeze (BitMVec s n v) = liftM (BitVec  s n) (V.basicUnsafeFreeze v)-    basicUnsafeThaw   (BitVec  s n v) = liftM (BitMVec s n) (V.basicUnsafeThaw   v)-    basicLength       (BitVec  _ n _) = n--    basicUnsafeIndexM (BitVec s _ v) !i' = let i = s + i' in liftM (readBit (modWordSize i)) (V.basicUnsafeIndexM v (divWordSize i))--    basicUnsafeCopy dst src = do-        src1 <- V.basicUnsafeThaw src-        MV.basicUnsafeCopy dst src1--    {-# INLINE basicUnsafeSlice #-}-    basicUnsafeSlice offset n (BitVec s _ v) =-        BitVec relStartBit n (V.basicUnsafeSlice startWord (endWord - startWord) v)-            where-                absStartBit = s + offset-                relStartBit = modWordSize absStartBit-                absEndBit   = absStartBit + n-                endWord     = nWords absEndBit-                startWord   = divWordSize absStartBit--padWith :: Bit -> Int -> U.Vector Bit -> U.Vector Bit-padWith b n' bitvec@(BitVec _ n _)-    | n' <= n   = bitvec-    | otherwise = runST $ do-        mv@(BitMVec mvStart _ ws) <- MV.replicate n' b-        when (mvStart /= 0) (fail "assertion failed: offset /= 0 after MV.new")--        V.copy (MV.basicUnsafeSlice 0 n mv) bitvec--        when (notAligned n) $ do-            let i = divWordSize n-                j = modWordSize n-            x <- MV.read ws i-            MV.write ws i (meld j x (extendToWord b))--        V.unsafeFreeze mv--pad :: Int -> U.Vector Bit -> U.Vector Bit-pad = padWith (fromBool False)

@@ -1,290 +0,0 @@-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE BangPatterns               #-}--module Data.Vector.Unboxed.Mutable.Bit-     ( wordSize-     , wordLength-     , cloneFromWords-     , cloneToWords-     , readWord-     , writeWord--     , mapMInPlaceWithIndex-     , mapInPlaceWithIndex-     , mapMInPlace-     , mapInPlace--     , zipInPlace--     , unionInPlace-     , intersectionInPlace-     , differenceInPlace-     , symDiffInPlace-     , invertInPlace-     , selectBitsInPlace-     , excludeBitsInPlace--     , countBits-     , listBits--     , and-     , or--     , any-     , anyBits-     , all-     , allBits--     , reverseInPlace-     ) where--import           Control.Monad-import           Control.Monad.Primitive-import           Data.Bit.Internal-import           Data.Bits-import qualified Data.Vector.Generic.Mutable       as MV-import qualified Data.Vector.Generic               as V-import qualified Data.Vector.Unboxed               as U (Vector)-import           Data.Vector.Unboxed.Mutable       as U-import           Data.Vector.Unboxed.Bit.Internal-import           Data.Word-import           Prelude                           as P-    hiding (and, or, any, all, reverse)----- TODO: this interface needs more work.---- |Get the length of the vector that would be created by 'cloneToWords'-wordLength :: U.MVector s Bit -> Int-wordLength = nWords . MV.length---- |Clone a specified number of bits from a vector of words into a new vector of bits (interpreting the words in little-endian order, as described at 'indexWord').  If there are not enough words for the number of bits requested, the vector will be zero-padded.-cloneFromWords :: PrimMonad m => Int -> U.MVector (PrimState m) Word -> m (U.MVector (PrimState m) Bit)-cloneFromWords n ws = do-    let wordsNeeded = nWords n-        wordsGiven  = MV.length ws-        fillNeeded  = wordsNeeded - wordsGiven--    v <- MV.new wordsNeeded--    if fillNeeded > 0-        then do-            MV.copy (MV.slice          0 wordsGiven v) ws-            MV.set  (MV.slice wordsGiven fillNeeded v) 0-        else do-            MV.copy v (MV.slice 0 wordsNeeded ws)--    return (BitMVec 0 n v)---- |clone a vector of bits to a new unboxed vector of words.  If the bits don't completely fill the words, the last word will be zero-padded.-cloneToWords :: PrimMonad m => U.MVector (PrimState m) Bit -> m (U.MVector (PrimState m) Word)-cloneToWords v@(BitMVec s n ws)-    | aligned s = do-        ws1 <- MV.clone (MV.slice (divWordSize s) (nWords n) ws)-        when (not (aligned n)) $ do-            readWord v (alignDown n) >>= MV.write ws1 (divWordSize n)-        return ws1-    | otherwise = cloneWords v---- |Map a function over a bit vector one 'Word' at a time ('wordSize' bits at a time).  The function will be passed the bit index (which will always be 'wordSize'-aligned) and the current value of the corresponding word.  The returned word will be written back to the vector.  If there is a partial word at the end of the vector, it will be zero-padded when passed to the function and truncated when the result is written back to the array.-{-# INLINE mapMInPlaceWithIndex #-}-mapMInPlaceWithIndex ::-    PrimMonad m =>-        (Int -> Word -> m Word)-     -> U.MVector (PrimState m) Bit -> m ()-mapMInPlaceWithIndex f xs@(BitMVec 0 _ v) = loop 0 0-    where-        !n_ = alignDown (MV.length xs)-        loop !i !j-            | i >= n_   = when (n_ /= MV.length xs) $ do-                readWord xs i >>= f i >>= writeWord xs i--            | otherwise = do-                MV.read v j >>= f i >>= MV.write v j-                loop (i + wordSize) (j + 1)-mapMInPlaceWithIndex f xs = loop 0-    where-        !n = MV.length xs-        loop !i-            | i >= n    = return ()-            | otherwise = do-                readWord xs i >>= f i >>= writeWord xs i-                loop (i + wordSize)--{-# INLINE mapInPlaceWithIndex #-}-mapInPlaceWithIndex ::-    PrimMonad m =>-        (Int -> Word -> Word)-     -> U.MVector (PrimState m) Bit -> m ()-mapInPlaceWithIndex f = mapMInPlaceWithIndex g-    where-        {-# INLINE g #-}-        g i x = return $! f i x---- |Same as 'mapMInPlaceWithIndex' but without the index.-{-# INLINE mapMInPlace #-}-mapMInPlace :: PrimMonad m => (Word -> m Word) -> U.MVector (PrimState m) Bit -> m ()-mapMInPlace f = mapMInPlaceWithIndex (const f)--{-# INLINE mapInPlace #-}-mapInPlace :: PrimMonad m => (Word -> Word) -> U.MVector (PrimState m) Bit -> m ()-mapInPlace f = mapMInPlaceWithIndex (\_ x -> return (f x))--{-# INLINE zipInPlace #-}-zipInPlace :: PrimMonad m => (Word -> Word -> Word) -> U.MVector (PrimState m) Bit -> U.Vector Bit -> m ()-zipInPlace f xs ys@(BitVec 0 n2 v) =-    mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs)-    where-        -- WARNING: relies on guarantee by mapMInPlaceWithIndex that index will always be aligned!-        !n = min (MV.length xs) (V.length ys)-        {-# INLINE g #-}-        g !i !x =-            let !w = masked (n2 - i) (v V.! divWordSize i)-             in f x w-zipInPlace f xs ys =-    mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs)-    where-        !n = min (MV.length xs) (V.length ys)-        {-# INLINE g #-}-        g !i !x =-            let !w = indexWord ys i-             in f x w--unionInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m ()-unionInPlace = zipInPlace (.|.)--intersectionInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m ()-intersectionInPlace = zipInPlace (.&.)--differenceInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m ()-differenceInPlace = zipInPlace diff--symDiffInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m ()-symDiffInPlace = zipInPlace xor---- |Flip every bit in the given vector-invertInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()-invertInPlace = mapInPlace complement--selectBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int-selectBitsInPlace is xs = loop 0 0-    where-        !n = min (V.length is) (MV.length xs)-        loop !i !ct-            | i >= n    = return ct-            | otherwise = do-                x <- readWord xs i-                let !(nSet, x') = selectWord (masked (n - i) (indexWord is i)) x-                writeWord xs ct x'-                loop (i + wordSize) (ct + nSet)--excludeBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int-excludeBitsInPlace is xs = loop 0 0-    where-        !n = min (V.length is) (MV.length xs)-        loop !i !ct-            | i >= n    = return ct-            | otherwise = do-                x <- readWord xs i-                let !(nSet, x') = selectWord (masked (n - i) (complement (indexWord is i))) x-                writeWord xs ct x'-                loop (i + wordSize) (ct + nSet)---- |return the number of ones in a bit vector-countBits :: PrimMonad m => U.MVector (PrimState m) Bit -> m Int-countBits v = loop 0 0-    where-        !n = alignUp (MV.length v)-        loop !s !i-            | i >= n    = return s-            | otherwise = do-                x <- readWord v i-                loop (s + popCount x) (i + wordSize)--listBits :: PrimMonad m => U.MVector (PrimState m) Bit -> m [Int]-listBits v = loop id 0-    where-        !n = MV.length v-        loop bs !i-            | i >= n    = return $! bs []-            | otherwise = do-                w <- readWord v i-                loop (bs . bitsInWord i w) (i + wordSize)---- | Returns 'True' if all bits in the vector are set-and :: PrimMonad m => U.MVector (PrimState m) Bit -> m Bool-and v = loop 0-    where-        !n = MV.length v-        loop !i-            | i >= n    = return True-            | otherwise = do-                y <- readWord v i-                if y == mask (n - i)-                    then loop (i + wordSize)-                    else return False---- | Returns 'True' if any bit in the vector is set-or :: PrimMonad m => U.MVector (PrimState m) Bit -> m Bool-or v = loop 0-    where-        !n = MV.length v-        loop !i-            | i >= n    = return False-            | otherwise = do-                y <- readWord v i-                if y /= 0-                    then return True-                    else loop (i + wordSize)--all :: PrimMonad m => (Bit -> Bool) -> U.MVector (PrimState m) Bit -> m Bool-all p = case (p (Bit False), p (Bit True)) of-    (False, False) -> return . MV.null-    (False,  True) -> allBits (Bit True)-    (True,  False) -> allBits (Bit False)-    (True,   True) -> flip seq (return True)--any :: PrimMonad m => (Bit -> Bool) -> U.MVector (PrimState m) Bit -> m Bool-any p = case (p (Bit False), p (Bit True)) of-    (False, False) -> flip seq (return False)-    (False,  True) -> anyBits (Bit True)-    (True,  False) -> anyBits (Bit False)-    (True,   True) -> return . not . MV.null--allBits, anyBits :: PrimMonad m => Bit -> U.MVector (PrimState m) Bit -> m Bool-allBits (Bit False) = liftM not . or-allBits (Bit True) = and--anyBits (Bit False) = liftM not . and-anyBits (Bit True) = or--reverseInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()-reverseInPlace xs = loop 0 (MV.length xs)-    where-        loop !i !j-            | i' <= j'  = do-                x <- readWord xs i-                y <- readWord xs j'--                writeWord xs i  (reverseWord y)-                writeWord xs j' (reverseWord x)--                loop i' j'-            | i' < j    = do-                let w = (j - i) `shiftR` 1-                    k  = j - w-                x <- readWord xs i-                y <- readWord xs k--                writeWord xs i (meld w (reversePartialWord w y) x)-                writeWord xs k (meld w (reversePartialWord w x) y)--                loop i' j'-            | i  < j    = do-                let w = j - i-                x <- readWord xs i-                writeWord xs i (meld w (reversePartialWord w x) x)-            | otherwise = return ()-            where-                !i' = i + wordSize-                !j' = j - wordSize

@@ -1,24 +1,26 @@-#!/usr/bin/env runhaskell module Main where  import Data.Bit import Data.Proxy-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck.Classes+import Test.Tasty+import Test.Tasty.QuickCheck+ import Tests.MVector (mvectorTests)+import qualified Tests.MVectorTS as TS (mvectorTests) import Tests.SetOps (setOpTests) import Tests.Vector (vectorTests)  main :: IO ()-main = defaultMain+main = defaultMain $ testGroup "All"     [ showReadTests     , mvectorTests+    , TS.mvectorTests     , setOpTests     , vectorTests     ] -showReadTests :: Test+showReadTests :: TestTree showReadTests   = testGroup "Show/Read"   $ map (uncurry testProperty)

@@ -8,13 +8,13 @@  import Control.Monad.ST import Data.Bit+import qualified Data.Bit.ThreadSafe as TS import Data.Bits import qualified Data.Vector.Generic         as V import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Generic.New     as N import qualified Data.Vector.Unboxed         as U-import Data.Vector.Unboxed.Bit (wordSize)-import Test.QuickCheck+import Test.Tasty.QuickCheck  instance Arbitrary Bit where     arbitrary = Bit <$> arbitrary@@ -26,6 +26,16 @@ instance Function Bit where     function f = functionMap unBit Bit f +instance Arbitrary TS.Bit where+    arbitrary = TS.Bit <$> arbitrary+    shrink = fmap TS.Bit . shrink . TS.unBit++instance CoArbitrary TS.Bit where+    coarbitrary = coarbitrary . TS.unBit++instance Function TS.Bit where+    function f = functionMap TS.unBit TS.Bit f+ instance (Arbitrary a, U.Unbox a) => Arbitrary (U.Vector a) where     arbitrary = V.new <$> arbitrary @@ -58,6 +68,9 @@ sliceList :: Int -> Int -> [a] -> [a] sliceList s n = take n . drop s +wordSize :: Int+wordSize = finiteBitSize (0 :: Word)+ packBitsToWord :: [Bit] -> (Word, [Bit]) packBitsToWord = loop 0 0     where@@ -78,29 +91,30 @@ writeWordL xs n w = pre ++ writeWordL post 0 w     where (pre, post) = splitAt n xs -prop_writeWordL_preserves_length :: [Bit] -> NonNegative Int -> Word -> Bool+prop_writeWordL_preserves_length :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_length xs (NonNegative n) w =-    length (writeWordL xs n w) == length xs+    length (writeWordL xs n w) === length xs -prop_writeWordL_preserves_prefix :: [Bit] -> NonNegative Int -> Word -> Bool+prop_writeWordL_preserves_prefix :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_prefix xs (NonNegative n) w =-    take n (writeWordL xs n w) == take n xs+    take n (writeWordL xs n w) === take n xs -prop_writeWordL_preserves_suffix :: [Bit] -> NonNegative Int -> Word -> Bool+prop_writeWordL_preserves_suffix :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_suffix xs (NonNegative n) w =-    drop (n + wordSize) (writeWordL xs n w) == drop (n + wordSize) xs+    drop (n + wordSize) (writeWordL xs n w) === drop (n + wordSize) xs -prop_writeWordL_readWordL :: [Bit] -> Int -> Bool+prop_writeWordL_readWordL :: [Bit] -> Int -> Property prop_writeWordL_readWordL xs n =-    writeWordL xs n (readWordL xs n) == xs+    writeWordL xs n (readWordL xs n) === xs  -- the opposite is more work to state, but these tests together with the simplicity of the definitions makes me reasonably confident in these as a reference implementation. -withNonEmptyMVec :: Eq t =>-       (U.Vector Bit -> t)+withNonEmptyMVec+    :: (Eq t, Show t)+    => (U.Vector Bit -> t)     -> (forall s. U.MVector s Bit -> ST s t)     -> Property withNonEmptyMVec f g = forAll arbitrary $ \xs ->-     let xs' = V.new xs-      in not (U.null xs') ==> f xs' == runST (N.run xs >>= g)+    let xs' = V.new xs in+        not (U.null xs') ==> f xs' === runST (N.run xs >>= g) 

@@ -1,45 +1,41 @@+{-# LANGUAGE CPP #-}++#ifndef BITVEC_THREADSAFE module Tests.MVector where+#else+module Tests.MVectorTS where+#endif  import Support -import Control.Monad import Control.Monad.ST+#ifndef BITVEC_THREADSAFE import Data.Bit+#else+import Data.Bit.ThreadSafe+#endif+import Data.Bits import Data.Proxy-import Data.STRef import qualified Data.Vector.Generic             as V import qualified Data.Vector.Generic.Mutable     as M (basicInitialize, basicSet) import qualified Data.Vector.Generic.New         as N-import qualified Data.Vector.Unboxed.Bit         as B hiding (reverse) import qualified Data.Vector.Unboxed             as B-import qualified Data.Vector.Unboxed.Mutable.Bit as U import qualified Data.Vector.Unboxed.Mutable     as M-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit (assertEqual)-import Test.QuickCheck import Test.QuickCheck.Classes+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck -mvectorTests :: Test+mvectorTests :: TestTree mvectorTests = testGroup "Data.Vector.Unboxed.Mutable.Bit"     [ testGroup "Data.Vector.Unboxed.Mutable functions"         [ testProperty "slice"          prop_slice_def         , testProperty "grow"           prop_grow_def         ]-    , testProperty "wordLength"     prop_wordLength_def     , testGroup "Read/write Words"-        [ testProperty "readWord"       prop_readWord_def-        , testProperty "writeWord"      prop_writeWord_def-        , testProperty "cloneFromWords" (prop_cloneFromWords_def 10000)+        [ testProperty "cloneFromWords" prop_cloneFromWords_def         , testProperty "cloneToWords"   prop_cloneToWords_def         ]-    , testGroup "mapMInPlaceWithIndex"-        [ testProperty "maps left to right" prop_mapMInPlaceWithIndex_leftToRight-        , testProperty "wordSize-aligned"   prop_mapMInPlaceWithIndex_aligned-        ]-    , testProperty "countBits"      prop_countBits_def-    , testProperty "listBits"       prop_listBits_def     , testProperty "reverseInPlace" prop_reverseInPlace_def     , testGroup "MVector laws" $ map (uncurry testProperty) $ lawsProperties $ muvectorLaws (Proxy :: Proxy Bit)     , testCase "basicInitialize 1" case_write_init_read1@@ -58,8 +54,16 @@     , testCase "basicUnsafeCopy3" case_write_copy_read3     , testCase "basicUnsafeCopy4" case_write_copy_read4     , testCase "basicUnsafeCopy5" case_write_copy_read5++    , testProperty "flipBit" prop_flipBit     ] +prop_flipBit :: B.Vector Bit -> NonNegative Int -> Property+prop_flipBit xs (NonNegative k) = k < B.length xs ==> ys === ys'+    where+        ys  = B.modify (\v -> M.modify v complement k) xs+        ys' = B.modify (\v -> flipBit v k) xs+ case_write_init_read1 :: IO () case_write_init_read1 = assertEqual "should be equal" (Bit True) $ runST $ do     arr <- M.new 2@@ -196,70 +200,18 @@     fv1 <- B.freeze v1     return (fv0 == B.take n fv1) -prop_readWord_def :: Int -> Property-prop_readWord_def n = withNonEmptyMVec-    (\xs ->   readWordL (B.toList xs) (n `mod` V.length xs))-    (\xs -> U.readWord            xs  (n `mod` M.length xs))--prop_writeWord_def :: Int -> Word -> Property-prop_writeWord_def n w = withNonEmptyMVec-    (\xs -> B.fromList-               $ writeWordL (B.toList xs) (n `mod` V.length xs) w)-    (\xs -> do U.writeWord            xs  (n `mod` M.length xs) w-               V.unsafeFreeze xs)--prop_wordLength_def :: N.New B.Vector Bit -> Bool-prop_wordLength_def xs-    =  runST (fmap U.wordLength (N.run xs))-    == runST (fmap M.length (N.run xs >>= U.cloneToWords))--prop_cloneFromWords_def :: Int -> Int -> N.New B.Vector Word -> Bool-prop_cloneFromWords_def maxN n' ws-    =  runST (N.run ws >>= U.cloneFromWords n >>= V.unsafeFreeze)-    == B.fromWords n (V.new ws)-    where n = n' `mod` maxN+prop_cloneFromWords_def :: N.New B.Vector Word -> Bool+prop_cloneFromWords_def ws+    =  runST (N.run ws >>= pure . castFromWordsM >>= V.unsafeFreeze)+    == castFromWords (V.new ws)  prop_cloneToWords_def :: N.New B.Vector Bit -> Bool prop_cloneToWords_def xs-    =  runST (N.run xs >>= U.cloneToWords >>= V.unsafeFreeze)-    == B.toWords (V.new xs)--prop_mapMInPlaceWithIndex_leftToRight :: N.New B.Vector Bit -> Bool-prop_mapMInPlaceWithIndex_leftToRight xs-    = runST $ do-        x <- newSTRef (-1)-        xs1 <- N.run xs-        let f i _ = do-                j <- readSTRef x-                writeSTRef x i-                return (if i > j then maxBound else 0)-        U.mapMInPlaceWithIndex f xs1-        xs2 <- V.unsafeFreeze xs1-        return (all unBit (B.toList xs2))--prop_mapMInPlaceWithIndex_aligned :: N.New B.Vector Bit -> Bool-prop_mapMInPlaceWithIndex_aligned xs = runST $ do-    ok <- newSTRef True-    xs1 <- N.run xs-    let aligned i   = i `mod` U.wordSize == 0-        f i x = do-            when (not (aligned i)) (writeSTRef ok False)-            return x-    U.mapMInPlaceWithIndex f xs1-    readSTRef ok--prop_countBits_def :: N.New B.Vector Bit -> Bool-prop_countBits_def xs-    =  runST (N.run xs >>= U.countBits)-    == B.countBits (V.new xs)--prop_listBits_def :: N.New B.Vector Bit -> Bool-prop_listBits_def xs-    =  runST (N.run xs >>= U.listBits)-    == B.listBits (V.new xs)+    =  runST (N.run xs >>= cloneToWordsM >>= V.unsafeFreeze)+    == cloneToWords (V.new xs)  prop_reverseInPlace_def :: N.New B.Vector Bit -> Bool prop_reverseInPlace_def xs-    =  runST (N.run xs >>= \v -> U.reverseInPlace v >> V.unsafeFreeze v)+    =  runST (N.run xs >>= \v -> reverseInPlace v >> V.unsafeFreeze v)     == B.reverse (V.new xs) 

@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Tests/MVector.hs"

@@ -4,20 +4,20 @@  import Data.Bit import Data.Bits+import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Vector.Unboxed as U-import qualified Data.Vector.Unboxed.Bit as U-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Tasty+import Test.Tasty.QuickCheck hiding ((.&.)) -setOpTests :: Test+setOpTests :: TestTree setOpTests = testGroup "Set operations"     [ testProperty "union"          prop_union_def     , testProperty "intersection"   prop_intersection_def     , testProperty "difference"     prop_difference_def     , testProperty "symDiff"        prop_symDiff_def -    , testProperty "unions"         (prop_unions_def 1000)-    , testProperty "intersections"  (prop_unions_def 1000)+    , testProperty "unions"         prop_unions_def+    , testProperty "intersections"  prop_unions_def      , testProperty "invert"         prop_invert_def @@ -30,66 +30,100 @@     , testProperty "countBits"      prop_countBits_def     ] -prop_union_def :: U.Vector Bit -> U.Vector Bit -> Bool+union :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+union = zipBits (.|.)++prop_union_def :: U.Vector Bit -> U.Vector Bit -> Property prop_union_def xs ys-    =  U.toList (U.union xs ys)-    == zipWith (.|.) (U.toList xs) (U.toList ys)+    =  U.toList (union xs ys)+    === zipWith (.|.) (U.toList xs) (U.toList ys) -prop_intersection_def :: U.Vector Bit -> U.Vector Bit -> Bool+intersection :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+intersection = zipBits (.&.)++prop_intersection_def :: U.Vector Bit -> U.Vector Bit -> Property prop_intersection_def xs ys-    =  U.toList (U.intersection xs ys)-    == zipWith (.&.) (U.toList xs) (U.toList ys)+    =  U.toList (intersection xs ys)+    === zipWith (.&.) (U.toList xs) (U.toList ys) -prop_difference_def :: U.Vector Bit -> U.Vector Bit -> Bool+difference :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+difference = zipBits (\a b -> a .&. complement b)++prop_difference_def :: U.Vector Bit -> U.Vector Bit -> Property prop_difference_def xs ys-    =  U.toList (U.difference xs ys)-    == zipWith diff (U.toList xs) (U.toList ys)+    =  U.toList (difference xs ys)+    === zipWith diff (U.toList xs) (U.toList ys)     where         diff x y = x .&. complement y -prop_symDiff_def :: U.Vector Bit -> U.Vector Bit -> Bool+symDiff :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+symDiff = zipBits xor++prop_symDiff_def :: U.Vector Bit -> U.Vector Bit -> Property prop_symDiff_def xs ys-    =  U.toList (U.symDiff xs ys)-    == zipWith xor (U.toList xs) (U.toList ys)+    =  U.toList (symDiff xs ys)+    === zipWith xor (U.toList xs) (U.toList ys) -prop_unions_def :: Int -> Int -> [U.Vector Bit] -> Bool-prop_unions_def maxN n' xss-    =  U.unions n xss-    == U.take n (foldr U.union (U.replicate n (Bit False)) (map (U.pad n) xss))-    where n = n' `mod` maxN+unions :: NonEmpty (U.Vector Bit) -> U.Vector Bit+unions (x :| xs) = U.slice 0 l $ U.modify (go xs) x+    where+        l = minimum $ fmap U.length (x :| xs)+        go [] _ = pure ()+        go (y : ys) acc = do+            zipInPlace (.|.) y acc+            go ys acc -prop_intersections_def :: Int -> Int -> [U.Vector Bit] -> Bool-prop_intersections_def maxN n' xss-    =  U.intersections n xss-    == U.take n (foldr U.intersection (U.replicate n (Bit True)) (map (U.padWith (Bit True) n) xss))-    where n = n' `mod` maxN+prop_unions_def :: U.Vector Bit -> [U.Vector Bit] -> Property+prop_unions_def xs xss+    =   unions (xs :| xss)+    === foldr union xs xss +intersections :: NonEmpty (U.Vector Bit) -> U.Vector Bit+intersections (x :| xs) = U.slice 0 l $ U.modify (go xs) x+    where+        l = minimum $ fmap U.length (x :| xs)+        go [] _ = pure ()+        go (y : ys) acc = do+            zipInPlace (.&.) y acc+            go ys acc++prop_intersections_def :: U.Vector Bit -> [U.Vector Bit] -> Property+prop_intersections_def xs xss+    =   intersections (xs :| xss)+    === foldr intersection xs xss+ prop_invert_def :: U.Vector Bit -> Bool prop_invert_def xs-    =  U.toList (U.invert xs)+    =  U.toList (U.modify invertInPlace xs)     == map complement (U.toList xs) +select :: U.Unbox a => U.Vector Bit -> U.Vector a -> [a]+select mask ws = U.toList (U.map snd (U.filter (unBit . fst) (U.zip mask ws)))+ prop_select_def :: U.Vector Bit -> U.Vector Word -> Bool prop_select_def xs ys-    =  U.select xs ys+    =  select xs ys     == [ x | (Bit True, x) <- zip (U.toList xs) (U.toList ys)] +exclude :: U.Unbox a => U.Vector Bit -> U.Vector a -> [a]+exclude mask ws = U.toList (U.map snd (U.filter (not . unBit . fst) (U.zip mask ws)))+ prop_exclude_def :: U.Vector Bit -> U.Vector Word -> Bool prop_exclude_def xs ys-    =  U.exclude xs ys+    =  exclude xs ys     == [ x | (Bit False, x) <- zip (U.toList xs) (U.toList ys)]  prop_selectBits_def :: U.Vector Bit -> U.Vector Bit -> Bool prop_selectBits_def xs ys-    =  U.selectBits xs ys-    == U.fromList (U.select xs ys)+    =  selectBits xs ys+    == U.fromList (select xs ys)  prop_excludeBits_def :: U.Vector Bit -> U.Vector Bit -> Bool prop_excludeBits_def xs ys-    =  U.excludeBits xs ys-    == U.fromList (U.exclude xs ys)+    =  excludeBits xs ys+    == U.fromList (exclude xs ys)  prop_countBits_def :: U.Vector Bit -> Bool prop_countBits_def xs-    =  U.countBits xs-    == U.length (U.selectBits xs xs)+    =  countBits xs+    == U.length (selectBits xs xs)

@@ -2,31 +2,23 @@  import Support +import Prelude hiding (and, or) import Data.Bit-import Data.Bits-import Data.List+import Data.List hiding (and, or) import qualified Data.Vector.Unboxed as U hiding (reverse, and, or, any, all, findIndex)-import qualified Data.Vector.Unboxed.Bit as U-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit ((@?=))-import Test.QuickCheck-import Test.QuickCheck.Function+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck -vectorTests :: Test+vectorTests :: TestTree vectorTests = testGroup "Data.Vector.Unboxed.Bit"-    [ testCase     "wordSize correct"           (U.wordSize @?= finiteBitSize (0 :: Word))-    , testGroup "Data.Vector.Unboxed functions"+    [ testGroup "Data.Vector.Unboxed functions"         [ testProperty "toList . fromList == id"    prop_toList_fromList         , testProperty "fromList . toList == id"    prop_fromList_toList         , testProperty "slice"                      prop_slice_def         ]-    , testProperty "wordLength"                 prop_wordLength_def-    , testProperty "fromWords"                  (prop_fromWords_def 10000)-    , testProperty "toWords"                    prop_toWords_def-    , testProperty "indexWord"                  prop_indexWord_def-    , testProperty "zipWords"                   prop_zipWords_def+    , testProperty "cloneFromWords"             prop_cloneFromWords_def+    , testProperty "cloneToWords"               prop_cloneToWords_def     , testProperty "reverse"                    prop_reverse_def     , testProperty "countBits"                  prop_countBits_def     , testProperty "listBits"                   prop_listBits_def@@ -35,13 +27,17 @@         , testProperty "or"                         prop_or_def         ]     , testGroup "Search operations"-        [ testProperty "any"                        prop_any_def-        , testProperty "all"                        prop_all_def-        , testProperty "anyBits"                    prop_anyBits_def-        , testProperty "allBits"                    prop_allBits_def-        , testProperty "first"                      prop_first_def-        , testProperty "findIndex"                  prop_findIndex_def+        [ testProperty "first"                      prop_first_def         ]+    , testGroup "nthBitIndex"+        [ testCase     "special case 1"                     case_nthBit_1++        , testProperty "matches bitIndex True"              prop_nthBit_1+        , testProperty "matches bitIndex False"             prop_nthBit_2+        , testProperty "matches sequence of bitIndex True"  prop_nthBit_3+        , testProperty "matches sequence of bitIndex False" prop_nthBit_4+        , testProperty "matches countBits"                  prop_nthBit_5+        ]     ]  prop_toList_fromList :: [Bit] -> Bool@@ -59,94 +55,90 @@     where         (s', n') = trimSlice s n (U.length xs) -prop_wordLength_def :: U.Vector Bit -> Bool-prop_wordLength_def xs-    =  U.wordLength xs-    == U.length (U.toWords xs)--prop_fromWords_def :: Int -> Int -> U.Vector Word -> Bool-prop_fromWords_def maxN n ws-    =  U.toList (U.fromWords n' ws)-    == take n' (concatMap wordToBitList (U.toList ws) ++ repeat (Bit False))-    where n' = n `mod` maxN+prop_cloneFromWords_def :: U.Vector Word -> Property+prop_cloneFromWords_def ws+    =   U.toList (castFromWords ws)+    === concatMap wordToBitList (U.toList ws) -prop_toWords_def :: U.Vector Bit -> Bool-prop_toWords_def xs-    =  U.toList (U.toWords xs)+prop_cloneToWords_def :: U.Vector Bit -> Bool+prop_cloneToWords_def xs+    =  U.toList (cloneToWords xs)     == loop (U.toList xs)         where             loop [] = []             loop bs = case packBitsToWord bs of                 (w, bs') -> w : loop bs' -prop_indexWord_def :: Int -> U.Vector Bit -> Property-prop_indexWord_def n xs-    = not (U.null xs)-    ==> readWordL  (U.toList xs) n'-     == U.indexWord xs           n'-    where-        n' = n `mod` U.length xs--prop_zipWords_def :: Fun (Word, Word) Word -> U.Vector Bit -> U.Vector Bit -> Bool-prop_zipWords_def f' xs ys-    =  U.zipWords f xs ys-    == U.fromWords (min (U.length xs) (U.length ys)) (U.zipWith f (U.toWords xs) (U.toWords ys))-    where f = curry (apply f')- prop_reverse_def :: U.Vector Bit -> Bool prop_reverse_def xs     =   reverse  (U.toList xs)-    ==  U.toList (U.reverse xs)+    ==  U.toList (U.modify reverseInPlace xs)  prop_countBits_def :: U.Vector Bit -> Bool prop_countBits_def xs-    =  U.countBits xs+    =  countBits xs     == length (filter unBit (U.toList xs)) -prop_listBits_def :: U.Vector Bit -> Bool+prop_listBits_def :: U.Vector Bit -> Property prop_listBits_def xs-    =  U.listBits xs-    == [ i | (i,x) <- zip [0..] (U.toList xs), unBit x]+    =  listBits xs+    === [ i | (i,x) <- zip [0..] (U.toList xs), unBit x] +and :: U.Vector Bit -> Bool+and xs = case bitIndex (Bit False) xs of+    Nothing -> True+    Just{}  -> False+ prop_and_def :: U.Vector Bit -> Bool prop_and_def xs-    =  U.and xs+    =  and xs     == all unBit (U.toList xs) +or :: U.Vector Bit -> Bool+or xs = case bitIndex (Bit True) xs of+    Nothing -> False+    Just{}  -> True+ prop_or_def :: U.Vector Bit -> Bool prop_or_def xs-    =  U.or xs+    =  or xs     == any unBit (U.toList xs) -prop_any_def :: Fun Bit Bool -> U.Vector Bit -> Bool-prop_any_def f' xs-    =  U.any f xs-    == any f (U.toList xs)-    where f = apply f'+prop_first_def :: Bit -> U.Vector Bit -> Bool+prop_first_def b xs+    =  bitIndex b xs+    == findIndex (b ==) (U.toList xs) -prop_all_def :: Fun Bit Bool -> U.Vector Bit -> Bool-prop_all_def f' xs-    =  U.all f xs-    == all f (U.toList xs)-    where f = apply f'+prop_nthBit_1 :: U.Vector Bit -> Property+prop_nthBit_1 xs = bitIndex (Bit True) xs === nthBitIndex (Bit True) 1 xs -prop_anyBits_def :: Bit -> U.Vector Bit -> Bool-prop_anyBits_def b xs-    =  U.anyBits b xs-    == U.any (b ==) xs+prop_nthBit_2 :: U.Vector Bit -> Property+prop_nthBit_2 xs = bitIndex (Bit False) xs === nthBitIndex (Bit False) 1 xs -prop_allBits_def :: Bit -> U.Vector Bit -> Bool-prop_allBits_def b xs-    =  U.allBits b xs-    == U.all (b ==) xs+prop_nthBit_3 :: Positive Int -> U.Vector Bit -> Property+prop_nthBit_3 (Positive n) xs = case nthBitIndex (Bit True) (n + 1) xs of+    Nothing -> property True+    Just i  -> case bitIndex (Bit True) xs of+        Nothing -> property False+        Just j  -> case nthBitIndex (Bit True) n (U.drop (j + 1) xs) of+            Nothing -> property False+            Just k  -> i === j + k + 1 -prop_first_def :: Bit -> U.Vector Bit -> Bool-prop_first_def b xs-    =  U.first b xs-    == findIndex (b ==) (U.toList xs)+prop_nthBit_4 :: Positive Int -> U.Vector Bit -> Property+prop_nthBit_4 (Positive n) xs = case nthBitIndex (Bit False) (n + 1) xs of+    Nothing -> property True+    Just i  -> case bitIndex (Bit False) xs of+        Nothing -> property False+        Just j  -> case nthBitIndex (Bit False) n (U.drop (j + 1) xs) of+            Nothing -> property False+            Just k  -> i === j + k + 1 -prop_findIndex_def :: Fun Bit Bool -> U.Vector Bit -> Bool-prop_findIndex_def f' xs-    =  U.findIndex f xs-    == findIndex f (U.toList xs)-    where f = apply f'+prop_nthBit_5 :: Positive Int -> U.Vector Bit -> Property+prop_nthBit_5 (Positive n) xs = n <= countBits xs ==>+    case nthBitIndex (Bit True) n xs of+        Nothing -> property False+        Just i  -> countBits (U.take (i + 1) xs) === n++case_nthBit_1 :: IO ()+case_nthBit_1 = assertEqual "should be equal" Nothing $+    nthBitIndex (Bit True) 1 $ U.slice 61 4 $ U.replicate 100 (Bit False)