{-# LANGUAGE BangPatterns, Rank2Types, ScopedTypeVariables, TypeOperators #-}
module Data.BloomFilter
(
Hash
, Bloom
, MBloom
, freeze
, thaw
, unsafeFreeze
, unfold
, fromList
, empty
, singleton
, length
, elem
, notElem
, insert
, insertList
, bitArray
) where
import Control.Monad (liftM, forM_)
import Control.Monad.ST (ST, runST)
import Control.DeepSeq (NFData(..))
import Data.Array.Base (unsafeAt)
import qualified Data.Array.Base as ST
import Data.Array.Unboxed (UArray)
import Data.Bits ((.&.))
import Data.BloomFilter.Util (FastShift(..), (:*)(..))
import qualified Data.BloomFilter.Mutable as MB
import qualified Data.BloomFilter.Mutable.Internal as MB
import Data.BloomFilter.Mutable.Internal (Hash, MBloom)
import Data.Word (Word32)
import Prelude hiding (elem, length, notElem,
(/), (*), div, divMod, mod, rem)
data Bloom a = B {
forall a. Bloom a -> a -> [Hash]
hashes :: !(a -> [Hash])
, forall a. Bloom a -> Int
shift :: {-# UNPACK #-} !Int
, forall a. Bloom a -> Int
mask :: {-# UNPACK #-} !Int
, forall a. Bloom a -> UArray Int Hash
bitArray :: {-# UNPACK #-} !(UArray Int Hash)
}
instance Show (Bloom a) where
show :: Bloom a -> String
show Bloom a
ub = String
"Bloom { " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ((Int
1::Int) Int -> Int -> Int
forall a. FastShift a => a -> Int -> a
`shiftL` Bloom a -> Int
forall a. Bloom a -> Int
shift Bloom a
ub) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bits } "
instance NFData (Bloom a) where
rnf :: Bloom a -> ()
rnf !Bloom a
_ = ()
logBitsInHash :: Int
logBitsInHash :: Int
logBitsInHash = Int
5
create :: (a -> [Hash])
-> Int
-> (forall s. (MBloom s a -> ST s ()))
-> Bloom a
{-# INLINE create #-}
create :: forall a.
(a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
create a -> [Hash]
hash Int
numBits forall s. MBloom s a -> ST s ()
body = (forall s. ST s (Bloom a)) -> Bloom a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Bloom a)) -> Bloom a)
-> (forall s. ST s (Bloom a)) -> Bloom a
forall a b. (a -> b) -> a -> b
$ do
MBloom s a
mb <- (a -> [Hash]) -> Int -> ST s (MBloom s a)
forall a s. (a -> [Hash]) -> Int -> ST s (MBloom s a)
MB.new a -> [Hash]
hash Int
numBits
MBloom s a -> ST s ()
forall s. MBloom s a -> ST s ()
body MBloom s a
mb
MBloom s a -> ST s (Bloom a)
forall s a. MBloom s a -> ST s (Bloom a)
unsafeFreeze MBloom s a
mb
freeze :: MBloom s a -> ST s (Bloom a)
freeze :: forall s a. MBloom s a -> ST s (Bloom a)
freeze MBloom s a
mb = (a -> [Hash]) -> Int -> Int -> UArray Int Hash -> Bloom a
forall a. (a -> [Hash]) -> Int -> Int -> UArray Int Hash -> Bloom a
B (MBloom s a -> a -> [Hash]
forall s a. MBloom s a -> a -> [Hash]
MB.hashes MBloom s a
mb) (MBloom s a -> Int
forall s a. MBloom s a -> Int
MB.shift MBloom s a
mb) (MBloom s a -> Int
forall s a. MBloom s a -> Int
MB.mask MBloom s a
mb) (UArray Int Hash -> Bloom a)
-> ST s (UArray Int Hash) -> ST s (Bloom a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
STUArray s Int Hash -> ST s (UArray Int Hash)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
ST.freeze (MBloom s a -> STUArray s Int Hash
forall s a. MBloom s a -> STUArray s Int Hash
MB.bitArray MBloom s a
mb)
unsafeFreeze :: MBloom s a -> ST s (Bloom a)
unsafeFreeze :: forall s a. MBloom s a -> ST s (Bloom a)
unsafeFreeze MBloom s a
mb = (a -> [Hash]) -> Int -> Int -> UArray Int Hash -> Bloom a
forall a. (a -> [Hash]) -> Int -> Int -> UArray Int Hash -> Bloom a
B (MBloom s a -> a -> [Hash]
forall s a. MBloom s a -> a -> [Hash]
MB.hashes MBloom s a
mb) (MBloom s a -> Int
forall s a. MBloom s a -> Int
MB.shift MBloom s a
mb) (MBloom s a -> Int
forall s a. MBloom s a -> Int
MB.mask MBloom s a
mb) (UArray Int Hash -> Bloom a)
-> ST s (UArray Int Hash) -> ST s (Bloom a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
STUArray s Int Hash -> ST s (UArray Int Hash)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
ST.unsafeFreeze (MBloom s a -> STUArray s Int Hash
forall s a. MBloom s a -> STUArray s Int Hash
MB.bitArray MBloom s a
mb)
thaw :: Bloom a -> ST s (MBloom s a)
thaw :: forall a s. Bloom a -> ST s (MBloom s a)
thaw Bloom a
ub = (a -> [Hash]) -> Int -> Int -> STUArray s Int Hash -> MBloom s a
forall s a.
(a -> [Hash]) -> Int -> Int -> STUArray s Int Hash -> MBloom s a
MB.MB (Bloom a -> a -> [Hash]
forall a. Bloom a -> a -> [Hash]
hashes Bloom a
ub) (Bloom a -> Int
forall a. Bloom a -> Int
shift Bloom a
ub) (Bloom a -> Int
forall a. Bloom a -> Int
mask Bloom a
ub) (STUArray s Int Hash -> MBloom s a)
-> ST s (STUArray s Int Hash) -> ST s (MBloom s a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` UArray Int Hash -> ST s (STUArray s Int Hash)
forall i (a :: * -> * -> *) e (b :: * -> * -> *) (m :: * -> *).
(Ix i, IArray a e, MArray b e m) =>
a i e -> m (b i e)
ST.thaw (Bloom a -> UArray Int Hash
forall a. Bloom a -> UArray Int Hash
bitArray Bloom a
ub)
empty :: (a -> [Hash])
-> Int
-> Bloom a
{-# INLINE [1] empty #-}
empty :: forall a. (a -> [Hash]) -> Int -> Bloom a
empty a -> [Hash]
hash Int
numBits = (a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
forall a.
(a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
create a -> [Hash]
hash Int
numBits (\MBloom s a
_ -> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
singleton :: (a -> [Hash])
-> Int
-> a
-> Bloom a
{-# INLINE [1] singleton #-}
singleton :: forall a. (a -> [Hash]) -> Int -> a -> Bloom a
singleton a -> [Hash]
hash Int
numBits a
elt = (a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
forall a.
(a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
create a -> [Hash]
hash Int
numBits (\MBloom s a
mb -> MBloom s a -> a -> ST s ()
forall s a. MBloom s a -> a -> ST s ()
MB.insert MBloom s a
mb a
elt)
hashIdx :: Int -> Word32 -> (Int :* Int)
hashIdx :: Int -> Hash -> Int :* Int
hashIdx Int
mask Hash
x = (Int
y Int -> Int -> Int
forall a. FastShift a => a -> Int -> a
`shiftR` Int
logBitsInHash) Int -> Int -> Int :* Int
forall a b. a -> b -> a :* b
:* (Int
y Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
hashMask)
where hashMask :: Int
hashMask = Int
31
y :: Int
y = Hash -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Hash
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask
hashesM :: MBloom s a -> a -> [Int :* Int]
hashesM :: forall s a. MBloom s a -> a -> [Int :* Int]
hashesM MBloom s a
mb a
elt = Int -> Hash -> Int :* Int
hashIdx (MBloom s a -> Int
forall s a. MBloom s a -> Int
MB.mask MBloom s a
mb) (Hash -> Int :* Int) -> [Hash] -> [Int :* Int]
forall a b. (a -> b) -> [a] -> [b]
`map` MBloom s a -> a -> [Hash]
forall s a. MBloom s a -> a -> [Hash]
MB.hashes MBloom s a
mb a
elt
hashesU :: Bloom a -> a -> [Int :* Int]
hashesU :: forall a. Bloom a -> a -> [Int :* Int]
hashesU Bloom a
ub a
elt = Int -> Hash -> Int :* Int
hashIdx (Bloom a -> Int
forall a. Bloom a -> Int
mask Bloom a
ub) (Hash -> Int :* Int) -> [Hash] -> [Int :* Int]
forall a b. (a -> b) -> [a] -> [b]
`map` Bloom a -> a -> [Hash]
forall a. Bloom a -> a -> [Hash]
hashes Bloom a
ub a
elt
elem :: a -> Bloom a -> Bool
elem :: forall a. a -> Bloom a -> Bool
elem a
elt Bloom a
ub = ((Int :* Int) -> Bool) -> [Int :* Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int :* Int) -> Bool
test (Bloom a -> a -> [Int :* Int]
forall a. Bloom a -> a -> [Int :* Int]
hashesU Bloom a
ub a
elt)
where test :: (Int :* Int) -> Bool
test (Int
off :* Int
bit) = (Bloom a -> UArray Int Hash
forall a. Bloom a -> UArray Int Hash
bitArray Bloom a
ub UArray Int Hash -> Int -> Hash
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
off) Hash -> Hash -> Hash
forall a. Bits a => a -> a -> a
.&. (Hash
1 Hash -> Int -> Hash
forall a. FastShift a => a -> Int -> a
`shiftL` Int
bit) Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
/= Hash
0
modify :: (forall s. (MBloom s a -> ST s z))
-> Bloom a
-> Bloom a
{-# INLINE modify #-}
modify :: forall a z. (forall s. MBloom s a -> ST s z) -> Bloom a -> Bloom a
modify forall s. MBloom s a -> ST s z
body Bloom a
ub = (forall s. ST s (Bloom a)) -> Bloom a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Bloom a)) -> Bloom a)
-> (forall s. ST s (Bloom a)) -> Bloom a
forall a b. (a -> b) -> a -> b
$ do
MBloom s a
mb <- Bloom a -> ST s (MBloom s a)
forall a s. Bloom a -> ST s (MBloom s a)
thaw Bloom a
ub
z
_ <- MBloom s a -> ST s z
forall s. MBloom s a -> ST s z
body MBloom s a
mb
MBloom s a -> ST s (Bloom a)
forall s a. MBloom s a -> ST s (Bloom a)
unsafeFreeze MBloom s a
mb
insert :: a -> Bloom a -> Bloom a
{-# NOINLINE insert #-}
insert :: forall a. a -> Bloom a -> Bloom a
insert a
elt = (forall s. MBloom s a -> ST s ()) -> Bloom a -> Bloom a
forall a z. (forall s. MBloom s a -> ST s z) -> Bloom a -> Bloom a
modify ((MBloom s a -> a -> ST s ()) -> a -> MBloom s a -> ST s ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip MBloom s a -> a -> ST s ()
forall s a. MBloom s a -> a -> ST s ()
MB.insert a
elt)
insertList :: [a] -> Bloom a -> Bloom a
{-# NOINLINE insertList #-}
insertList :: forall a. [a] -> Bloom a -> Bloom a
insertList [a]
elts = (forall s. MBloom s a -> ST s ()) -> Bloom a -> Bloom a
forall a z. (forall s. MBloom s a -> ST s z) -> Bloom a -> Bloom a
modify ((forall s. MBloom s a -> ST s ()) -> Bloom a -> Bloom a)
-> (forall s. MBloom s a -> ST s ()) -> Bloom a -> Bloom a
forall a b. (a -> b) -> a -> b
$ \MBloom s a
mb -> (a -> ST s ()) -> [a] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (MBloom s a -> a -> ST s ()
forall s a. MBloom s a -> a -> ST s ()
MB.insert MBloom s a
mb) [a]
elts
{-# RULES "Bloom insert . insert" forall a b u.
insert b (insert a u) = insertList [a,b] u
#-}
{-# RULES "Bloom insertList . insert" forall x xs u.
insertList xs (insert x u) = insertList (x:xs) u
#-}
{-# RULES "Bloom insert . insertList" forall x xs u.
insert x (insertList xs u) = insertList (x:xs) u
#-}
{-# RULES "Bloom insertList . insertList" forall xs ys u.
insertList xs (insertList ys u) = insertList (xs++ys) u
#-}
{-# RULES "Bloom insertList . empty" forall h n xs.
insertList xs (empty h n) = fromList h n xs
#-}
{-# RULES "Bloom insertList . singleton" forall h n x xs.
insertList xs (singleton h n x) = fromList h n (x:xs)
#-}
notElem :: a -> Bloom a -> Bool
notElem :: forall a. a -> Bloom a -> Bool
notElem a
elt Bloom a
ub = ((Int :* Int) -> Bool) -> [Int :* Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int :* Int) -> Bool
test (Bloom a -> a -> [Int :* Int]
forall a. Bloom a -> a -> [Int :* Int]
hashesU Bloom a
ub a
elt)
where test :: (Int :* Int) -> Bool
test (Int
off :* Int
bit) = (Bloom a -> UArray Int Hash
forall a. Bloom a -> UArray Int Hash
bitArray Bloom a
ub UArray Int Hash -> Int -> Hash
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
off) Hash -> Hash -> Hash
forall a. Bits a => a -> a -> a
.&. (Hash
1 Hash -> Int -> Hash
forall a. FastShift a => a -> Int -> a
`shiftL` Int
bit) Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
0
length :: Bloom a -> Int
length :: forall a. Bloom a -> Int
length = Int -> Int -> Int
forall a. FastShift a => a -> Int -> a
shiftL Int
1 (Int -> Int) -> (Bloom a -> Int) -> Bloom a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bloom a -> Int
forall a. Bloom a -> Int
shift
unfold :: forall a b. (a -> [Hash])
-> Int
-> (b -> Maybe (a, b))
-> b
-> Bloom a
{-# INLINE unfold #-}
unfold :: forall a b.
(a -> [Hash]) -> Int -> (b -> Maybe (a, b)) -> b -> Bloom a
unfold a -> [Hash]
hashes Int
numBits b -> Maybe (a, b)
f b
k = (a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
forall a.
(a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
create a -> [Hash]
hashes Int
numBits (b -> MBloom s a -> ST s ()
forall s. b -> MBloom s a -> ST s ()
loop b
k)
where loop :: forall s. b -> MBloom s a -> ST s ()
loop :: forall s. b -> MBloom s a -> ST s ()
loop b
j MBloom s a
mb = case b -> Maybe (a, b)
f b
j of
Just (a
a, b
j') -> MBloom s a -> a -> ST s ()
forall s a. MBloom s a -> a -> ST s ()
MB.insert MBloom s a
mb a
a ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> MBloom s a -> ST s ()
forall s. b -> MBloom s a -> ST s ()
loop b
j' MBloom s a
mb
Maybe (a, b)
_ -> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
fromList :: (a -> [Hash])
-> Int
-> [a]
-> Bloom a
{-# INLINE [1] fromList #-}
fromList :: forall a. (a -> [Hash]) -> Int -> [a] -> Bloom a
fromList a -> [Hash]
hashes Int
numBits [a]
list = (a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
forall a.
(a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
create a -> [Hash]
hashes Int
numBits ((forall s. MBloom s a -> ST s ()) -> Bloom a)
-> (forall s. MBloom s a -> ST s ()) -> Bloom a
forall a b. (a -> b) -> a -> b
$ [a] -> (a -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [a]
list ((a -> ST s ()) -> ST s ())
-> (MBloom s a -> a -> ST s ()) -> MBloom s a -> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MBloom s a -> a -> ST s ()
forall s a. MBloom s a -> a -> ST s ()
MB.insert
{-# RULES "Bloom insertList . fromList" forall h n xs ys.
insertList xs (fromList h n ys) = fromList h n (xs ++ ys)
#-}
logPower2 :: Int -> Int
logPower2 :: Int -> Int
logPower2 Int
k = Int -> Int -> Int
forall {t} {t}. (Eq t, Num t, Num t, FastShift t) => t -> t -> t
go Int
0 Int
k
where go :: t -> t -> t
go t
j t
1 = t
j
go t
j t
n = t -> t -> t
go (t
jt -> t -> t
forall a. Num a => a -> a -> a
+t
1) (t
n t -> Int -> t
forall a. FastShift a => a -> Int -> a
`shiftR` Int
1)