-- Copyright 2020 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE BangPatterns #-}
-- | Seed class to hash 'Derive.Stack.Frame's into the random seed.  This is
-- like Hashable, except that it must be stable (so hashable isn't suitable),
-- and since it's for a random seed, doesn't care about being well-distributed.
-- So I use the addition algorithm, which has been stable for a while.
module Util.Seed (
    Seed(to_seed), (&)
) where
import qualified Data.Primitive.PrimArray as PrimArray
import qualified Data.Text as Text
import qualified Data.Text.Array as Text.Array
import qualified Data.Text.Internal as Text.Internal
import qualified Data.Word as Word

import qualified Foreign
import qualified System.IO.Unsafe as Unsafe


class Seed a where
    to_seed :: Int -> a -> Int

(&) :: Seed a => Int -> a -> Int
& :: forall a. Seed a => Int -> a -> Int
(&) = Int -> a -> Int
forall a. Seed a => Int -> a -> Int
to_seed
infixl 1 &

combine :: Int -> Int -> Int
combine :: Int -> Int -> Int
combine = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
-- This is fnv, which hashable uses (for now):
-- combine h1 h2 = (h1 * 16777619) `Bit.xor` h2

instance Seed Int where
    to_seed :: Int -> Int -> Int
to_seed Int
salt Int
n = Int -> Int -> Int
combine Int
salt Int
n

instance Seed Word.Word64 where
    to_seed :: Int -> Word64 -> Int
to_seed Int
salt Word64
n = Int
salt Int -> Int -> Int
`combine` Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n
instance Seed Word.Word32 where
    to_seed :: Int -> Word32 -> Int
to_seed Int
salt Word32
n = Int
salt Int -> Int -> Int
`combine` Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
n

instance Seed Double where
    to_seed :: Int -> Double -> Int
to_seed Int
salt Double
n = Int -> Word64 -> Int
forall a. Seed a => Int -> a -> Int
to_seed Int
salt
        ((IO Word64 -> Word64
forall a. IO a -> a
Unsafe.unsafeDupablePerformIO (IO Word64 -> Word64) -> IO Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ Double -> (Ptr Double -> IO Word64) -> IO Word64
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
Foreign.with Double
n ((Ptr Double -> IO Word64) -> IO Word64)
-> (Ptr Double -> IO Word64) -> IO Word64
forall a b. (a -> b) -> a -> b
$
            Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
Foreign.peek (Ptr Word64 -> IO Word64)
-> (Ptr Double -> Ptr Word64) -> Ptr Double -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Double -> Ptr Word64
forall a b. Ptr a -> Ptr b
Foreign.castPtr) :: Word.Word64)

instance Seed Text.Text where
    to_seed :: Int -> Text -> Int
to_seed = Int -> Text -> Int
simple_text

simple_text :: Int -> Text.Text -> Int
simple_text :: Int -> Text -> Int
simple_text = (Int -> Char -> Int) -> Int -> Text -> Int
forall a. (a -> Char -> a) -> a -> Text -> a
Text.foldl' (\Int
n -> (Int
n+) (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum)

_prim_text :: Int -> Text.Text -> Int
_prim_text :: Int -> Text -> Int
_prim_text Int
salt Text
t = Int
salt Int -> Int -> Int
`combine` Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Word16
prim_text_sum Text
t)

-- | Sum the Word16 components of the Text directly.  In theory this should be
-- faster than Text.foldl', since it skips decoding UTF16 to a Char, but in
-- practice it seems to be just the same.
--
-- This is only 16 bits so it'll wrap before an Int, but since seed winds up
-- getting trimmed to 0-999, I don't really care.
prim_text_sum :: Text.Text -> Word.Word16
prim_text_sum :: Text -> Word16
prim_text_sum (Text.Internal.Text Array
tarray Int
offset Int
len) = Word16 -> Int -> Word16
go Word16
0 Int
offset
    where
    go :: Word16 -> Int -> Word16
go !Word16
accum !Int
offset
        | Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
end =
            let !v :: Word16
v = PrimArray Word16 -> Int -> Word16
forall a. Prim a => PrimArray a -> Int -> a
PrimArray.indexPrimArray PrimArray Word16
array Int
offset
            in Word16 -> Int -> Word16
go (Word16
accum Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
v) (Int
offsetInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        | Bool
otherwise = Word16
accum
    end :: Int
end = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len
    array :: PrimArray Word16
array = Array -> PrimArray Word16
toPrim Array
tarray

toPrim :: Text.Array.Array -> PrimArray.PrimArray Word.Word16
toPrim :: Array -> PrimArray Word16
toPrim Array
array = ByteArray# -> PrimArray Word16
forall a. ByteArray# -> PrimArray a
PrimArray.PrimArray (Array -> ByteArray#
Text.Array.aBA Array
array)