{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module Data.HashTable.Internal.Linear.Bucket
( Bucket,
newBucketArray,
newBucketSize,
emptyWithSize,
growBucketTo,
snoc,
size,
lookup,
lookupIndex,
elemAt,
delete,
mutate,
mutateST,
toList,
fromList,
mapM_,
foldM,
expandBucketArray,
expandArray,
nelemsAndOverheadInWords,
bucketSplitSize
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad hiding (foldM, mapM_)
import qualified Control.Monad
import Control.Monad.ST (ST)
#ifdef DEBUG
import Data.HashTable.Internal.Utils (unsafeIOToST)
#endif
import Data.HashTable.Internal.Array
import Data.Maybe (fromMaybe)
import Data.STRef
import Prelude hiding (lookup, mapM_)
import Data.HashTable.Internal.UnsafeTricks
#ifdef DEBUG
import System.IO
#endif
type Bucket s k v = Key (Bucket_ s k v)
data Bucket_ s k v = Bucket { forall s k v. Bucket_ s k v -> Int
_bucketSize :: {-# UNPACK #-} !Int
, forall s k v. Bucket_ s k v -> STRef s Int
_highwater :: {-# UNPACK #-} !(STRef s Int)
, forall s k v. Bucket_ s k v -> MutableArray s k
_keys :: {-# UNPACK #-} !(MutableArray s k)
, forall s k v. Bucket_ s k v -> MutableArray s v
_values :: {-# UNPACK #-} !(MutableArray s v)
}
bucketSplitSize :: Int
bucketSplitSize :: Int
bucketSplitSize = Int
16
newBucketArray :: Int -> ST s (MutableArray s (Bucket s k v))
newBucketArray :: forall s k v. Int -> ST s (MutableArray s (Bucket s k v))
newBucketArray Int
k = Int -> Bucket s k v -> ST s (MutableArray s (Bucket s k v))
forall a s. Int -> a -> ST s (MutableArray s a)
newArray Int
k Bucket s k v
forall a. Bucket s k v
emptyRecord
nelemsAndOverheadInWords :: Bucket s k v -> ST s (Int,Int)
nelemsAndOverheadInWords :: forall s k v. Bucket s k v -> ST s (Int, Int)
nelemsAndOverheadInWords Bucket s k v
bKey = do
if (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bKey)
then do
!hw <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
forall {s}. STRef s Int
hwRef
let !w = Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
hw
return (hw, constOverhead + 2*w)
else
(Int, Int) -> ST s (Int, Int)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, Int
0)
where
constOverhead :: Int
constOverhead = Int
8
b :: a
b = Bucket s k v -> a
forall a. Bucket s k v -> a
fromKey Bucket s k v
bKey
sz :: Int
sz = Bucket_ (Bucket s k v) (Bucket s k v) (Bucket s k v) -> Int
forall s k v. Bucket_ s k v -> Int
_bucketSize Bucket_ (Bucket s k v) (Bucket s k v) (Bucket s k v)
forall {a}. a
b
hwRef :: STRef s Int
hwRef = Bucket_ s (Bucket s k v) (Bucket s k v) -> STRef s Int
forall s k v. Bucket_ s k v -> STRef s Int
_highwater Bucket_ s (Bucket s k v) (Bucket s k v)
forall {a}. a
b
emptyWithSize :: Int -> ST s (Bucket s k v)
emptyWithSize :: forall s k v. Int -> ST s (Bucket s k v)
emptyWithSize !Int
sz = do
!keys <- Int -> Bucket s k v -> ST s (MutableArray s (Bucket s k v))
forall a s. Int -> a -> ST s (MutableArray s a)
newArray Int
sz Bucket s k v
forall a. HasCallStack => a
undefined
!values <- newArray sz undefined
!ref <- newSTRef 0
return $ toKey $ Bucket sz ref keys values
newBucketSize :: Int
newBucketSize :: Int
newBucketSize = Int
4
expandArray :: a
-> Int
-> Int
-> MutableArray s a
-> ST s (MutableArray s a)
expandArray :: forall a s.
a -> Int -> Int -> MutableArray s a -> ST s (MutableArray s a)
expandArray a
def !Int
sz !Int
hw !MutableArray s a
arr = do
newArr <- Int -> a -> ST s (MutableArray s a)
forall a s. Int -> a -> ST s (MutableArray s a)
newArray Int
sz a
def
cp newArr
where
cp :: MutableArray s a -> ST s (MutableArray s a)
cp !MutableArray s a
newArr = Int -> ST s (MutableArray s a)
go Int
0
where
go :: Int -> ST s (MutableArray s a)
go !Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
hw = MutableArray s a -> ST s (MutableArray s a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MutableArray s a
newArr
| Bool
otherwise = do
MutableArray s a -> Int -> ST s a
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s a
arr Int
i ST s a -> (a -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray s a -> Int -> a -> ST s ()
forall s a. MutableArray s a -> Int -> a -> ST s ()
writeArray MutableArray s a
newArr Int
i
Int -> ST s (MutableArray s a)
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
expandBucketArray :: Int
-> Int
-> MutableArray s (Bucket s k v)
-> ST s (MutableArray s (Bucket s k v))
expandBucketArray :: forall s k v.
Int
-> Int
-> MutableArray s (Bucket s k v)
-> ST s (MutableArray s (Bucket s k v))
expandBucketArray = Bucket s k v
-> Int
-> Int
-> MutableArray s (Bucket s k v)
-> ST s (MutableArray s (Bucket s k v))
forall a s.
a -> Int -> Int -> MutableArray s a -> ST s (MutableArray s a)
expandArray Bucket s k v
forall a. Bucket s k v
emptyRecord
growBucketTo :: Int -> Bucket s k v -> ST s (Bucket s k v)
growBucketTo :: forall s k v. Int -> Bucket s k v -> ST s (Bucket s k v)
growBucketTo !Int
sz Bucket s k v
bk | Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bk = Int -> ST s (Bucket s k v)
forall s k v. Int -> ST s (Bucket s k v)
emptyWithSize Int
sz
| Bool
otherwise = do
if Int
osz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz
then Bucket s k v -> ST s (Bucket s k v)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Bucket s k v
bk
else do
hw <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
forall {s}. STRef s Int
hwRef
k' <- expandArray undefined sz hw keys
v' <- expandArray undefined sz hw values
return $ toKey $ Bucket sz hwRef k' v'
where
bucket :: a
bucket = Bucket s k v -> a
forall a. Bucket s k v -> a
fromKey Bucket s k v
bk
osz :: Int
osz = Bucket_ (Bucket s k v) (Bucket s k v) (Bucket s k v) -> Int
forall s k v. Bucket_ s k v -> Int
_bucketSize Bucket_ (Bucket s k v) (Bucket s k v) (Bucket s k v)
forall {a}. a
bucket
hwRef :: STRef s Int
hwRef = Bucket_ s (Bucket s k v) (Bucket s k v) -> STRef s Int
forall s k v. Bucket_ s k v -> STRef s Int
_highwater Bucket_ s (Bucket s k v) (Bucket s k v)
forall {a}. a
bucket
keys :: MutableArray s k
keys = Bucket_ s k (Bucket s k v) -> MutableArray s k
forall s k v. Bucket_ s k v -> MutableArray s k
_keys Bucket_ s k (Bucket s k v)
forall {a}. a
bucket
values :: MutableArray s v
values = Bucket_ s (Bucket s k v) v -> MutableArray s v
forall s k v. Bucket_ s k v -> MutableArray s v
_values Bucket_ s (Bucket s k v) v
forall {a}. a
bucket
{-# INLINE snoc #-}
snoc :: Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
snoc :: forall s k v.
Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
snoc Bucket s k v
bucket | Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bucket = k -> v -> ST s (Int, Maybe (Bucket s k v))
forall {a} {k} {v} {s}.
Num a =>
k -> v -> ST s (a, Maybe (Bucket s k v))
mkNew
| Bool
otherwise = Bucket_ s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
forall {s} {k} {v}.
Bucket_ s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
snoc' (Bucket s k v -> Bucket_ s k v
forall a. Bucket s k v -> a
fromKey Bucket s k v
bucket)
where
mkNew :: k -> v -> ST s (a, Maybe (Bucket s k v))
mkNew !k
k !v
v = do
String -> ST s ()
forall s. String -> ST s ()
debug String
"Bucket.snoc: mkNew"
keys <- Int -> k -> ST s (MutableArray s k)
forall a s. Int -> a -> ST s (MutableArray s a)
newArray Int
newBucketSize k
forall a. HasCallStack => a
undefined
values <- newArray newBucketSize undefined
writeArray keys 0 k
writeArray values 0 v
ref <- newSTRef 1
return (1, Just $ toKey $ Bucket newBucketSize ref keys values)
snoc' :: Bucket_ s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
snoc' (Bucket Int
bsz STRef s Int
hwRef MutableArray s k
keys MutableArray s v
values) !k
k !v
v =
STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
hwRef ST s Int
-> (Int -> ST s (Int, Maybe (Bucket s k v)))
-> ST s (Int, Maybe (Bucket s k v))
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ST s (Int, Maybe (Bucket s k v))
check
where
check :: Int -> ST s (Int, Maybe (Bucket s k v))
check !Int
hw
| Int
hw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bsz = Int -> ST s (Int, Maybe (Bucket s k v))
forall {a}. Int -> ST s (Int, Maybe a)
bump Int
hw
| Bool
otherwise = Int -> ST s (Int, Maybe (Bucket s k v))
forall {s}. Int -> ST s (Int, Maybe (Bucket s k v))
spill Int
hw
bump :: Int -> ST s (Int, Maybe a)
bump Int
hw = do
String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"Bucket.snoc: bumping hw, bsz=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bsz String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", hw="
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
hw
MutableArray s k -> Int -> k -> ST s ()
forall s a. MutableArray s a -> Int -> a -> ST s ()
writeArray MutableArray s k
keys Int
hw k
k
MutableArray s v -> Int -> v -> ST s ()
forall s a. MutableArray s a -> Int -> a -> ST s ()
writeArray MutableArray s v
values Int
hw v
v
let !hw' :: Int
hw' = Int
hw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
hwRef Int
hw'
String -> ST s ()
forall s. String -> ST s ()
debug String
"Bucket.snoc: finished"
(Int, Maybe a) -> ST s (Int, Maybe a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
hw', Maybe a
forall a. Maybe a
Nothing)
doublingThreshold :: Int
doublingThreshold = Int
bucketSplitSize Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
growFactor :: Double
growFactor = Double
1.5 :: Double
newSize :: Int -> Int
newSize Int
z | Int
z Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int
newBucketSize
| Int
z Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
doublingThreshold = Int
z Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
| Bool
otherwise = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
growFactor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
z
spill :: Int -> ST s (Int, Maybe (Bucket s k v))
spill !Int
hw = do
let sz :: Int
sz = Int -> Int
newSize Int
bsz
String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"Bucket.snoc: spilling, old size=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bsz String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", new size="
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz
bk <- Int -> Bucket s k v -> ST s (Bucket s k v)
forall s k v. Int -> Bucket s k v -> ST s (Bucket s k v)
growBucketTo Int
sz Bucket s k v
bucket
debug "Bucket.snoc: spill finished, snoccing element"
let (Bucket _ hwRef' keys' values') = fromKey bk
let !hw' = Int
hwInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
writeArray keys' hw k
writeArray values' hw v
writeSTRef hwRef' hw'
return (hw', Just bk)
{-# INLINE size #-}
size :: Bucket s k v -> ST s Int
size :: forall s k v. Bucket s k v -> ST s Int
size Bucket s k v
b | Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
b = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
| Bool
otherwise = STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef (STRef s Int -> ST s Int) -> STRef s Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Bucket_ s (Bucket s k v) (Bucket s k v) -> STRef s Int
forall s k v. Bucket_ s k v -> STRef s Int
_highwater (Bucket_ s (Bucket s k v) (Bucket s k v) -> STRef s Int)
-> Bucket_ s (Bucket s k v) (Bucket s k v) -> STRef s Int
forall a b. (a -> b) -> a -> b
$ Bucket s k v -> Bucket_ s (Bucket s k v) (Bucket s k v)
forall a. Bucket s k v -> a
fromKey Bucket s k v
b
lookup :: (Eq k) => Bucket s k v -> k -> ST s (Maybe v)
lookup :: forall k s v. Eq k => Bucket s k v -> k -> ST s (Maybe v)
lookup Bucket s k v
bucketKey !k
k | Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bucketKey = Maybe v -> ST s (Maybe v)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing
| Bool
otherwise = Bucket_ s k v -> ST s (Maybe v)
forall {s} {v}. Bucket_ s k v -> ST s (Maybe v)
lookup' (Bucket_ s k v -> ST s (Maybe v))
-> Bucket_ s k v -> ST s (Maybe v)
forall a b. (a -> b) -> a -> b
$ Bucket s k v -> Bucket_ s k v
forall a. Bucket s k v -> a
fromKey Bucket s k v
bucketKey
where
lookup' :: Bucket_ s k v -> ST s (Maybe v)
lookup' (Bucket Int
_ STRef s Int
hwRef MutableArray s k
keys MutableArray s v
values) = do
hw <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
hwRef
go (hw-1)
where
go :: Int -> ST s (Maybe v)
go !Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe v -> ST s (Maybe v)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing
| Bool
otherwise = do
k' <- MutableArray s k -> Int -> ST s k
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s k
keys Int
i
if k == k'
then do
!v <- readArray values i
return $! Just v
else go (i-1)
lookupIndex :: (Eq k) => Bucket s k v -> k -> ST s (Maybe Int)
lookupIndex :: forall k s v. Eq k => Bucket s k v -> k -> ST s (Maybe Int)
lookupIndex Bucket s k v
bucketKey !k
k
| Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bucketKey = Maybe Int -> ST s (Maybe Int)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
| Bool
otherwise = Bucket_ s k (Bucket s k v) -> ST s (Maybe Int)
forall {s} {v}. Bucket_ s k v -> ST s (Maybe Int)
lookup' (Bucket_ s k (Bucket s k v) -> ST s (Maybe Int))
-> Bucket_ s k (Bucket s k v) -> ST s (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Bucket s k v -> Bucket_ s k (Bucket s k v)
forall a. Bucket s k v -> a
fromKey Bucket s k v
bucketKey
where
lookup' :: Bucket_ s k v -> ST s (Maybe Int)
lookup' (Bucket Int
_ STRef s Int
hwRef MutableArray s k
keys MutableArray s v
_values) = do
hw <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
hwRef
go (hw-1)
where
go :: Int -> ST s (Maybe Int)
go !Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe Int -> ST s (Maybe Int)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
| Bool
otherwise = do
k' <- MutableArray s k -> Int -> ST s k
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s k
keys Int
i
if k == k'
then return (Just i)
else go (i-1)
elemAt :: Bucket s k v -> Int -> ST s (Maybe (k,v))
elemAt :: forall s k v. Bucket s k v -> Int -> ST s (Maybe (k, v))
elemAt Bucket s k v
bucketKey Int
ix
| Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bucketKey = Maybe (k, v) -> ST s (Maybe (k, v))
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (k, v)
forall a. Maybe a
Nothing
| Bool
otherwise = Bucket_ s k v -> ST s (Maybe (k, v))
forall {s} {a} {b}. Bucket_ s a b -> ST s (Maybe (a, b))
lookup' (Bucket_ s k v -> ST s (Maybe (k, v)))
-> Bucket_ s k v -> ST s (Maybe (k, v))
forall a b. (a -> b) -> a -> b
$ Bucket s k v -> Bucket_ s k v
forall a. Bucket s k v -> a
fromKey Bucket s k v
bucketKey
where
lookup' :: Bucket_ s a b -> ST s (Maybe (a, b))
lookup' (Bucket Int
_ STRef s Int
hwRef MutableArray s a
keys MutableArray s b
values) = do
hw <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
hwRef
if 0 <= ix && ix < hw
then do k <- readArray keys ix
v <- readArray values ix
return (Just (k,v))
else return Nothing
{-# INLINE toList #-}
toList :: Bucket s k v -> ST s [(k,v)]
toList :: forall s k v. Bucket s k v -> ST s [(k, v)]
toList Bucket s k v
bucketKey | Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bucketKey = [(k, v)] -> ST s [(k, v)]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = Bucket_ s k v -> ST s [(k, v)]
forall {s} {k} {v}. Bucket_ s k v -> ST s [(k, v)]
toList' (Bucket_ s k v -> ST s [(k, v)]) -> Bucket_ s k v -> ST s [(k, v)]
forall a b. (a -> b) -> a -> b
$ Bucket s k v -> Bucket_ s k v
forall a. Bucket s k v -> a
fromKey Bucket s k v
bucketKey
where
toList' :: Bucket_ s k v -> ST s [(k, v)]
toList' (Bucket Int
_ STRef s Int
hwRef MutableArray s k
keys MutableArray s v
values) = do
hw <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
hwRef
go [] hw 0
where
go :: [(k, v)] -> Int -> Int -> ST s [(k, v)]
go ![(k, v)]
l !Int
hw !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
hw = [(k, v)] -> ST s [(k, v)]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return [(k, v)]
l
| Bool
otherwise = do
k <- MutableArray s k -> Int -> ST s k
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s k
keys Int
i
v <- readArray values i
go ((k,v):l) hw $ i+1
{-# INLINE fromList #-}
fromList :: [(k,v)] -> ST s (Bucket s k v)
fromList :: forall k v s. [(k, v)] -> ST s (Bucket s k v)
fromList [(k, v)]
l = (Bucket s k v -> (k, v) -> ST s (Bucket s k v))
-> Bucket s k v -> [(k, v)] -> ST s (Bucket s k v)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Control.Monad.foldM Bucket s k v -> (k, v) -> ST s (Bucket s k v)
forall {k} {v} {s}. Bucket s k v -> (k, v) -> ST s (Bucket s k v)
f Bucket s k v
forall a. Bucket s k v
emptyRecord ([(k, v)] -> [(k, v)]
forall a. [a] -> [a]
reverse [(k, v)]
l)
where
f :: Bucket s k v -> (k, v) -> ST s (Bucket s k v)
f Bucket s k v
bucket (k
k,v
v) = do
(_,m) <- Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
forall s k v.
Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
snoc Bucket s k v
bucket k
k v
v
return $ fromMaybe bucket m
delete :: (Eq k) => Bucket s k v -> k -> ST s Bool
delete :: forall k s v. Eq k => Bucket s k v -> k -> ST s Bool
delete Bucket s k v
bucketKey !k
k | Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bucketKey = do
String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"Bucket.delete: empty bucket"
Bool -> ST s Bool
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise = do
String -> ST s ()
forall s. String -> ST s ()
debug String
"Bucket.delete: start"
Bucket_ s k (Bucket s k v) -> ST s Bool
forall {s} {v}. Bucket_ s k v -> ST s Bool
del (Bucket_ s k (Bucket s k v) -> ST s Bool)
-> Bucket_ s k (Bucket s k v) -> ST s Bool
forall a b. (a -> b) -> a -> b
$ Bucket s k v -> Bucket_ s k (Bucket s k v)
forall a. Bucket s k v -> a
fromKey Bucket s k v
bucketKey
where
del :: Bucket_ s k v -> ST s Bool
del (Bucket Int
sz STRef s Int
hwRef MutableArray s k
keys MutableArray s v
values) = do
hw <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
hwRef
debug $ "Bucket.delete: hw=" ++ show hw ++ ", sz=" ++ show sz
go hw $ hw - 1
where
go :: Int -> Int -> ST s Bool
go !Int
hw !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Bool -> ST s Bool
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise = do
k' <- MutableArray s k -> Int -> ST s k
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s k
keys Int
i
if k == k'
then do
debug $ "found entry to delete at " ++ show i
move (hw-1) i keys
move (hw-1) i values
let !hw' = Int
hwInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
writeSTRef hwRef hw'
return True
else go hw (i-1)
mutate :: (Eq k) =>
Bucket s k v
-> k
-> (Maybe v -> (Maybe v, a))
-> ST s (Int, Maybe (Bucket s k v), a)
mutate :: forall k s v a.
Eq k =>
Bucket s k v
-> k
-> (Maybe v -> (Maybe v, a))
-> ST s (Int, Maybe (Bucket s k v), a)
mutate Bucket s k v
bucketKey !k
k !Maybe v -> (Maybe v, a)
f = Bucket s k v
-> k
-> (Maybe v -> ST s (Maybe v, a))
-> ST s (Int, Maybe (Bucket s k v), a)
forall k s v a.
Eq k =>
Bucket s k v
-> k
-> (Maybe v -> ST s (Maybe v, a))
-> ST s (Int, Maybe (Bucket s k v), a)
mutateST Bucket s k v
bucketKey k
k ((Maybe v, a) -> ST s (Maybe v, a)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe v, a) -> ST s (Maybe v, a))
-> (Maybe v -> (Maybe v, a)) -> Maybe v -> ST s (Maybe v, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe v -> (Maybe v, a)
f)
{-# INLINE mutate #-}
mutateST :: (Eq k) =>
Bucket s k v
-> k
-> (Maybe v -> ST s (Maybe v, a))
-> ST s (Int, Maybe (Bucket s k v), a)
mutateST :: forall k s v a.
Eq k =>
Bucket s k v
-> k
-> (Maybe v -> ST s (Maybe v, a))
-> ST s (Int, Maybe (Bucket s k v), a)
mutateST Bucket s k v
bucketKey !k
k !Maybe v -> ST s (Maybe v, a)
f
| Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bucketKey = do
fRes <- Maybe v -> ST s (Maybe v, a)
f Maybe v
forall a. Maybe a
Nothing
case fRes of
(Maybe v
Nothing, a
a) -> (Int, Maybe (Bucket s k v), a)
-> ST s (Int, Maybe (Bucket s k v), a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, Maybe (Bucket s k v)
forall a. Maybe a
Nothing, a
a)
(Just v
v', a
a) -> do
(!hw', mbk) <- Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
forall s k v.
Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
snoc Bucket s k v
bucketKey k
k v
v'
return (hw', mbk, a)
| Bool
otherwise = Bucket_ s k v -> ST s (Int, Maybe (Bucket s k v), a)
mutate' (Bucket_ s k v -> ST s (Int, Maybe (Bucket s k v), a))
-> Bucket_ s k v -> ST s (Int, Maybe (Bucket s k v), a)
forall a b. (a -> b) -> a -> b
$ Bucket s k v -> Bucket_ s k v
forall a. Bucket s k v -> a
fromKey Bucket s k v
bucketKey
where
mutate' :: Bucket_ s k v -> ST s (Int, Maybe (Bucket s k v), a)
mutate' (Bucket Int
_sz STRef s Int
hwRef MutableArray s k
keys MutableArray s v
values) = do
hw <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
hwRef
pos <- findPosition hw (hw-1)
mv <- do
if pos < 0
then return Nothing
else readArray values pos >>= return . Just
fRes <- f mv
case (mv, fRes) of
(Maybe v
Nothing, (Maybe v
Nothing, a
a)) -> (Int, Maybe (Bucket s k v), a)
-> ST s (Int, Maybe (Bucket s k v), a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
hw, Maybe (Bucket s k v)
forall a. Maybe a
Nothing, a
a)
(Maybe v
Nothing, (Just v
v', a
a)) -> do
(!hw', mbk) <- Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
forall s k v.
Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
snoc Bucket s k v
bucketKey k
k v
v'
return (hw', mbk, a)
(Just v
_v, (Just v
v', a
a)) -> do
MutableArray s v -> Int -> v -> ST s ()
forall s a. MutableArray s a -> Int -> a -> ST s ()
writeArray MutableArray s v
values Int
pos v
v'
(Int, Maybe (Bucket s k v), a)
-> ST s (Int, Maybe (Bucket s k v), a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
hw, Maybe (Bucket s k v)
forall a. Maybe a
Nothing, a
a)
(Just v
_v, (Maybe v
Nothing, a
a)) -> do
Int -> Int -> MutableArray s k -> ST s ()
forall s a. Int -> Int -> MutableArray s a -> ST s ()
move (Int
hwInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
pos MutableArray s k
keys
Int -> Int -> MutableArray s v -> ST s ()
forall s a. Int -> Int -> MutableArray s a -> ST s ()
move (Int
hwInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
pos MutableArray s v
values
let !hw' :: Int
hw' = Int
hwInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
hwRef Int
hw'
(Int, Maybe (Bucket s k v), a)
-> ST s (Int, Maybe (Bucket s k v), a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
hw', Maybe (Bucket s k v)
forall a. Maybe a
Nothing, a
a)
where
findPosition :: t -> Int -> ST s Int
findPosition !t
hw !Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
1)
| Bool
otherwise = do
k' <- MutableArray s k -> Int -> ST s k
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s k
keys Int
i
if k == k'
then return i
else findPosition hw (i-1)
{-# INLINE mapM_ #-}
mapM_ :: ((k,v) -> ST s a) -> Bucket s k v -> ST s ()
mapM_ :: forall k v s a. ((k, v) -> ST s a) -> Bucket s k v -> ST s ()
mapM_ (k, v) -> ST s a
f Bucket s k v
bucketKey
| Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bucketKey = do
String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"Bucket.mapM_: bucket was empty"
() -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = Bucket_ s k v -> ST s ()
doMap (Bucket_ s k v -> ST s ()) -> Bucket_ s k v -> ST s ()
forall a b. (a -> b) -> a -> b
$ Bucket s k v -> Bucket_ s k v
forall a. Bucket s k v -> a
fromKey Bucket s k v
bucketKey
where
doMap :: Bucket_ s k v -> ST s ()
doMap (Bucket Int
sz STRef s Int
hwRef MutableArray s k
keys MutableArray s v
values) = do
hw <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
hwRef
debug $ "Bucket.mapM_: hw was " ++ show hw ++ ", sz was " ++ show sz
go hw 0
where
go :: Int -> Int -> ST s ()
go !Int
hw !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
hw = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
k <- MutableArray s k -> Int -> ST s k
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s k
keys Int
i
v <- readArray values i
_ <- f (k,v)
go hw $ i+1
{-# INLINE foldM #-}
foldM :: (a -> (k,v) -> ST s a) -> a -> Bucket s k v -> ST s a
foldM :: forall a k v s.
(a -> (k, v) -> ST s a) -> a -> Bucket s k v -> ST s a
foldM a -> (k, v) -> ST s a
f !a
seed0 Bucket s k v
bucketKey
| Bucket s k v -> Bool
forall a. Bucket s k v -> Bool
keyIsEmpty Bucket s k v
bucketKey = a -> ST s a
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
seed0
| Bool
otherwise = Bucket_ s k v -> ST s a
doMap (Bucket_ s k v -> ST s a) -> Bucket_ s k v -> ST s a
forall a b. (a -> b) -> a -> b
$ Bucket s k v -> Bucket_ s k v
forall a. Bucket s k v -> a
fromKey Bucket s k v
bucketKey
where
doMap :: Bucket_ s k v -> ST s a
doMap (Bucket Int
_ STRef s Int
hwRef MutableArray s k
keys MutableArray s v
values) = do
hw <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
hwRef
go hw seed0 0
where
go :: Int -> a -> Int -> ST s a
go !Int
hw !a
seed !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
hw = a -> ST s a
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
seed
| Bool
otherwise = do
k <- MutableArray s k -> Int -> ST s k
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s k
keys Int
i
v <- readArray values i
seed' <- f seed (k,v)
go hw seed' (i+1)
move :: Int -> Int -> MutableArray s a -> ST s ()
move :: forall s a. Int -> Int -> MutableArray s a -> ST s ()
move Int
i Int
j MutableArray s a
arr | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j = do
String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"move " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" into " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
j
() -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"move " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" into " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
j
MutableArray s a -> Int -> ST s a
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s a
arr Int
i ST s a -> (a -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray s a -> Int -> a -> ST s ()
forall s a. MutableArray s a -> Int -> a -> ST s ()
writeArray MutableArray s a
arr Int
j
{-# INLINE debug #-}
debug :: String -> ST s ()
#ifdef DEBUG
debug s = unsafeIOToST $ do
putStrLn s
hFlush stdout
#else
#ifdef TESTSUITE
debug !s = do
let !_ = length s
return $! ()
#else
debug :: forall s. String -> ST s ()
debug String
_ = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
#endif