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

-- |
-- Module: Data.Hash.Class.Pure.Internal
-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>
-- License: MIT
-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>
-- Stability: experimental
--
-- Incremental Pure Hashes
--
module Data.Hash.Class.Pure.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 Pure Hashes

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

updateByteString :: forall a . IncrementalHash a => Context a -> B.ByteString -> Context a
updateByteString :: forall a. IncrementalHash a => Context a -> ByteString -> Context a
updateByteString !Context a
ctx !ByteString
b = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> 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 (Context a)
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
    -> Context a
updateByteStringLazy :: forall a. IncrementalHash a => Context a -> ByteString -> Context a
updateByteStringLazy = forall a. (a -> ByteString -> a) -> a -> ByteString -> a
BL.foldlChunks (forall a. IncrementalHash a => Context a -> ByteString -> Context a
updateByteString @a)
{-# INLINE updateByteStringLazy #-}

updateShortByteString
    :: forall a
    . IncrementalHash a
    => Context a
    -> BS.ShortByteString
    -> Context a
updateShortByteString :: forall a.
IncrementalHash a =>
Context a -> ShortByteString -> Context a
updateShortByteString !Context a
ctx ShortByteString
b = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> 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 (Context a)
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
    -> Context a
updateStorable :: forall a b.
(IncrementalHash a, Storable b) =>
Context a -> b -> Context a
updateStorable !Context a
ctx b
b = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> 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 (Context a)
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#
    -> Context a
updateByteArray :: forall a. IncrementalHash a => Context a -> ByteArray# -> Context a
updateByteArray Context a
ctx ByteArray#
a# = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$!
    case ByteArray# -> Int#
isByteArrayPinned# ByteArray#
a# of
        -- Pinned ByteArray
        Int#
1# -> forall a.
IncrementalHash a =>
Context a -> Ptr Word8 -> Int -> IO (Context a)
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 (Context a)
update @a Context a
ctx Ptr Word8
ptr (Int# -> Int
I# Int#
size#) of
                    IO State# RealWorld -> (# State# RealWorld, Context a #)
run -> State# RealWorld -> (# State# RealWorld, Context a #)
run State# RealWorld
s1
  where
    size# :: Int#
size# = ByteArray# -> Int#
sizeofByteArray# ByteArray#
a#
{-# INLINE updateByteArray #-}