module Data.LargeHashable.Intern (
HashUpdates(..), HashAlgorithm(..), LH
, hashUpdates, ioInLH, runLH, updateXorHash
) where
import Control.Monad
import Data.Word
import Foreign.C.Types
import Foreign.Ptr
import System.IO.Unsafe (unsafePerformIO)
data HashUpdates
= HashUpdates
{ hu_updatePtr :: !(Ptr Word8 -> Int -> IO ())
, hu_updateChar :: !(CChar -> IO ())
, hu_updateUChar :: !(CUChar -> IO ())
, hu_updateShort :: !(CShort -> IO ())
, hu_updateUShort :: !(CUShort -> IO ())
, hu_updateInt :: !(CInt -> IO ())
, hu_updateUInt :: !(CUInt -> IO ())
, hu_updateLong :: !(CLong -> IO ())
, hu_updateULong :: !(CULong -> IO ())
}
data HashAlgorithm h
= HashAlgorithm
{ ha_run :: !((HashUpdates -> IO ()) -> IO h)
, ha_xor :: !(h -> h -> h)
, ha_updateHash :: !(HashUpdates -> h -> IO ())
}
data LHEnv
= LHEnv
{ lh_updates :: !HashUpdates
, lh_updateXorHash :: !([LH ()] -> IO ())
}
newtype LH a = LH (LHEnv -> IO a)
lhFmap :: (a -> b) -> LH a -> LH b
lhFmap f (LH x) =
LH $ \env ->
do y <- x env
return (f y)
lhReturn :: a -> LH a
lhReturn x = LH $ \_env -> return x
lhApp :: LH (a -> b) -> LH a -> LH b
lhApp (LH f) (LH x) =
LH $ \env -> f env <*> x env
lhBind :: LH a -> (a -> LH b) -> LH b
lhBind (LH x) f =
LH $ \env ->
do y <- x env
let (LH g) = f y
g env
lhBind' :: LH a -> LH b -> LH b
lhBind' (LH x) (LH y) =
LH $ \env ->
do _ <- x env
y env
instance Functor LH where
fmap = lhFmap
instance Applicative LH where
pure = lhReturn
(<*>) = lhApp
instance Monad LH where
return = lhReturn
(>>=) = lhBind
(>>) = lhBind'
hashUpdates :: LH HashUpdates
hashUpdates =
LH $ \env -> return (lh_updates env)
getUpdateXorHash :: LH ([LH ()] -> IO ())
getUpdateXorHash =
LH $ \env -> return (lh_updateXorHash env)
ioInLH :: IO a -> LH a
ioInLH io =
LH $ \_env -> io
runLH :: HashAlgorithm h -> LH () -> h
runLH alg lh =
unsafePerformIO (runLH' alg lh)
runLH' :: HashAlgorithm h -> LH () -> IO h
runLH' alg (LH lh) =
ha_run alg fun
where
fun updates =
lh (LHEnv updates (updateXor updates))
updateXor updates actions =
do mh <- foldM foldFun Nothing actions
case mh of
Just h -> ha_updateHash alg updates h
Nothing -> return ()
foldFun mh action =
do h2 <- runLH' alg action
case mh of
Nothing -> return (Just h2)
Just h1 ->
let !h = ha_xor alg h1 h2
in return (Just h)
updateXorHash :: [LH ()] -> LH ()
updateXorHash actions =
do f <- getUpdateXorHash
ioInLH (f actions)