-- |
-- Utility focuses.
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