-- | Generic, low-level data types for hashing. This is an internal module.
--
-- You should only import this module if you write your own hash algorithm
-- or if you need access to low-level hashing functions when defining
-- instances of 'LargeHash'.
--
-- Regular users should not import this module. Import 'Data.LargeHashable'
-- instead.
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.LargeHashable.Intern (

    HashUpdates(..), HashAlgorithm(..), LH
  , hashUpdates, ioInLH, runLH, updateXorHash

) where

-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")
import Control.Monad
import Data.Word
import Foreign.Ptr
import System.IO.Unsafe (unsafePerformIO)

-- | Functions for updating an intermediate hash value. The functions live
-- in the 'IO' monad because they are typically implemented via FFI.
data HashUpdates
    = HashUpdates
    { HashUpdates -> Ptr Word8 -> Int -> IO ()
hu_updatePtr :: {-# NOUNPACK #-} !(Ptr Word8 -> Int -> IO ()) -- ^ adds a byte array to the hash
    , HashUpdates -> Word8 -> IO ()
hu_updateUChar :: {-# NOUNPACK #-} !(Word8 -> IO ())    -- Word8
    , HashUpdates -> Word16 -> IO ()
hu_updateUShort :: {-# NOUNPACK #-} !(Word16 -> IO ())  -- Word16
    , HashUpdates -> Word32 -> IO ()
hu_updateUInt :: {-# NOUNPACK #-} !(Word32 -> IO ())      -- Word32
    , HashUpdates -> Word64 -> IO ()
hu_updateULong :: {-# NOUNPACK #-} !(Word64 -> IO ())    -- Word64
    }

-- | The interface for a hashing algorithm. The interface contains a simple run
-- function, which is used to update the hash with all values needed, and the
-- outputs the resulting hash.
data HashAlgorithm h
    = HashAlgorithm
    { forall h. HashAlgorithm h -> (HashUpdates -> IO ()) -> IO h
ha_run :: {-# NOUNPACK #-} !((HashUpdates -> IO ()) -> IO h)
    , forall h. HashAlgorithm h -> h -> h -> h
ha_xor :: {-# NOUNPACK #-} !(h -> h -> h)
    , forall h. HashAlgorithm h -> HashUpdates -> h -> IO ()
ha_updateHash :: {-# NOUNPACK #-} !(HashUpdates -> h -> IO ())
    }

data LHEnv
    = LHEnv
    { LHEnv -> HashUpdates
lh_updates :: {-# NOUNPACK #-} !HashUpdates
    , LHEnv -> [LH ()] -> IO ()
lh_updateXorHash :: {-# NOUNPACK #-} !([LH ()] -> IO ())
    }

-- | The 'LH' monad (`LH` stands for "large hash") is used in the definition of
-- hashing functions for arbitrary data types.
newtype LH a = LH (LHEnv -> IO a)

{-# INLINE lhFmap #-}
lhFmap :: (a -> b) -> LH a -> LH b
lhFmap :: forall a b. (a -> b) -> LH a -> LH b
lhFmap a -> b
f (LH LHEnv -> IO a
x) =
    (LHEnv -> IO b) -> LH b
forall a. (LHEnv -> IO a) -> LH a
LH ((LHEnv -> IO b) -> LH b) -> (LHEnv -> IO b) -> LH b
forall a b. (a -> b) -> a -> b
$ \LHEnv
env ->
    do a
y <- LHEnv -> IO a
x LHEnv
env
       b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
y)

{-# INLINE lhReturn #-}
lhReturn :: a -> LH a
lhReturn :: forall a. a -> LH a
lhReturn a
x = (LHEnv -> IO a) -> LH a
forall a. (LHEnv -> IO a) -> LH a
LH ((LHEnv -> IO a) -> LH a) -> (LHEnv -> IO a) -> LH a
forall a b. (a -> b) -> a -> b
$ \LHEnv
_env -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

{-# INLINE lhApp #-}
lhApp :: LH (a -> b) -> LH a -> LH b
lhApp :: forall a b. LH (a -> b) -> LH a -> LH b
lhApp (LH LHEnv -> IO (a -> b)
f) (LH LHEnv -> IO a
x) =
    (LHEnv -> IO b) -> LH b
forall a. (LHEnv -> IO a) -> LH a
LH ((LHEnv -> IO b) -> LH b) -> (LHEnv -> IO b) -> LH b
forall a b. (a -> b) -> a -> b
$ \LHEnv
env -> LHEnv -> IO (a -> b)
f LHEnv
env IO (a -> b) -> IO a -> IO b
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHEnv -> IO a
x LHEnv
env

{-# INLINE lhBind #-}
lhBind :: LH a -> (a -> LH b) -> LH b
lhBind :: forall a b. LH a -> (a -> LH b) -> LH b
lhBind (LH LHEnv -> IO a
x) a -> LH b
f =
    (LHEnv -> IO b) -> LH b
forall a. (LHEnv -> IO a) -> LH a
LH ((LHEnv -> IO b) -> LH b) -> (LHEnv -> IO b) -> LH b
forall a b. (a -> b) -> a -> b
$ \LHEnv
env ->
    do a
y <- LHEnv -> IO a
x LHEnv
env
       let (LH LHEnv -> IO b
g) = a -> LH b
f a
y
       LHEnv -> IO b
g LHEnv
env

{-# INLINE lhBind' #-}
lhBind' :: LH a -> LH b -> LH b
lhBind' :: forall a b. LH a -> LH b -> LH b
lhBind' (LH LHEnv -> IO a
x) (LH LHEnv -> IO b
y) =
    (LHEnv -> IO b) -> LH b
forall a. (LHEnv -> IO a) -> LH a
LH ((LHEnv -> IO b) -> LH b) -> (LHEnv -> IO b) -> LH b
forall a b. (a -> b) -> a -> b
$ \LHEnv
env ->
    do a
_ <- LHEnv -> IO a
x LHEnv
env
       LHEnv -> IO b
y LHEnv
env

instance Functor LH where
    fmap :: forall a b. (a -> b) -> LH a -> LH b
fmap = (a -> b) -> LH a -> LH b
forall a b. (a -> b) -> LH a -> LH b
lhFmap

instance Applicative LH where
    pure :: forall a. a -> LH a
pure = a -> LH a
forall a. a -> LH a
lhReturn
    <*> :: forall a b. LH (a -> b) -> LH a -> LH b
(<*>) = LH (a -> b) -> LH a -> LH b
forall a b. LH (a -> b) -> LH a -> LH b
lhApp
    *> :: forall a b. LH a -> LH b -> LH b
(*>) = LH a -> LH b -> LH b
forall a b. LH a -> LH b -> LH b
lhBind'

instance Monad LH where
    >>= :: forall a b. LH a -> (a -> LH b) -> LH b
(>>=) = LH a -> (a -> LH b) -> LH b
forall a b. LH a -> (a -> LH b) -> LH b
lhBind

{-# INLINE hashUpdates #-}
hashUpdates :: LH HashUpdates
hashUpdates :: LH HashUpdates
hashUpdates =
    (LHEnv -> IO HashUpdates) -> LH HashUpdates
forall a. (LHEnv -> IO a) -> LH a
LH ((LHEnv -> IO HashUpdates) -> LH HashUpdates)
-> (LHEnv -> IO HashUpdates) -> LH HashUpdates
forall a b. (a -> b) -> a -> b
$ \LHEnv
env -> HashUpdates -> IO HashUpdates
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHEnv -> HashUpdates
lh_updates LHEnv
env)

{-# INLINE getUpdateXorHash #-}
getUpdateXorHash :: LH ([LH ()] -> IO ())
getUpdateXorHash :: LH ([LH ()] -> IO ())
getUpdateXorHash =
    (LHEnv -> IO ([LH ()] -> IO ())) -> LH ([LH ()] -> IO ())
forall a. (LHEnv -> IO a) -> LH a
LH ((LHEnv -> IO ([LH ()] -> IO ())) -> LH ([LH ()] -> IO ()))
-> (LHEnv -> IO ([LH ()] -> IO ())) -> LH ([LH ()] -> IO ())
forall a b. (a -> b) -> a -> b
$ \LHEnv
env -> ([LH ()] -> IO ()) -> IO ([LH ()] -> IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHEnv -> [LH ()] -> IO ()
lh_updateXorHash LHEnv
env)

-- | Perform an 'IO' action in the 'LH' monad. Use with care, do not perform
-- arbitrary 'IO' operation with this function! Only use it for calling
-- functions of the 'HashUpdates' datatype.
{-# INLINE ioInLH #-}
ioInLH :: IO a -> LH a
ioInLH :: forall a. IO a -> LH a
ioInLH IO a
io =
    (LHEnv -> IO a) -> LH a
forall a. (LHEnv -> IO a) -> LH a
LH ((LHEnv -> IO a) -> LH a) -> (LHEnv -> IO a) -> LH a
forall a b. (a -> b) -> a -> b
$ \LHEnv
_env -> IO a
io

-- | Runs a 'LH' computation and returns the resulting hash.
{-# NOINLINE runLH #-}
runLH :: HashAlgorithm h -> LH () -> h
runLH :: forall h. HashAlgorithm h -> LH () -> h
runLH HashAlgorithm h
alg LH ()
lh =
    IO h -> h
forall a. IO a -> a
unsafePerformIO (HashAlgorithm h -> LH () -> IO h
forall h. HashAlgorithm h -> LH () -> IO h
runLH' HashAlgorithm h
alg LH ()
lh)

runLH' :: HashAlgorithm h -> LH () -> IO h
runLH' :: forall h. HashAlgorithm h -> LH () -> IO h
runLH' HashAlgorithm h
alg (LH LHEnv -> IO ()
lh) =
    HashAlgorithm h -> (HashUpdates -> IO ()) -> IO h
forall h. HashAlgorithm h -> (HashUpdates -> IO ()) -> IO h
ha_run HashAlgorithm h
alg HashUpdates -> IO ()
fun
    where
      fun :: HashUpdates -> IO ()
fun HashUpdates
updates =
          LHEnv -> IO ()
lh (HashUpdates -> ([LH ()] -> IO ()) -> LHEnv
LHEnv HashUpdates
updates (HashUpdates -> [LH ()] -> IO ()
forall {t :: * -> *}.
Foldable t =>
HashUpdates -> t (LH ()) -> IO ()
updateXor HashUpdates
updates))
      updateXor :: HashUpdates -> t (LH ()) -> IO ()
updateXor HashUpdates
updates t (LH ())
actions =
          do Maybe h
mh <- (Maybe h -> LH () -> IO (Maybe h))
-> Maybe h -> t (LH ()) -> IO (Maybe h)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Maybe h -> LH () -> IO (Maybe h)
foldFun Maybe h
forall a. Maybe a
Nothing t (LH ())
actions
             case Maybe h
mh of
               Just h
h -> HashAlgorithm h -> HashUpdates -> h -> IO ()
forall h. HashAlgorithm h -> HashUpdates -> h -> IO ()
ha_updateHash HashAlgorithm h
alg HashUpdates
updates h
h
               Maybe h
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      foldFun :: Maybe h -> LH () -> IO (Maybe h)
foldFun Maybe h
mh LH ()
action =
          do h
h2 <- HashAlgorithm h -> LH () -> IO h
forall h. HashAlgorithm h -> LH () -> IO h
runLH' HashAlgorithm h
alg LH ()
action
             case Maybe h
mh of
               Maybe h
Nothing -> Maybe h -> IO (Maybe h)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (h -> Maybe h
forall a. a -> Maybe a
Just h
h2)
               Just h
h1 ->
                   let !h :: h
h = HashAlgorithm h -> h -> h -> h
forall h. HashAlgorithm h -> h -> h -> h
ha_xor HashAlgorithm h
alg h
h1 h
h2
                   in Maybe h -> IO (Maybe h)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (h -> Maybe h
forall a. a -> Maybe a
Just h
h)

updateXorHash :: [LH ()] -> LH ()
updateXorHash :: [LH ()] -> LH ()
updateXorHash [LH ()]
actions =
    do [LH ()] -> IO ()
f <- LH ([LH ()] -> IO ())
getUpdateXorHash
       IO () -> LH ()
forall a. IO a -> LH a
ioInLH ([LH ()] -> IO ()
f [LH ()]
actions)