module StmHamt.Focuses where
import Focus
import qualified PrimitiveExtras.By6Bits as By6Bits
import qualified PrimitiveExtras.SmallArray as SmallArray
import qualified StmHamt.Constructors.Branch as BranchConstructors
import qualified StmHamt.IntOps as IntOps
import StmHamt.Prelude
import StmHamt.Types
onBranchElement :: forall a b. Int -> Int -> (a -> Bool) -> Focus a STM b -> Focus (Branch a) STM b
onBranchElement :: forall a b.
Int
-> Int -> (a -> Bool) -> Focus a STM b -> Focus (Branch a) STM b
onBranchElement Int
depth Int
hash a -> Bool
testElement elementFocus :: Focus a STM b
elementFocus@(Focus STM (b, Change a)
concealElement a -> STM (b, Change a)
revealElement) =
let ~(Focus STM (b, Change (SmallArray a))
concealLeaves SmallArray a -> STM (b, Change (SmallArray a))
revealLeaves) = (a -> Bool)
-> (a -> Bool) -> Focus a STM b -> Focus (SmallArray a) STM b
forall (m :: * -> *) a b.
Monad m =>
(a -> Bool)
-> (a -> Bool) -> Focus a m b -> Focus (SmallArray a) m b
SmallArray.onFoundElementFocus a -> Bool
testElement (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
False) Focus a STM b
elementFocus
branchesVarFocus :: Int -> Focus (TVar (By6Bits (Branch a))) STM b
branchesVarFocus :: Int -> Focus (TVar (By6Bits (Branch a))) STM b
branchesVarFocus Int
depth =
let !branchIndex :: Int
branchIndex = Int -> Int -> Int
IntOps.indexAtDepth Int
depth Int
hash
in Focus (By6Bits (Branch a)) STM b
-> Focus (TVar (By6Bits (Branch a))) STM b
forall a b. Focus a STM b -> Focus (TVar a) STM b
onTVarValue (Int -> Focus (Branch a) STM b -> Focus (By6Bits (Branch a)) STM b
forall (m :: * -> *) a b.
Monad m =>
Int -> Focus a m b -> Focus (By6Bits a) m b
By6Bits.onElementAtFocus Int
branchIndex (Int -> Focus (Branch a) STM b
branchFocus (Int
depth)))
branchFocus :: Int -> Focus (Branch a) STM b
branchFocus :: Int -> Focus (Branch a) STM b
branchFocus Int
depth = STM (b, Change (Branch a))
-> (Branch a -> STM (b, Change (Branch a)))
-> Focus (Branch a) STM b
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus STM (b, Change (Branch a))
concealBranch Branch a -> STM (b, Change (Branch a))
revealBranch
where
concealBranch :: STM (b, Change (Branch a))
concealBranch = ((b, Change (SmallArray a)) -> (b, Change (Branch a)))
-> STM (b, Change (SmallArray a)) -> STM (b, Change (Branch a))
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change (SmallArray a) -> Change (Branch a))
-> (b, Change (SmallArray a)) -> (b, Change (Branch a))
forall a b. (a -> b) -> (b, a) -> (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SmallArray a -> Branch a)
-> Change (SmallArray a) -> Change (Branch a)
forall a b. (a -> b) -> Change a -> Change b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> SmallArray a -> Branch a
forall element. Int -> SmallArray element -> Branch element
LeavesBranch Int
hash))) STM (b, Change (SmallArray a))
concealLeaves
revealBranch :: Branch a -> STM (b, Change (Branch a))
revealBranch = \case
LeavesBranch Int
leavesHash SmallArray a
leavesArray ->
case Int
leavesHash Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
hash of
Bool
True -> ((b, Change (SmallArray a)) -> (b, Change (Branch a)))
-> STM (b, Change (SmallArray a)) -> STM (b, Change (Branch a))
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change (SmallArray a) -> Change (Branch a))
-> (b, Change (SmallArray a)) -> (b, Change (Branch a))
forall a b. (a -> b) -> (b, a) -> (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SmallArray a -> Branch a)
-> Change (SmallArray a) -> Change (Branch a)
forall a b. (a -> b) -> Change a -> Change b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> SmallArray a -> Branch a
forall element. Int -> SmallArray element -> Branch element
LeavesBranch Int
leavesHash))) (SmallArray a -> STM (b, Change (SmallArray a))
revealLeaves SmallArray a
leavesArray)
Bool
False ->
let interpretChange :: Change a -> STM (Change (Branch a))
interpretChange = \case
Set !a
newElement -> Branch a -> Change (Branch a)
forall a. a -> Change a
Set (Branch a -> Change (Branch a))
-> STM (Branch a) -> STM (Change (Branch a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Branch a -> Int -> Branch a -> STM (Branch a)
forall a.
Int -> Int -> Branch a -> Int -> Branch a -> STM (Branch a)
BranchConstructors.pair (Int -> Int
IntOps.nextDepth Int
depth) Int
hash (Int -> a -> Branch a
forall a. Int -> a -> Branch a
BranchConstructors.singleton Int
hash a
newElement) Int
leavesHash (Int -> SmallArray a -> Branch a
forall element. Int -> SmallArray element -> Branch element
LeavesBranch Int
leavesHash SmallArray a
leavesArray)
Change a
_ -> Change (Branch a) -> STM (Change (Branch a))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Change (Branch a)
forall a. Change a
Leave
in STM (b, Change a)
concealElement STM (b, Change a)
-> ((b, Change a) -> STM (b, Change (Branch a)))
-> STM (b, Change (Branch a))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Change a -> STM (Change (Branch a)))
-> (b, Change a) -> STM (b, Change (Branch a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (b, a) -> f (b, b)
traverse Change a -> STM (Change (Branch a))
interpretChange
BranchesBranch (Hamt TVar (By6Bits (Branch a))
var) ->
let Focus STM (b, Change (TVar (By6Bits (Branch a))))
_ TVar (By6Bits (Branch a))
-> STM (b, Change (TVar (By6Bits (Branch a))))
revealBranchesVar = Int -> Focus (TVar (By6Bits (Branch a))) STM b
branchesVarFocus (Int -> Int
IntOps.nextDepth Int
depth)
in ((b, Change (TVar (By6Bits (Branch a)))) -> (b, Change (Branch a)))
-> STM (b, Change (TVar (By6Bits (Branch a))))
-> STM (b, Change (Branch a))
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change (TVar (By6Bits (Branch a))) -> Change (Branch a))
-> (b, Change (TVar (By6Bits (Branch a))))
-> (b, Change (Branch a))
forall a b. (a -> b) -> (b, a) -> (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TVar (By6Bits (Branch a)) -> Branch a)
-> Change (TVar (By6Bits (Branch a))) -> Change (Branch a)
forall a b. (a -> b) -> Change a -> Change b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Hamt a -> Branch a
forall element. Hamt element -> Branch element
BranchesBranch (Hamt a -> Branch a)
-> (TVar (By6Bits (Branch a)) -> Hamt a)
-> TVar (By6Bits (Branch a))
-> Branch a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TVar (By6Bits (Branch a)) -> Hamt a
forall element. TVar (By6Bits (Branch element)) -> Hamt element
Hamt))) (TVar (By6Bits (Branch a))
-> STM (b, Change (TVar (By6Bits (Branch a))))
revealBranchesVar TVar (By6Bits (Branch a))
var)
in Int -> Focus (Branch a) STM b
branchFocus Int
depth
onHamtElement :: Int -> Int -> (a -> Bool) -> Focus a STM b -> Focus (Hamt a) STM b
onHamtElement :: forall a b.
Int -> Int -> (a -> Bool) -> Focus a STM b -> Focus (Hamt a) STM b
onHamtElement Int
depth Int
hash a -> Bool
test Focus a STM b
focus =
let branchIndex :: Int
branchIndex = Int -> Int -> Int
IntOps.indexAtDepth Int
depth Int
hash
Focus STM (b, Change (By6Bits (Branch a)))
concealBranches By6Bits (Branch a) -> STM (b, Change (By6Bits (Branch a)))
revealBranches =
Int -> Focus (Branch a) STM b -> Focus (By6Bits (Branch a)) STM b
forall (m :: * -> *) a b.
Monad m =>
Int -> Focus a m b -> Focus (By6Bits a) m b
By6Bits.onElementAtFocus Int
branchIndex
(Focus (Branch a) STM b -> Focus (By6Bits (Branch a)) STM b)
-> Focus (Branch a) STM b -> Focus (By6Bits (Branch a)) STM b
forall a b. (a -> b) -> a -> b
$ Int
-> Int -> (a -> Bool) -> Focus a STM b -> Focus (Branch a) STM b
forall a b.
Int
-> Int -> (a -> Bool) -> Focus a STM b -> Focus (Branch a) STM b
onBranchElement Int
depth Int
hash a -> Bool
test Focus a STM b
focus
concealHamt :: STM (b, Change (Hamt a))
concealHamt =
let hamtChangeStm :: Change (By6Bits (Branch element)) -> STM (Change (Hamt element))
hamtChangeStm = \case
Change (By6Bits (Branch element))
Leave -> Change (Hamt element) -> STM (Change (Hamt element))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Change (Hamt element)
forall a. Change a
Leave
Set !By6Bits (Branch element)
branches -> Hamt element -> Change (Hamt element)
forall a. a -> Change a
Set (Hamt element -> Change (Hamt element))
-> (TVar (By6Bits (Branch element)) -> Hamt element)
-> TVar (By6Bits (Branch element))
-> Change (Hamt element)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TVar (By6Bits (Branch element)) -> Hamt element
forall element. TVar (By6Bits (Branch element)) -> Hamt element
Hamt (TVar (By6Bits (Branch element)) -> Change (Hamt element))
-> STM (TVar (By6Bits (Branch element)))
-> STM (Change (Hamt element))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> By6Bits (Branch element) -> STM (TVar (By6Bits (Branch element)))
forall a. a -> STM (TVar a)
newTVar By6Bits (Branch element)
branches
Change (By6Bits (Branch element))
Remove -> Hamt element -> Change (Hamt element)
forall a. a -> Change a
Set (Hamt element -> Change (Hamt element))
-> (TVar (By6Bits (Branch element)) -> Hamt element)
-> TVar (By6Bits (Branch element))
-> Change (Hamt element)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TVar (By6Bits (Branch element)) -> Hamt element
forall element. TVar (By6Bits (Branch element)) -> Hamt element
Hamt (TVar (By6Bits (Branch element)) -> Change (Hamt element))
-> STM (TVar (By6Bits (Branch element)))
-> STM (Change (Hamt element))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> By6Bits (Branch element) -> STM (TVar (By6Bits (Branch element)))
forall a. a -> STM (TVar a)
newTVar By6Bits (Branch element)
forall e. By6Bits e
By6Bits.empty
in STM (b, Change (By6Bits (Branch a)))
concealBranches STM (b, Change (By6Bits (Branch a)))
-> ((b, Change (By6Bits (Branch a))) -> STM (b, Change (Hamt a)))
-> STM (b, Change (Hamt a))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Change (By6Bits (Branch a)) -> STM (Change (Hamt a)))
-> (b, Change (By6Bits (Branch a))) -> STM (b, Change (Hamt a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (b, a) -> f (b, b)
traverse Change (By6Bits (Branch a)) -> STM (Change (Hamt a))
forall {element}.
Change (By6Bits (Branch element)) -> STM (Change (Hamt element))
hamtChangeStm
revealHamt :: Hamt a -> STM (b, Change (Hamt a))
revealHamt (Hamt TVar (By6Bits (Branch a))
branchesVar) = do
By6Bits (Branch a)
branches <- TVar (By6Bits (Branch a)) -> STM (By6Bits (Branch a))
forall a. TVar a -> STM a
readTVar TVar (By6Bits (Branch a))
branchesVar
(b
result, Change (By6Bits (Branch a))
branchesChange) <- By6Bits (Branch a) -> STM (b, Change (By6Bits (Branch a)))
revealBranches By6Bits (Branch a)
branches
case Change (By6Bits (Branch a))
branchesChange of
Change (By6Bits (Branch a))
Leave -> (b, Change (Hamt a)) -> STM (b, Change (Hamt a))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
result, Change (Hamt a)
forall a. Change a
Leave)
Set !By6Bits (Branch a)
newBranches -> TVar (By6Bits (Branch a)) -> By6Bits (Branch a) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (By6Bits (Branch a))
branchesVar By6Bits (Branch a)
newBranches STM () -> (b, Change (Hamt a)) -> STM (b, Change (Hamt a))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (b
result, Change (Hamt a)
forall a. Change a
Leave)
Change (By6Bits (Branch a))
Remove -> TVar (By6Bits (Branch a)) -> By6Bits (Branch a) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (By6Bits (Branch a))
branchesVar By6Bits (Branch a)
forall e. By6Bits e
By6Bits.empty STM () -> (b, Change (Hamt a)) -> STM (b, Change (Hamt a))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (b
result, Change (Hamt a)
forall a. Change a
Leave)
in STM (b, Change (Hamt a))
-> (Hamt a -> STM (b, Change (Hamt a))) -> Focus (Hamt a) STM b
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus STM (b, Change (Hamt a))
concealHamt Hamt a -> STM (b, Change (Hamt a))
revealHamt