{-# 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 ((.&.), unsafeShiftL, unsafeShiftR)
import Data.BloomFilter.Util ((:*)(..))
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 { " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ((Int
1::Int) forall a. Bits a => a -> Int -> a
`unsafeShiftL` forall a. Bloom a -> Int
shift Bloom a
ub) 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 a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
MBloom s a
mb <- forall a s. (a -> [Hash]) -> Int -> ST s (MBloom s a)
MB.new a -> [Hash]
hash Int
numBits
forall s. MBloom s a -> ST s ()
body MBloom s a
mb
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 = forall a. (a -> [Hash]) -> Int -> Int -> UArray Int Hash -> Bloom a
B (forall s a. MBloom s a -> a -> [Hash]
MB.hashes MBloom s a
mb) (forall s a. MBloom s a -> Int
MB.shift MBloom s a
mb) (forall s a. MBloom s a -> Int
MB.mask MBloom s a
mb) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
ST.freeze (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 = forall a. (a -> [Hash]) -> Int -> Int -> UArray Int Hash -> Bloom a
B (forall s a. MBloom s a -> a -> [Hash]
MB.hashes MBloom s a
mb) (forall s a. MBloom s a -> Int
MB.shift MBloom s a
mb) (forall s a. MBloom s a -> Int
MB.mask MBloom s a
mb) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
ST.unsafeFreeze (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 = forall s a.
(a -> [Hash]) -> Int -> Int -> STUArray s Int Hash -> MBloom s a
MB.MB (forall a. Bloom a -> a -> [Hash]
hashes Bloom a
ub) (forall a. Bloom a -> Int
shift Bloom a
ub) (forall a. Bloom a -> Int
mask Bloom a
ub) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall i (a :: * -> * -> *) e (b :: * -> * -> *) (m :: * -> *).
(Ix i, IArray a e, MArray b e m) =>
a i e -> m (b i e)
ST.thaw (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 = forall a.
(a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
create a -> [Hash]
hash Int
numBits (\MBloom s a
_ -> 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 = forall a.
(a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
create a -> [Hash]
hash Int
numBits (\MBloom s a
mb -> 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
msk Hash
x = (Int
y forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
logBitsInHash) forall a b. a -> b -> a :* b
:* (Int
y forall a. Bits a => a -> a -> a
.&. Int
hashMask)
where hashMask :: Int
hashMask = Int
31
y :: Int
y = forall a b. (Integral a, Num b) => a -> b
fromIntegral Hash
x forall a. Bits a => a -> a -> a
.&. Int
msk
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 (forall a. Bloom a -> Int
mask Bloom a
ub) forall a b. (a -> b) -> [a] -> [b]
`map` 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int :* Int) -> Bool
test (forall a. Bloom a -> a -> [Int :* Int]
hashesU Bloom a
ub a
elt)
where test :: (Int :* Int) -> Bool
test (Int
off :* Int
bit) = (forall a. Bloom a -> UArray Int Hash
bitArray Bloom a
ub forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
off) forall a. Bits a => a -> a -> a
.&. (Hash
1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
bit) 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 a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
MBloom s a
mb <- forall a s. Bloom a -> ST s (MBloom s a)
thaw Bloom a
ub
z
_ <- forall s. MBloom s a -> ST s z
body MBloom s a
mb
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 a z. (forall s. MBloom s a -> ST s z) -> Bloom a -> Bloom a
modify (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 a z. (forall s. MBloom s a -> ST s z) -> Bloom a -> Bloom a
modify forall a b. (a -> b) -> a -> b
$ \MBloom s a
mb -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int :* Int) -> Bool
test (forall a. Bloom a -> a -> [Int :* Int]
hashesU Bloom a
ub a
elt)
where test :: (Int :* Int) -> Bool
test (Int
off :* Int
bit) = (forall a. Bloom a -> UArray Int Hash
bitArray Bloom a
ub forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
off) forall a. Bits a => a -> a -> a
.&. (Hash
1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
bit) forall a. Eq a => a -> a -> Bool
== Hash
0
length :: Bloom a -> Int
length :: forall a. Bloom a -> Int
length = forall a. Bits a => a -> Int -> a
unsafeShiftL Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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]
hs Int
numBits b -> Maybe (a, b)
f b
k = forall a.
(a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
create a -> [Hash]
hs Int
numBits (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') -> forall s a. MBloom s a -> a -> ST s ()
MB.insert MBloom s a
mb a
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. b -> MBloom s a -> ST s ()
loop b
j' MBloom s a
mb
Maybe (a, b)
_ -> 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]
hs Int
numBits [a]
list = forall a.
(a -> [Hash])
-> Int -> (forall s. MBloom s a -> ST s ()) -> Bloom a
create a -> [Hash]
hs Int
numBits forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [a]
list forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
#-}