module Database.LSMTree.Internal.MergingTree.Lookup (
    LookupTree (..)
  , mkLookupNode
  , buildLookupTree
  , releaseLookupTree
  , foldLookupTree
  ) where

import           Control.ActionRegistry
import           Control.Concurrent.Class.MonadMVar.Strict
import           Control.Exception (assert)
import           Control.Monad.Class.MonadAsync (Async, MonadAsync)
import qualified Control.Monad.Class.MonadAsync as Async
import           Control.Monad.Class.MonadThrow (MonadMask)
import           Control.Monad.Primitive
import           Control.RefCount
import           Data.Foldable (traverse_)
import qualified Data.Vector as V
import qualified Database.LSMTree.Internal.Entry as Entry
import           Database.LSMTree.Internal.Lookup (LookupAcc,
                     ResolveSerialisedValue)
import qualified Database.LSMTree.Internal.MergingRun as MR
import qualified Database.LSMTree.Internal.MergingTree as MT
import           Database.LSMTree.Internal.Run (Run)

-- | A simplified representation of the shape of a 'MT.MergingTree'.
data LookupTree a =
    LookupBatch !a
    -- | Use 'mkLookupNode' to construct this.
  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a))  -- ^ length 2 or more
  deriving stock ((forall m. Monoid m => LookupTree m -> m)
-> (forall m a. Monoid m => (a -> m) -> LookupTree a -> m)
-> (forall m a. Monoid m => (a -> m) -> LookupTree a -> m)
-> (forall a b. (a -> b -> b) -> b -> LookupTree a -> b)
-> (forall a b. (a -> b -> b) -> b -> LookupTree a -> b)
-> (forall b a. (b -> a -> b) -> b -> LookupTree a -> b)
-> (forall b a. (b -> a -> b) -> b -> LookupTree a -> b)
-> (forall a. (a -> a -> a) -> LookupTree a -> a)
-> (forall a. (a -> a -> a) -> LookupTree a -> a)
-> (forall a. LookupTree a -> [a])
-> (forall a. LookupTree a -> Bool)
-> (forall a. LookupTree a -> Int)
-> (forall a. Eq a => a -> LookupTree a -> Bool)
-> (forall a. Ord a => LookupTree a -> a)
-> (forall a. Ord a => LookupTree a -> a)
-> (forall a. Num a => LookupTree a -> a)
-> (forall a. Num a => LookupTree a -> a)
-> Foldable LookupTree
forall a. Eq a => a -> LookupTree a -> Bool
forall a. Num a => LookupTree a -> a
forall a. Ord a => LookupTree a -> a
forall m. Monoid m => LookupTree m -> m
forall a. LookupTree a -> Bool
forall a. LookupTree a -> Int
forall a. LookupTree a -> [a]
forall a. (a -> a -> a) -> LookupTree a -> a
forall m a. Monoid m => (a -> m) -> LookupTree a -> m
forall b a. (b -> a -> b) -> b -> LookupTree a -> b
forall a b. (a -> b -> b) -> b -> LookupTree a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => LookupTree m -> m
fold :: forall m. Monoid m => LookupTree m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> LookupTree a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> LookupTree a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> LookupTree a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> LookupTree a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> LookupTree a -> b
foldr :: forall a b. (a -> b -> b) -> b -> LookupTree a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> LookupTree a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> LookupTree a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> LookupTree a -> b
foldl :: forall b a. (b -> a -> b) -> b -> LookupTree a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> LookupTree a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> LookupTree a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> LookupTree a -> a
foldr1 :: forall a. (a -> a -> a) -> LookupTree a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> LookupTree a -> a
foldl1 :: forall a. (a -> a -> a) -> LookupTree a -> a
$ctoList :: forall a. LookupTree a -> [a]
toList :: forall a. LookupTree a -> [a]
$cnull :: forall a. LookupTree a -> Bool
null :: forall a. LookupTree a -> Bool
$clength :: forall a. LookupTree a -> Int
length :: forall a. LookupTree a -> Int
$celem :: forall a. Eq a => a -> LookupTree a -> Bool
elem :: forall a. Eq a => a -> LookupTree a -> Bool
$cmaximum :: forall a. Ord a => LookupTree a -> a
maximum :: forall a. Ord a => LookupTree a -> a
$cminimum :: forall a. Ord a => LookupTree a -> a
minimum :: forall a. Ord a => LookupTree a -> a
$csum :: forall a. Num a => LookupTree a -> a
sum :: forall a. Num a => LookupTree a -> a
$cproduct :: forall a. Num a => LookupTree a -> a
product :: forall a. Num a => LookupTree a -> a
Foldable, (forall a b. (a -> b) -> LookupTree a -> LookupTree b)
-> (forall a b. a -> LookupTree b -> LookupTree a)
-> Functor LookupTree
forall a b. a -> LookupTree b -> LookupTree a
forall a b. (a -> b) -> LookupTree a -> LookupTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LookupTree a -> LookupTree b
fmap :: forall a b. (a -> b) -> LookupTree a -> LookupTree b
$c<$ :: forall a b. a -> LookupTree b -> LookupTree a
<$ :: forall a b. a -> LookupTree b -> LookupTree a
Functor, Functor LookupTree
Foldable LookupTree
(Functor LookupTree, Foldable LookupTree) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> LookupTree a -> f (LookupTree b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    LookupTree (f a) -> f (LookupTree a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> LookupTree a -> m (LookupTree b))
-> (forall (m :: * -> *) a.
    Monad m =>
    LookupTree (m a) -> m (LookupTree a))
-> Traversable LookupTree
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
LookupTree (m a) -> m (LookupTree a)
forall (f :: * -> *) a.
Applicative f =>
LookupTree (f a) -> f (LookupTree a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LookupTree a -> m (LookupTree b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LookupTree a -> f (LookupTree b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LookupTree a -> f (LookupTree b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LookupTree a -> f (LookupTree b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
LookupTree (f a) -> f (LookupTree a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
LookupTree (f a) -> f (LookupTree a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LookupTree a -> m (LookupTree b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LookupTree a -> m (LookupTree b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
LookupTree (m a) -> m (LookupTree a)
sequence :: forall (m :: * -> *) a.
Monad m =>
LookupTree (m a) -> m (LookupTree a)
Traversable)

-- | Asserts that the vector is non-empty. Collapses singleton nodes.
mkLookupNode :: MR.TreeMergeType -> V.Vector (LookupTree a) -> LookupTree a
mkLookupNode :: forall a. TreeMergeType -> Vector (LookupTree a) -> LookupTree a
mkLookupNode TreeMergeType
ty Vector (LookupTree a)
ts
  | Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (Vector (LookupTree a) -> Bool
forall a. Vector a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector (LookupTree a)
ts)) (Vector (LookupTree a) -> Int
forall a. Vector a -> Int
V.length Vector (LookupTree a)
ts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) = Vector (LookupTree a) -> LookupTree a
forall a. Vector a -> a
V.head Vector (LookupTree a)
ts
  | Bool
otherwise                                 = TreeMergeType -> Vector (LookupTree a) -> LookupTree a
forall a. TreeMergeType -> Vector (LookupTree a) -> LookupTree a
LookupNode TreeMergeType
ty Vector (LookupTree a)
ts

-- | Combine a tree of accs into a single one, using the 'MR.TreeMergeType' of
-- each node.
{-# SPECIALISE foldLookupTree ::
     ResolveSerialisedValue
  -> LookupTree (Async IO (LookupAcc IO h))
  -> IO (LookupAcc IO h) #-}
foldLookupTree ::
     MonadAsync m
  => ResolveSerialisedValue
  -> LookupTree (Async m (LookupAcc m h))
  -> m (LookupAcc m h)
foldLookupTree :: forall (m :: * -> *) h.
MonadAsync m =>
ResolveSerialisedValue
-> LookupTree (Async m (LookupAcc m h)) -> m (LookupAcc m h)
foldLookupTree ResolveSerialisedValue
resolve = \case
    LookupBatch Async m (LookupAcc m h)
batch ->
      Async m (LookupAcc m h) -> m (LookupAcc m h)
forall a. Async m a -> m a
forall (m :: * -> *) a. MonadAsync m => Async m a -> m a
Async.wait Async m (LookupAcc m h)
batch
    LookupNode TreeMergeType
mt Vector (LookupTree (Async m (LookupAcc m h)))
children ->
      ResolveSerialisedValue
-> TreeMergeType -> Vector (LookupAcc m h) -> LookupAcc m h
forall (m :: * -> *) h.
ResolveSerialisedValue
-> TreeMergeType -> Vector (LookupAcc m h) -> LookupAcc m h
mergeLookupAcc ResolveSerialisedValue
resolve TreeMergeType
mt (Vector (LookupAcc m h) -> LookupAcc m h)
-> m (Vector (LookupAcc m h)) -> m (LookupAcc m h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LookupTree (Async m (LookupAcc m h)) -> m (LookupAcc m h))
-> Vector (LookupTree (Async m (LookupAcc m h)))
-> m (Vector (LookupAcc m h))
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) -> Vector a -> f (Vector b)
traverse (ResolveSerialisedValue
-> LookupTree (Async m (LookupAcc m h)) -> m (LookupAcc m h)
forall (m :: * -> *) h.
MonadAsync m =>
ResolveSerialisedValue
-> LookupTree (Async m (LookupAcc m h)) -> m (LookupAcc m h)
foldLookupTree ResolveSerialisedValue
resolve) Vector (LookupTree (Async m (LookupAcc m h)))
children

-- | Requires multiple inputs, all of the same length.
--
-- TODO: do more efficiently on mutable vectors?
mergeLookupAcc ::
     ResolveSerialisedValue
  -> MR.TreeMergeType
  -> V.Vector (LookupAcc m h)
  -> LookupAcc m h
mergeLookupAcc :: forall (m :: * -> *) h.
ResolveSerialisedValue
-> TreeMergeType -> Vector (LookupAcc m h) -> LookupAcc m h
mergeLookupAcc ResolveSerialisedValue
resolve TreeMergeType
mt Vector (LookupAcc m h)
accs =
    Bool -> LookupAcc m h -> LookupAcc m h
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Vector (LookupAcc m h) -> Int
forall a. Vector a -> Int
V.length Vector (LookupAcc m h)
accs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (LookupAcc m h -> LookupAcc m h) -> LookupAcc m h -> LookupAcc m h
forall a b. (a -> b) -> a -> b
$
    Bool -> LookupAcc m h -> LookupAcc m h
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((LookupAcc m h -> Bool) -> Vector (LookupAcc m h) -> Bool
forall a. (a -> Bool) -> Vector a -> Bool
V.all ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== LookupAcc m h -> Int
forall a. Vector a -> Int
V.length (Vector (LookupAcc m h) -> LookupAcc m h
forall a. Vector a -> a
V.head Vector (LookupAcc m h)
accs)) (Int -> Bool) -> (LookupAcc m h -> Int) -> LookupAcc m h -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LookupAcc m h -> Int
forall a. Vector a -> Int
V.length) Vector (LookupAcc m h)
accs) (LookupAcc m h -> LookupAcc m h) -> LookupAcc m h -> LookupAcc m h
forall a b. (a -> b) -> a -> b
$
      (LookupAcc m h -> LookupAcc m h -> LookupAcc m h)
-> Vector (LookupAcc m h) -> LookupAcc m h
forall a. (a -> a -> a) -> Vector a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 ((Maybe (Entry SerialisedValue (WeakBlobRef m h))
 -> Maybe (Entry SerialisedValue (WeakBlobRef m h))
 -> Maybe (Entry SerialisedValue (WeakBlobRef m h)))
-> LookupAcc m h -> LookupAcc m h -> LookupAcc m h
forall a b c. (a -> b -> c) -> Vector a -> Vector b -> Vector c
V.zipWith Maybe (Entry SerialisedValue (WeakBlobRef m h))
-> Maybe (Entry SerialisedValue (WeakBlobRef m h))
-> Maybe (Entry SerialisedValue (WeakBlobRef m h))
updateEntry) Vector (LookupAcc m h)
accs
  where
    updateEntry :: Maybe (Entry SerialisedValue (WeakBlobRef m h))
-> Maybe (Entry SerialisedValue (WeakBlobRef m h))
-> Maybe (Entry SerialisedValue (WeakBlobRef m h))
updateEntry Maybe (Entry SerialisedValue (WeakBlobRef m h))
Nothing    Maybe (Entry SerialisedValue (WeakBlobRef m h))
old        = Maybe (Entry SerialisedValue (WeakBlobRef m h))
old
    updateEntry Maybe (Entry SerialisedValue (WeakBlobRef m h))
new        Maybe (Entry SerialisedValue (WeakBlobRef m h))
Nothing    = Maybe (Entry SerialisedValue (WeakBlobRef m h))
new
    updateEntry (Just Entry SerialisedValue (WeakBlobRef m h)
new) (Just Entry SerialisedValue (WeakBlobRef m h)
old) = Entry SerialisedValue (WeakBlobRef m h)
-> Maybe (Entry SerialisedValue (WeakBlobRef m h))
forall a. a -> Maybe a
Just (Entry SerialisedValue (WeakBlobRef m h)
-> Entry SerialisedValue (WeakBlobRef m h)
-> Entry SerialisedValue (WeakBlobRef m h)
combine Entry SerialisedValue (WeakBlobRef m h)
new Entry SerialisedValue (WeakBlobRef m h)
old)

    combine :: Entry SerialisedValue (WeakBlobRef m h)
-> Entry SerialisedValue (WeakBlobRef m h)
-> Entry SerialisedValue (WeakBlobRef m h)
combine = case TreeMergeType
mt of
        TreeMergeType
MR.MergeLevel -> ResolveSerialisedValue
-> Entry SerialisedValue (WeakBlobRef m h)
-> Entry SerialisedValue (WeakBlobRef m h)
-> Entry SerialisedValue (WeakBlobRef m h)
forall v b. (v -> v -> v) -> Entry v b -> Entry v b -> Entry v b
Entry.combine ResolveSerialisedValue
resolve
        TreeMergeType
MR.MergeUnion -> ResolveSerialisedValue
-> Entry SerialisedValue (WeakBlobRef m h)
-> Entry SerialisedValue (WeakBlobRef m h)
-> Entry SerialisedValue (WeakBlobRef m h)
forall v b. (v -> v -> v) -> Entry v b -> Entry v b -> Entry v b
Entry.combineUnion ResolveSerialisedValue
resolve

-- | Create a 'LookupTree' of batches of runs, e.g. to do lookups on. The
-- entries within each batch are to be combined using 'MR.MergeLevel'.
--
-- Assumes that the merging tree is not 'MT.isStructurallyEmpty'.
--
-- This function duplicates the references to all the tree's runs.
-- These references later need to be released using 'releaseLookupTree'.
{-# SPECIALISE buildLookupTree ::
     ActionRegistry IO
  -> Ref (MT.MergingTree IO h)
  -> IO (LookupTree (V.Vector (Ref (Run IO h)))) #-}
buildLookupTree ::
     (PrimMonad m, MonadMVar m, MonadMask m)
  => ActionRegistry m
  -> Ref (MT.MergingTree m h)
  -> m (LookupTree (V.Vector (Ref (Run m h))))
buildLookupTree :: forall (m :: * -> *) h.
(PrimMonad m, MonadMVar m, MonadMask m) =>
ActionRegistry m
-> Ref (MergingTree m h) -> m (LookupTree (Vector (Ref (Run m h))))
buildLookupTree ActionRegistry m
reg (DeRef MergingTree m h
mt) =
    -- we make sure the state is not updated while we look at it, so no runs get
    -- dropped before we duplicated the reference.
    StrictMVar m (MergingTreeState m h)
-> (MergingTreeState m h
    -> m (LookupTree (Vector (Ref (Run m h)))))
-> m (LookupTree (Vector (Ref (Run m h))))
forall (m :: * -> *) a b.
MonadMVar m =>
StrictMVar m a -> (a -> m b) -> m b
withMVar (MergingTree m h -> StrictMVar m (MergingTreeState m h)
forall (m :: * -> *) h.
MergingTree m h -> StrictMVar m (MergingTreeState m h)
MT.mergeState MergingTree m h
mt) ((MergingTreeState m h -> m (LookupTree (Vector (Ref (Run m h)))))
 -> m (LookupTree (Vector (Ref (Run m h)))))
-> (MergingTreeState m h
    -> m (LookupTree (Vector (Ref (Run m h)))))
-> m (LookupTree (Vector (Ref (Run m h))))
forall a b. (a -> b) -> a -> b
$ \case
      MT.CompletedTreeMerge Ref (Run m h)
r ->
        Vector (Ref (Run m h)) -> LookupTree (Vector (Ref (Run m h)))
forall a. a -> LookupTree a
LookupBatch (Vector (Ref (Run m h)) -> LookupTree (Vector (Ref (Run m h))))
-> (Ref (Run m h) -> Vector (Ref (Run m h)))
-> Ref (Run m h)
-> LookupTree (Vector (Ref (Run m h)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref (Run m h) -> Vector (Ref (Run m h))
forall a. a -> Vector a
V.singleton (Ref (Run m h) -> LookupTree (Vector (Ref (Run m h))))
-> m (Ref (Run m h)) -> m (LookupTree (Vector (Ref (Run m h))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ref (Run m h) -> m (Ref (Run m h))
dupRun Ref (Run m h)
r
      MT.OngoingTreeMerge Ref (MergingRun TreeMergeType m h)
mr -> do
        Vector (Ref (Run m h))
rs <- ActionRegistry m
-> m (Vector (Ref (Run m h)))
-> (Vector (Ref (Run m h)) -> m ())
-> m (Vector (Ref (Run m h)))
forall (m :: * -> *) a.
(PrimMonad m, MonadMask m, ?callStack::CallStack) =>
ActionRegistry m -> m a -> (a -> m ()) -> m a
withRollback ActionRegistry m
reg (Ref (MergingRun TreeMergeType m h) -> m (Vector (Ref (Run m h)))
forall (m :: * -> *) t h.
(PrimMonad m, MonadMVar m, MonadMask m) =>
Ref (MergingRun t m h) -> m (Vector (Ref (Run m h)))
MR.duplicateRuns Ref (MergingRun TreeMergeType m h)
mr) ((Ref (Run m h) -> m ()) -> Vector (Ref (Run m h)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ Ref (Run m h) -> m ()
forall (m :: * -> *) obj.
(RefCounted m obj, PrimMonad m, MonadMask m,
 ?callStack::CallStack) =>
Ref obj -> m ()
releaseRef)
        Maybe TreeMergeType
ty <- Ref (MergingRun TreeMergeType m h) -> m (Maybe TreeMergeType)
forall (m :: * -> *) t h.
MonadMVar m =>
Ref (MergingRun t m h) -> m (Maybe t)
MR.mergeType Ref (MergingRun TreeMergeType m h)
mr
        LookupTree (Vector (Ref (Run m h)))
-> m (LookupTree (Vector (Ref (Run m h))))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LookupTree (Vector (Ref (Run m h)))
 -> m (LookupTree (Vector (Ref (Run m h)))))
-> LookupTree (Vector (Ref (Run m h)))
-> m (LookupTree (Vector (Ref (Run m h))))
forall a b. (a -> b) -> a -> b
$ case Maybe TreeMergeType
ty of
          Maybe TreeMergeType
Nothing            -> Vector (Ref (Run m h)) -> LookupTree (Vector (Ref (Run m h)))
forall a. a -> LookupTree a
LookupBatch Vector (Ref (Run m h))
rs  -- just one run
          Just TreeMergeType
MR.MergeLevel -> Vector (Ref (Run m h)) -> LookupTree (Vector (Ref (Run m h)))
forall a. a -> LookupTree a
LookupBatch Vector (Ref (Run m h))
rs  -- combine runs
          Just TreeMergeType
MR.MergeUnion -> TreeMergeType
-> Vector (LookupTree (Vector (Ref (Run m h))))
-> LookupTree (Vector (Ref (Run m h)))
forall a. TreeMergeType -> Vector (LookupTree a) -> LookupTree a
mkLookupNode TreeMergeType
MR.MergeUnion  -- separate
                                  (Vector (Ref (Run m h)) -> LookupTree (Vector (Ref (Run m h)))
forall a. a -> LookupTree a
LookupBatch (Vector (Ref (Run m h)) -> LookupTree (Vector (Ref (Run m h))))
-> (Ref (Run m h) -> Vector (Ref (Run m h)))
-> Ref (Run m h)
-> LookupTree (Vector (Ref (Run m h)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref (Run m h) -> Vector (Ref (Run m h))
forall a. a -> Vector a
V.singleton (Ref (Run m h) -> LookupTree (Vector (Ref (Run m h))))
-> Vector (Ref (Run m h))
-> Vector (LookupTree (Vector (Ref (Run m h))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Ref (Run m h))
rs)
      MT.PendingTreeMerge (MT.PendingLevelMerge Vector (PreExistingRun m h)
prs Maybe (Ref (MergingTree m h))
Nothing) -> do
        Vector (Ref (Run m h)) -> LookupTree (Vector (Ref (Run m h)))
forall a. a -> LookupTree a
LookupBatch (Vector (Ref (Run m h)) -> LookupTree (Vector (Ref (Run m h))))
-> (Vector (Vector (Ref (Run m h))) -> Vector (Ref (Run m h)))
-> Vector (Vector (Ref (Run m h)))
-> LookupTree (Vector (Ref (Run m h)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Vector (Ref (Run m h))] -> Vector (Ref (Run m h))
forall a. [Vector a] -> Vector a
V.concat ([Vector (Ref (Run m h))] -> Vector (Ref (Run m h)))
-> (Vector (Vector (Ref (Run m h))) -> [Vector (Ref (Run m h))])
-> Vector (Vector (Ref (Run m h)))
-> Vector (Ref (Run m h))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Vector (Ref (Run m h))) -> [Vector (Ref (Run m h))]
forall a. Vector a -> [a]
V.toList (Vector (Vector (Ref (Run m h)))
 -> LookupTree (Vector (Ref (Run m h))))
-> m (Vector (Vector (Ref (Run m h))))
-> m (LookupTree (Vector (Ref (Run m h))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  -- combine runs
          (PreExistingRun m h -> m (Vector (Ref (Run m h))))
-> Vector (PreExistingRun m h)
-> m (Vector (Vector (Ref (Run m h))))
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) -> Vector a -> f (Vector b)
traverse PreExistingRun m h -> m (Vector (Ref (Run m h)))
duplicatePreExistingRun Vector (PreExistingRun m h)
prs
      MT.PendingTreeMerge (MT.PendingLevelMerge Vector (PreExistingRun m h)
prs (Just Ref (MergingTree m h)
tree)) -> do
        LookupTree (Vector (Ref (Run m h)))
child <- ActionRegistry m
-> Ref (MergingTree m h) -> m (LookupTree (Vector (Ref (Run m h))))
forall (m :: * -> *) h.
(PrimMonad m, MonadMVar m, MonadMask m) =>
ActionRegistry m
-> Ref (MergingTree m h) -> m (LookupTree (Vector (Ref (Run m h))))
buildLookupTree ActionRegistry m
reg Ref (MergingTree m h)
tree
        if Vector (PreExistingRun m h) -> Bool
forall a. Vector a -> Bool
V.null Vector (PreExistingRun m h)
prs
          then LookupTree (Vector (Ref (Run m h)))
-> m (LookupTree (Vector (Ref (Run m h))))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return LookupTree (Vector (Ref (Run m h)))
child
          else do
            LookupTree (Vector (Ref (Run m h)))
preExisting <- do
              Vector (Ref (Run m h)) -> LookupTree (Vector (Ref (Run m h)))
forall a. a -> LookupTree a
LookupBatch (Vector (Ref (Run m h)) -> LookupTree (Vector (Ref (Run m h))))
-> (Vector (Vector (Ref (Run m h))) -> Vector (Ref (Run m h)))
-> Vector (Vector (Ref (Run m h)))
-> LookupTree (Vector (Ref (Run m h)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Vector (Ref (Run m h))] -> Vector (Ref (Run m h))
forall a. [Vector a] -> Vector a
V.concat ([Vector (Ref (Run m h))] -> Vector (Ref (Run m h)))
-> (Vector (Vector (Ref (Run m h))) -> [Vector (Ref (Run m h))])
-> Vector (Vector (Ref (Run m h)))
-> Vector (Ref (Run m h))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Vector (Ref (Run m h))) -> [Vector (Ref (Run m h))]
forall a. Vector a -> [a]
V.toList (Vector (Vector (Ref (Run m h)))
 -> LookupTree (Vector (Ref (Run m h))))
-> m (Vector (Vector (Ref (Run m h))))
-> m (LookupTree (Vector (Ref (Run m h))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  -- combine runs
                (PreExistingRun m h -> m (Vector (Ref (Run m h))))
-> Vector (PreExistingRun m h)
-> m (Vector (Vector (Ref (Run m h))))
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) -> Vector a -> f (Vector b)
traverse PreExistingRun m h -> m (Vector (Ref (Run m h)))
duplicatePreExistingRun Vector (PreExistingRun m h)
prs
            LookupTree (Vector (Ref (Run m h)))
-> m (LookupTree (Vector (Ref (Run m h))))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LookupTree (Vector (Ref (Run m h)))
 -> m (LookupTree (Vector (Ref (Run m h)))))
-> LookupTree (Vector (Ref (Run m h)))
-> m (LookupTree (Vector (Ref (Run m h))))
forall a b. (a -> b) -> a -> b
$ TreeMergeType
-> Vector (LookupTree (Vector (Ref (Run m h))))
-> LookupTree (Vector (Ref (Run m h)))
forall a. TreeMergeType -> Vector (LookupTree a) -> LookupTree a
mkLookupNode TreeMergeType
MR.MergeLevel (Vector (LookupTree (Vector (Ref (Run m h))))
 -> LookupTree (Vector (Ref (Run m h))))
-> Vector (LookupTree (Vector (Ref (Run m h))))
-> LookupTree (Vector (Ref (Run m h)))
forall a b. (a -> b) -> a -> b
$ [LookupTree (Vector (Ref (Run m h)))]
-> Vector (LookupTree (Vector (Ref (Run m h))))
forall a. [a] -> Vector a
V.fromList [LookupTree (Vector (Ref (Run m h)))
preExisting, LookupTree (Vector (Ref (Run m h)))
child]
      MT.PendingTreeMerge (MT.PendingUnionMerge Vector (Ref (MergingTree m h))
trees) ->
        TreeMergeType
-> Vector (LookupTree (Vector (Ref (Run m h))))
-> LookupTree (Vector (Ref (Run m h)))
forall a. TreeMergeType -> Vector (LookupTree a) -> LookupTree a
mkLookupNode TreeMergeType
MR.MergeUnion (Vector (LookupTree (Vector (Ref (Run m h))))
 -> LookupTree (Vector (Ref (Run m h))))
-> m (Vector (LookupTree (Vector (Ref (Run m h)))))
-> m (LookupTree (Vector (Ref (Run m h))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ref (MergingTree m h) -> m (LookupTree (Vector (Ref (Run m h)))))
-> Vector (Ref (MergingTree m h))
-> m (Vector (LookupTree (Vector (Ref (Run m h)))))
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) -> Vector a -> f (Vector b)
traverse (ActionRegistry m
-> Ref (MergingTree m h) -> m (LookupTree (Vector (Ref (Run m h))))
forall (m :: * -> *) h.
(PrimMonad m, MonadMVar m, MonadMask m) =>
ActionRegistry m
-> Ref (MergingTree m h) -> m (LookupTree (Vector (Ref (Run m h))))
buildLookupTree ActionRegistry m
reg) Vector (Ref (MergingTree m h))
trees
  where
    dupRun :: Ref (Run m h) -> m (Ref (Run m h))
dupRun Ref (Run m h)
r = ActionRegistry m
-> m (Ref (Run m h))
-> (Ref (Run m h) -> m ())
-> m (Ref (Run m h))
forall (m :: * -> *) a.
(PrimMonad m, MonadMask m, ?callStack::CallStack) =>
ActionRegistry m -> m a -> (a -> m ()) -> m a
withRollback ActionRegistry m
reg (Ref (Run m h) -> m (Ref (Run m h))
forall (m :: * -> *) obj.
(RefCounted m obj, PrimMonad m, MonadThrow m,
 ?callStack::CallStack) =>
Ref obj -> m (Ref obj)
dupRef Ref (Run m h)
r) Ref (Run m h) -> m ()
forall (m :: * -> *) obj.
(RefCounted m obj, PrimMonad m, MonadMask m,
 ?callStack::CallStack) =>
Ref obj -> m ()
releaseRef

    duplicatePreExistingRun :: PreExistingRun m h -> m (Vector (Ref (Run m h)))
duplicatePreExistingRun (MT.PreExistingRun Ref (Run m h)
r) =
        Ref (Run m h) -> Vector (Ref (Run m h))
forall a. a -> Vector a
V.singleton (Ref (Run m h) -> Vector (Ref (Run m h)))
-> m (Ref (Run m h)) -> m (Vector (Ref (Run m h)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ref (Run m h) -> m (Ref (Run m h))
dupRun Ref (Run m h)
r
    duplicatePreExistingRun (MT.PreExistingMergingRun Ref (MergingRun LevelMergeType m h)
mr) =
        ActionRegistry m
-> m (Vector (Ref (Run m h)))
-> (Vector (Ref (Run m h)) -> m ())
-> m (Vector (Ref (Run m h)))
forall (m :: * -> *) a.
(PrimMonad m, MonadMask m, ?callStack::CallStack) =>
ActionRegistry m -> m a -> (a -> m ()) -> m a
withRollback ActionRegistry m
reg (Ref (MergingRun LevelMergeType m h) -> m (Vector (Ref (Run m h)))
forall (m :: * -> *) t h.
(PrimMonad m, MonadMVar m, MonadMask m) =>
Ref (MergingRun t m h) -> m (Vector (Ref (Run m h)))
MR.duplicateRuns Ref (MergingRun LevelMergeType m h)
mr) ((Ref (Run m h) -> m ()) -> Vector (Ref (Run m h)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ Ref (Run m h) -> m ()
forall (m :: * -> *) obj.
(RefCounted m obj, PrimMonad m, MonadMask m,
 ?callStack::CallStack) =>
Ref obj -> m ()
releaseRef)

{-# SPECIALISE releaseLookupTree ::
     ActionRegistry IO -> LookupTree (V.Vector (Ref (Run IO h))) -> IO () #-}
releaseLookupTree ::
     (PrimMonad m, MonadMask m)
  => ActionRegistry m -> LookupTree (V.Vector (Ref (Run m h))) -> m ()
releaseLookupTree :: forall (m :: * -> *) h.
(PrimMonad m, MonadMask m) =>
ActionRegistry m -> LookupTree (Vector (Ref (Run m h))) -> m ()
releaseLookupTree ActionRegistry m
reg = (Vector (Ref (Run m h)) -> m ())
-> LookupTree (Vector (Ref (Run m h))) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Ref (Run m h) -> m ()) -> Vector (Ref (Run m h)) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ActionRegistry m -> m () -> m ()
forall (m :: * -> *).
(PrimMonad m, ?callStack::CallStack) =>
ActionRegistry m -> m () -> m ()
delayedCommit ActionRegistry m
reg (m () -> m ()) -> (Ref (Run m h) -> m ()) -> Ref (Run m h) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref (Run m h) -> m ()
forall (m :: * -> *) obj.
(RefCounted m obj, PrimMonad m, MonadMask m,
 ?callStack::CallStack) =>
Ref obj -> m ()
releaseRef))