{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module: Data.Hash.Class.Mutable.Internal
-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>
-- License: MIT
-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>
-- Stability: experimental
--
-- Incremental and Resetable Mutable Hashes
--
module Data.Hash.Class.Mutable.Internal
(
-- * Incremental Hashes
  IncrementalHash(..)
, updateByteString
, updateByteStringLazy
, updateShortByteString
, updateStorable
, updateByteArray

-- * Resetable Hashes
, ResetableHash(..)
) where

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Short as BS
import qualified Data.ByteString.Unsafe as B
import Data.Kind
import Data.Word

import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable

import GHC.Exts
import GHC.IO

-- -------------------------------------------------------------------------- --
-- Incremental Mutable Hashes

class IncrementalHash a where
    type Context a :: Type
    update :: Context a -> Ptr Word8 -> Int -> IO ()
    finalize :: Context a -> IO a

updateByteString
    :: forall a
    . IncrementalHash a
    => Context a
    -> B.ByteString
    -> IO ()
updateByteString :: forall a. IncrementalHash a => Context a -> ByteString -> IO ()
updateByteString Context a
ctx ByteString
b = forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
b forall a b. (a -> b) -> a -> b
$ \(!Ptr CChar
p, !Int
l) ->
    forall a.
IncrementalHash a =>
Context a -> Ptr Word8 -> Int -> IO ()
update @a Context a
ctx (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
p) Int
l
{-# INLINE updateByteString #-}

updateByteStringLazy
    :: forall a
    . IncrementalHash a
    => Context a
    -> BL.ByteString
    -> IO ()
updateByteStringLazy :: forall a. IncrementalHash a => Context a -> ByteString -> IO ()
updateByteStringLazy Context a
ctx = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. IncrementalHash a => Context a -> ByteString -> IO ()
updateByteString @a Context a
ctx) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.toChunks
{-# INLINE updateByteStringLazy #-}

updateShortByteString
    :: forall a
    . IncrementalHash a
    => Context a
    -> BS.ShortByteString
    -> IO ()
updateShortByteString :: forall a.
IncrementalHash a =>
Context a -> ShortByteString -> IO ()
updateShortByteString Context a
ctx ShortByteString
b = forall a. ShortByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ShortByteString
b forall a b. (a -> b) -> a -> b
$ \(!Ptr CChar
p, !Int
l) ->
    forall a.
IncrementalHash a =>
Context a -> Ptr Word8 -> Int -> IO ()
update @a Context a
ctx (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
p) Int
l
{-# INLINE updateShortByteString #-}

updateStorable
    :: forall a b
    . IncrementalHash a
    => Storable b
    => Context a
    -> b
    -> IO ()
updateStorable :: forall a b.
(IncrementalHash a, Storable b) =>
Context a -> b -> IO ()
updateStorable Context a
ctx b
b = forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with b
b forall a b. (a -> b) -> a -> b
$ \Ptr b
p -> forall a.
IncrementalHash a =>
Context a -> Ptr Word8 -> Int -> IO ()
update @a Context a
ctx (forall a b. Ptr a -> Ptr b
castPtr Ptr b
p) (forall a. Storable a => a -> Int
sizeOf b
b)
{-# INLINE updateStorable #-}

updateByteArray
    :: forall a
    . IncrementalHash a
    => Context a
    -> ByteArray#
    -> IO ()
updateByteArray :: forall a. IncrementalHash a => Context a -> ByteArray# -> IO ()
updateByteArray Context a
ctx ByteArray#
a# = case ByteArray# -> Int#
isByteArrayPinned# ByteArray#
a# of
    -- Pinned ByteArray
    Int#
1# -> forall a.
IncrementalHash a =>
Context a -> Ptr Word8 -> Int -> IO ()
update @a Context a
ctx (forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
a#)) (Int# -> Int
I# Int#
size#)

    -- Unpinned ByteArray, copy content to newly allocated pinned ByteArray
    Int#
_ -> forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (Int# -> Int
I# Int#
size#) forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Word8
ptr@(Ptr Addr#
addr#) -> forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
        case forall d.
ByteArray# -> Int# -> Addr# -> Int# -> State# d -> State# d
copyByteArrayToAddr# ByteArray#
a# Int#
0# Addr#
addr# Int#
size# State# RealWorld
s0 of
            State# RealWorld
s1 -> case forall a.
IncrementalHash a =>
Context a -> Ptr Word8 -> Int -> IO ()
update @a Context a
ctx Ptr Word8
ptr (Int# -> Int
I# Int#
size#) of
                IO State# RealWorld -> (# State# RealWorld, () #)
run -> State# RealWorld -> (# State# RealWorld, () #)
run State# RealWorld
s1
  where
    size# :: Int#
size# = ByteArray# -> Int#
sizeofByteArray# ByteArray#
a#
{-# INLINE updateByteArray #-}

-- -------------------------------------------------------------------------- --
-- Class of Resetable Hashes

class IncrementalHash a => ResetableHash a where
    reset :: Context a -> IO ()