module Data.Dish.Murmur3(
MHV(..),
Murmur3Hashable(..),
Str(..),
murmur3,
murmur3',
murmur3Int,
murmur3Int',
murmur3IntegerX86,
murmur3IntegerX86',
murmur3IntegerX64,
murmur3IntegerX64',
murmur3Raw
) where
import Foreign.C
import Foreign.Ptr
import Foreign
import qualified Data.List as L
import qualified Data.Bits as BITS
import qualified System.IO.Unsafe as US
import qualified Data.ByteString as B
data MHV = X86_32 | X86_128 | X64_128
--http://www.haskell.org/haskellwiki/List_instance
newtype Str = Str{ strCon :: String }
class Murmur3Hashable a where
toCstring :: a -> IO CStringLen
instance Murmur3Hashable Str where
toCstring val = withCAStringLen (strCon val) $ \x -> return x
instance Murmur3Hashable B.ByteString where
toCstring val = B.useAsCStringLen val $ \x -> return x
murmur3 :: Murmur3Hashable a => a
-> Int
-> MHV
-> [Int]
murmur3 v s ver = US.unsafePerformIO $ murmur3' v s ver
murmur3' :: Murmur3Hashable a => a
-> Int
-> MHV
-> IO [Int]
murmur3' v s ver = do m <- murmur3Raw v s ver; toArr m
where
toArr :: [CUInt] -> IO [Int]
toArr [] = return []
toArr l = return $ b l []
where b :: [CUInt] -> [Int] -> [Int]
b xs l2 = foldl (\ list x -> list ++ [w x] ) l2 xs
w :: CUInt -> Int
w = fromIntegral
murmur3Int' :: Murmur3Hashable a => a
-> Int
-> IO Int
murmur3Int' val seed = do v <- murmur3Raw val seed X86_32
return $ fromIntegral (L.head v)
murmur3Int :: Murmur3Hashable a => a
-> Int
-> Int
murmur3Int val seed = US.unsafePerformIO $ murmur3Int' val seed
murmur3IntegerX86' :: Murmur3Hashable a => a
-> Int
-> IO Integer
murmur3IntegerX86' val seed = x128 val seed X86_128
murmur3IntegerX86 :: Murmur3Hashable a => a
-> Int
-> Integer
murmur3IntegerX86 val seed = US.unsafePerformIO $ murmur3IntegerX86' val seed
murmur3IntegerX64' :: Murmur3Hashable a => a
-> Int
-> IO Integer
murmur3IntegerX64' val seed = x128 val seed X64_128
murmur3IntegerX64 :: Murmur3Hashable a => a
-> Int
-> Integer
murmur3IntegerX64 val seed = US.unsafePerformIO $ murmur3IntegerX64' val seed
foreign import ccall "MurmurHash3_x86_32" c_x86_32
:: CString -> CInt -> CUInt -> Ptr CUInt -> IO ()
foreign import ccall "MurmurHash3_x86_128" c_x86_128
:: CString -> CInt -> CUInt -> Ptr CUInt -> IO ()
foreign import ccall "MurmurHash3_x64_128" c_x64_128
:: CString -> CInt -> CUInt -> Ptr CUInt -> IO ()
murmur3Raw :: Murmur3Hashable a => a -> Int -> MHV -> IO [CUInt]
murmur3Raw val seed ver = do
val' <- toCstring val
let cstr = strFromCStr val'
let strLength = strLFromCStr val'
outPtr <- mallocArray arrSize
doHash ver cstr strLength (fromIntegral seed) outPtr
peekArray arrSize outPtr
where arrSize = 4
strFromCStr :: CStringLen -> CString
strFromCStr = fst
strLFromCStr :: CStringLen -> CInt
strLFromCStr i = fromIntegral $ snd i
doHash :: MHV -> CString -> CInt -> CUInt -> Ptr CUInt -> IO()
doHash X86_32 v s se o = c_x86_32 v s se o
doHash X86_128 v s se o = c_x86_128 v s se o
doHash X64_128 v s se o = c_x64_128 v s se o
x128 :: Murmur3Hashable a => a -> Int -> MHV -> IO Integer
x128 val seed ver= do
v <- hash ver
return $ twiddle 0 v
where hash :: MHV -> IO [CUInt]
hash X86_128 = murmur3Raw val seed X86_128
hash X64_128 = murmur3Raw val seed X64_128
hash _ = return []
twiddle :: Integer -> [CUInt] -> Integer
twiddle i [] = i
twiddle i (0:xs) = twiddle i xs
twiddle i (x:xs) = twiddle (BITS.shift i (BITS.bitSize x) `BITS.xor` fromIntegral x) xs