module StmHamt.Hamt
(
Hamt,
new,
newIO,
null,
focus,
focusExplicitly,
insert,
insertExplicitly,
lookup,
lookupExplicitly,
reset,
unfoldlM,
listT,
)
where
import StmHamt.Prelude hiding (empty, insert, update, lookup, delete, null)
import StmHamt.Types
import qualified Focus as Focus
import qualified StmHamt.Focuses as Focus
import qualified StmHamt.UnfoldlM as UnfoldlM
import qualified StmHamt.ListT as ListT
import qualified StmHamt.IntOps as IntOps
import qualified PrimitiveExtras.SmallArray as SmallArray
import qualified PrimitiveExtras.By6Bits as By6Bits
new :: STM (Hamt a)
new :: forall a. STM (Hamt a)
new = forall element. TVar (By6Bits (Branch element)) -> Hamt element
Hamt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> STM (TVar a)
newTVar forall e. By6Bits e
By6Bits.empty
newIO :: IO (Hamt a)
newIO :: forall a. IO (Hamt a)
newIO = forall element. TVar (By6Bits (Branch element)) -> Hamt element
Hamt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (TVar a)
newTVarIO forall e. By6Bits e
By6Bits.empty
focus :: (Eq key, Hashable key) => Focus element STM result -> (element -> key) -> key -> Hamt element -> STM result
focus :: forall key element result.
(Eq key, Hashable key) =>
Focus element STM result
-> (element -> key) -> key -> Hamt element -> STM result
focus Focus element STM result
focus element -> key
elementToKey key
key = forall a b. Focus a STM b -> Int -> (a -> Bool) -> Hamt a -> STM b
focusExplicitly Focus element STM result
focus (forall a. Hashable a => a -> Int
hash key
key) (forall a. Eq a => a -> a -> Bool
(==) key
key forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. element -> key
elementToKey)
focusExplicitly :: Focus a STM b -> Int -> (a -> Bool) -> Hamt a -> STM b
focusExplicitly :: forall a b. Focus a STM b -> Int -> (a -> Bool) -> Hamt a -> STM b
focusExplicitly Focus a STM b
focus Int
hash a -> Bool
test Hamt a
hamt =
{-# SCC "focus" #-}
let
Focus STM (b, Change (Hamt a))
_ Hamt a -> STM (b, Change (Hamt a))
reveal = forall a b.
Int -> Int -> (a -> Bool) -> Focus a STM b -> Focus (Hamt a) STM b
Focus.onHamtElement Int
0 Int
hash a -> Bool
test Focus a STM b
focus
in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (Hamt a -> STM (b, Change (Hamt a))
reveal Hamt a
hamt)
insert :: (Eq key, Hashable key) => (element -> key) -> element -> Hamt element -> STM Bool
insert :: forall key element.
(Eq key, Hashable key) =>
(element -> key) -> element -> Hamt element -> STM Bool
insert element -> key
elementToKey element
element = let
!key :: key
key = element -> key
elementToKey element
element
in forall a. Int -> (a -> Bool) -> a -> Hamt a -> STM Bool
insertExplicitly (forall a. Hashable a => a -> Int
hash key
key) (forall a. Eq a => a -> a -> Bool
(==) key
key forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. element -> key
elementToKey) element
element
insertExplicitly :: Int -> (a -> Bool) -> a -> Hamt a -> STM Bool
insertExplicitly :: forall a. Int -> (a -> Bool) -> a -> Hamt a -> STM Bool
insertExplicitly Int
hash a -> Bool
testKey a
element =
{-# SCC "insertExplicitly" #-}
let
loop :: Int -> Hamt a -> STM Bool
loop Int
depth (Hamt TVar (By6Bits (Branch a))
var) = let
!branchIndex :: Int
branchIndex = Int -> Int -> Int
IntOps.indexAtDepth Int
depth Int
hash
in do
By6Bits (Branch a)
branchArray <- forall a. TVar a -> STM a
readTVar TVar (By6Bits (Branch a))
var
case forall e. Int -> By6Bits e -> Maybe e
By6Bits.lookup Int
branchIndex By6Bits (Branch a)
branchArray of
Maybe (Branch a)
Nothing -> do
forall a. TVar a -> a -> STM ()
writeTVar TVar (By6Bits (Branch a))
var forall a b. (a -> b) -> a -> b
$! forall e. Int -> e -> By6Bits e -> By6Bits e
By6Bits.insert Int
branchIndex (forall element. Int -> SmallArray element -> Branch element
LeavesBranch Int
hash (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
element)) By6Bits (Branch a)
branchArray
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Just Branch a
branch -> case Branch a
branch of
LeavesBranch Int
leavesHash SmallArray a
leavesArray -> if Int
leavesHash forall a. Eq a => a -> a -> Bool
== Int
hash
then case forall a. (a -> Bool) -> SmallArray a -> Maybe (Int, a)
SmallArray.findWithIndex a -> Bool
testKey SmallArray a
leavesArray of
Just (Int
leavesIndex, a
_) -> let
!newLeavesArray :: SmallArray a
newLeavesArray = forall a. Int -> a -> SmallArray a -> SmallArray a
SmallArray.set Int
leavesIndex a
element SmallArray a
leavesArray
!newBranch :: Branch a
newBranch = forall element. Int -> SmallArray element -> Branch element
LeavesBranch Int
hash SmallArray a
newLeavesArray
!newBranchArray :: By6Bits (Branch a)
newBranchArray = forall e. Int -> e -> By6Bits e -> By6Bits e
By6Bits.replace Int
branchIndex Branch a
newBranch By6Bits (Branch a)
branchArray
in do
forall a. TVar a -> a -> STM ()
writeTVar TVar (By6Bits (Branch a))
var By6Bits (Branch a)
newBranchArray
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Maybe (Int, a)
Nothing -> let
newLeavesArray :: SmallArray a
newLeavesArray = forall a. a -> SmallArray a -> SmallArray a
SmallArray.cons a
element SmallArray a
leavesArray
in do
forall a. TVar a -> a -> STM ()
writeTVar TVar (By6Bits (Branch a))
var forall a b. (a -> b) -> a -> b
$! forall e. Int -> e -> By6Bits e -> By6Bits e
By6Bits.replace Int
branchIndex (forall element. Int -> SmallArray element -> Branch element
LeavesBranch Int
hash SmallArray a
newLeavesArray) By6Bits (Branch a)
branchArray
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Hamt a
hamt <- forall a. Int -> Int -> Branch a -> Int -> Branch a -> STM (Hamt a)
pair (Int -> Int
IntOps.nextDepth Int
depth) Int
hash (forall element. Int -> SmallArray element -> Branch element
LeavesBranch Int
hash (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
element)) Int
leavesHash (forall element. Int -> SmallArray element -> Branch element
LeavesBranch Int
leavesHash SmallArray a
leavesArray)
forall a. TVar a -> a -> STM ()
writeTVar TVar (By6Bits (Branch a))
var forall a b. (a -> b) -> a -> b
$! forall e. Int -> e -> By6Bits e -> By6Bits e
By6Bits.replace Int
branchIndex (forall element. Hamt element -> Branch element
BranchesBranch Hamt a
hamt) By6Bits (Branch a)
branchArray
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
BranchesBranch Hamt a
hamt -> Int -> Hamt a -> STM Bool
loop (Int -> Int
IntOps.nextDepth Int
depth) Hamt a
hamt
in Int -> Hamt a -> STM Bool
loop Int
0
pair :: Int -> Int -> Branch a -> Int -> Branch a -> STM (Hamt a)
pair :: forall a. Int -> Int -> Branch a -> Int -> Branch a -> STM (Hamt a)
pair Int
depth Int
hash1 Branch a
branch1 Int
hash2 Branch a
branch2 =
{-# SCC "pair" #-}
let
index1 :: Int
index1 = Int -> Int -> Int
IntOps.indexAtDepth Int
depth Int
hash1
index2 :: Int
index2 = Int -> Int -> Int
IntOps.indexAtDepth Int
depth Int
hash2
in if Int
index1 forall a. Eq a => a -> a -> Bool
== Int
index2
then do
Hamt a
deeperHamt <- forall a. Int -> Int -> Branch a -> Int -> Branch a -> STM (Hamt a)
pair (Int -> Int
IntOps.nextDepth Int
depth) Int
hash1 Branch a
branch1 Int
hash2 Branch a
branch2
TVar (By6Bits (Branch a))
var <- forall a. a -> STM (TVar a)
newTVar (forall e. Int -> e -> By6Bits e
By6Bits.singleton Int
index1 (forall element. Hamt element -> Branch element
BranchesBranch Hamt a
deeperHamt))
forall (m :: * -> *) a. Monad m => a -> m a
return (forall element. TVar (By6Bits (Branch element)) -> Hamt element
Hamt TVar (By6Bits (Branch a))
var)
else forall element. TVar (By6Bits (Branch element)) -> Hamt element
Hamt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> STM (TVar a)
newTVar (forall e. Int -> e -> Int -> e -> By6Bits e
By6Bits.pair Int
index1 Branch a
branch1 Int
index2 Branch a
branch2)
lookup :: (Eq key, Hashable key) => (element -> key) -> key -> Hamt element -> STM (Maybe element)
lookup :: forall key element.
(Eq key, Hashable key) =>
(element -> key) -> key -> Hamt element -> STM (Maybe element)
lookup element -> key
elementToKey key
key = forall a. Int -> (a -> Bool) -> Hamt a -> STM (Maybe a)
lookupExplicitly (forall a. Hashable a => a -> Int
hash key
key) (forall a. Eq a => a -> a -> Bool
(==) key
key forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. element -> key
elementToKey)
lookupExplicitly :: Int -> (a -> Bool) -> Hamt a -> STM (Maybe a)
lookupExplicitly :: forall a. Int -> (a -> Bool) -> Hamt a -> STM (Maybe a)
lookupExplicitly Int
hash a -> Bool
test =
{-# SCC "lookupExplicitly" #-}
let
loop :: Int -> Hamt a -> STM (Maybe a)
loop Int
depth (Hamt TVar (By6Bits (Branch a))
var) = let
!index :: Int
index = Int -> Int -> Int
IntOps.indexAtDepth Int
depth Int
hash
in do
By6Bits (Branch a)
branchArray <- forall a. TVar a -> STM a
readTVar TVar (By6Bits (Branch a))
var
case forall e. Int -> By6Bits e -> Maybe e
By6Bits.lookup Int
index By6Bits (Branch a)
branchArray of
Just Branch a
branch -> case Branch a
branch of
LeavesBranch Int
leavesHash SmallArray a
leavesArray -> if Int
leavesHash forall a. Eq a => a -> a -> Bool
== Int
hash
then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. (a -> Bool) -> SmallArray a -> Maybe a
SmallArray.find a -> Bool
test SmallArray a
leavesArray)
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
BranchesBranch Hamt a
hamt -> Int -> Hamt a -> STM (Maybe a)
loop (Int -> Int
IntOps.nextDepth Int
depth) Hamt a
hamt
Maybe (Branch a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
in Int -> Hamt a -> STM (Maybe a)
loop Int
0
reset :: Hamt a -> STM ()
reset :: forall a. Hamt a -> STM ()
reset (Hamt TVar (By6Bits (Branch a))
branchSsaVar) = forall a. TVar a -> a -> STM ()
writeTVar TVar (By6Bits (Branch a))
branchSsaVar forall e. By6Bits e
By6Bits.empty
unfoldlM :: Hamt a -> UnfoldlM STM a
unfoldlM :: forall a. Hamt a -> UnfoldlM STM a
unfoldlM = forall a. Hamt a -> UnfoldlM STM a
UnfoldlM.hamtElements
listT :: Hamt a -> ListT STM a
listT :: forall a. Hamt a -> ListT STM a
listT = forall a. Hamt a -> ListT STM a
ListT.hamtElements
null :: Hamt a -> STM Bool
null :: forall a. Hamt a -> STM Bool
null (Hamt TVar (By6Bits (Branch a))
branchSsaVar) = do
By6Bits (Branch a)
branchSsa <- forall a. TVar a -> STM a
readTVar TVar (By6Bits (Branch a))
branchSsaVar
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. By6Bits a -> Bool
By6Bits.null By6Bits (Branch a)
branchSsa)
introspect :: Show a => Hamt a -> STM String
introspect :: forall a. Show a => Hamt a -> STM String
introspect (Hamt TVar (By6Bits (Branch a))
branchArrayVar) = do
By6Bits (Branch a)
branchArray <- forall a. TVar a -> STM a
readTVar TVar (By6Bits (Branch a))
branchArrayVar
[(Int, String)]
indexedList <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {a}. Show a => Branch a -> STM String
introspectBranch) (forall e. By6Bits e -> [(Int, e)]
By6Bits.toIndexedList By6Bits (Branch a)
branchArray)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
String
"[" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Int
i, String
branchString) -> String
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i forall a. Semigroup a => a -> a -> a
<> String
", " forall a. Semigroup a => a -> a -> a
<> String
branchString forall a. Semigroup a => a -> a -> a
<> String
")") [(Int, String)]
indexedList) forall a. Semigroup a => a -> a -> a
<> String
"]"
where
introspectBranch :: Branch a -> STM String
introspectBranch = \ case
BranchesBranch Hamt a
deeperHamt -> do
String
deeperString <- forall a. Show a => Hamt a -> STM String
introspect Hamt a
deeperHamt
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ShowS
showString String
"BranchesBranch " String
deeperString)
LeavesBranch Int
hash SmallArray a
array -> forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ShowS
showString String
"LeavesBranch " (forall a. Show a => a -> ShowS
shows Int
hash (Char -> ShowS
showChar Char
' ' (forall a. Show a => a -> String
show (forall a. SmallArray a -> [a]
SmallArray.toList SmallArray a
array)))))