{-|
Utility focuses.
-}
module StmHamt.Focuses where

import StmHamt.Prelude
import StmHamt.Types
import Focus
import qualified StmHamt.IntOps as IntOps
import qualified StmHamt.Constructors.Branch as BranchConstructors
import qualified PrimitiveExtras.By6Bits as By6Bits
import qualified PrimitiveExtras.SmallArray as SmallArray


onBranchElement :: forall a b. Int -> Int -> (a -> Bool) -> Focus a STM b -> Focus (Branch a) STM b
onBranchElement :: 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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SmallArray a -> Branch a)
-> Change (SmallArray a) -> Change (Branch a)
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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SmallArray a -> Branch a)
-> Change (SmallArray a) -> Change (Branch a)
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 (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 (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)
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 (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 (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 (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 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 :: 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 (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 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 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 (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)
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 (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