{-# 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 Mutable Hashes
--
module Data.Hash.Class.Mutable.Internal
( IncrementalHash(..)
, updateByteString
, updateByteStringLazy
, updateShortByteString
, updateStorable
, updateByteArray
) 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 :: Context a -> ByteString -> IO ()
updateByteString Context a
ctx ByteString
b = ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
b ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(!Ptr CChar
p, !Int
l) ->
    Context a -> Ptr Word8 -> Int -> IO ()
forall a.
IncrementalHash a =>
Context a -> Ptr Word8 -> Int -> IO ()
update @a Context a
ctx (Ptr CChar -> Ptr Word8
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 :: Context a -> ByteString -> IO ()
updateByteStringLazy Context a
ctx = (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Context a -> ByteString -> IO ()
forall a. IncrementalHash a => Context a -> ByteString -> IO ()
updateByteString @a Context a
ctx) ([ByteString] -> IO ())
-> (ByteString -> [ByteString]) -> ByteString -> IO ()
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 :: Context a -> ShortByteString -> IO ()
updateShortByteString Context a
ctx ShortByteString
b = ShortByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ShortByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ShortByteString
b ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(!Ptr CChar
p, !Int
l) ->
    Context a -> Ptr Word8 -> Int -> IO ()
forall a.
IncrementalHash a =>
Context a -> Ptr Word8 -> Int -> IO ()
update @a Context a
ctx (Ptr CChar -> Ptr Word8
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 :: Context a -> b -> IO ()
updateStorable Context a
ctx b
b = b -> (Ptr b -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with b
b ((Ptr b -> IO ()) -> IO ()) -> (Ptr b -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr b
p -> Context a -> Ptr Word8 -> Int -> IO ()
forall a.
IncrementalHash a =>
Context a -> Ptr Word8 -> Int -> IO ()
update @a Context a
ctx (Ptr b -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr b
p) (b -> Int
forall a. Storable a => a -> Int
sizeOf b
b)
{-# INLINE updateStorable #-}

updateByteArray
    :: forall a
    . IncrementalHash a
    => Context a
    -> ByteArray#
    -> IO ()
updateByteArray :: Context a -> ByteArray# -> IO ()
updateByteArray Context a
ctx ByteArray#
a# = case ByteArray# -> Int#
isByteArrayPinned# ByteArray#
a# of
    -- Pinned ByteArray
    Int#
1# -> Context a -> Ptr Word8 -> Int -> IO ()
forall a.
IncrementalHash a =>
Context a -> Ptr Word8 -> Int -> IO ()
update @a Context a
ctx (Addr# -> Ptr Word8
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#
_ -> Int -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (Int# -> Int
I# Int#
size#) ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Word8
ptr@(Ptr Addr#
addr#) -> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
        case ByteArray#
-> Int# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld
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 Context a -> Ptr Word8 -> Int -> IO ()
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 #-}