module U.Codebase.Causal.Squash (squashCausal) where

import U.Codebase.Branch.Type
import U.Codebase.Causal (Causal (..))
import U.Codebase.Sqlite.HashHandle qualified as HH
import U.Codebase.Sqlite.Operations qualified as SqliteOps
import Unison.Prelude
import Unison.Sqlite qualified as Sqlite

-- Recursively discards history, resulting in a namespace tree with only single a single
-- Causal node at every level.
squashCausal :: HH.HashHandle -> CausalBranch Sqlite.Transaction -> Sqlite.Transaction (CausalBranch Sqlite.Transaction)
squashCausal :: HashHandle
-> Causal
     Transaction
     CausalHash
     BranchHash
     (Branch Transaction)
     (Branch Transaction)
-> Transaction
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction))
squashCausal hashHandle :: HashHandle
hashHandle@HH.HashHandle {BranchHash -> Set CausalHash -> CausalHash
hashCausal :: BranchHash -> Set CausalHash -> CausalHash
$sel:hashCausal:HashHandle :: HashHandle -> BranchHash -> Set CausalHash -> CausalHash
hashCausal, forall (m :: * -> *). Monad m => Branch m -> m BranchHash
hashBranch :: forall (m :: * -> *). Monad m => Branch m -> m BranchHash
$sel:hashBranch:HashHandle :: HashHandle
-> forall (m :: * -> *). Monad m => Branch m -> m BranchHash
hashBranch} Causal {$sel:valueHash:Causal :: forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> he
valueHash = BranchHash
unsquashedBranchHash, Transaction (Branch Transaction)
value :: Transaction (Branch Transaction)
$sel:value:Causal :: forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> m e
value} = do
  MaybeT
  Transaction
  (Causal
     Transaction
     CausalHash
     BranchHash
     (Branch Transaction)
     (Branch Transaction))
-> Transaction
     (Maybe
        (Causal
           Transaction
           CausalHash
           BranchHash
           (Branch Transaction)
           (Branch Transaction)))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (Transaction (Maybe CausalHash) -> MaybeT Transaction CausalHash
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (BranchHash -> Transaction (Maybe CausalHash)
SqliteOps.tryGetSquashResult BranchHash
unsquashedBranchHash) MaybeT Transaction CausalHash
-> (CausalHash
    -> MaybeT
         Transaction
         (Causal
            Transaction
            CausalHash
            BranchHash
            (Branch Transaction)
            (Branch Transaction)))
-> MaybeT
     Transaction
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction))
forall a b.
MaybeT Transaction a
-> (a -> MaybeT Transaction b) -> MaybeT Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Transaction
  (Maybe
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction)))
-> MaybeT
     Transaction
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction))
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Transaction
   (Maybe
      (Causal
         Transaction
         CausalHash
         BranchHash
         (Branch Transaction)
         (Branch Transaction)))
 -> MaybeT
      Transaction
      (Causal
         Transaction
         CausalHash
         BranchHash
         (Branch Transaction)
         (Branch Transaction)))
-> (CausalHash
    -> Transaction
         (Maybe
            (Causal
               Transaction
               CausalHash
               BranchHash
               (Branch Transaction)
               (Branch Transaction))))
-> CausalHash
-> MaybeT
     Transaction
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CausalHash
-> Transaction
     (Maybe
        (Causal
           Transaction
           CausalHash
           BranchHash
           (Branch Transaction)
           (Branch Transaction)))
SqliteOps.loadCausalBranchByCausalHash) Transaction
  (Maybe
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction)))
-> (Maybe
      (Causal
         Transaction
         CausalHash
         BranchHash
         (Branch Transaction)
         (Branch Transaction))
    -> Transaction
         (Causal
            Transaction
            CausalHash
            BranchHash
            (Branch Transaction)
            (Branch Transaction)))
-> Transaction
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction))
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Causal
  Transaction
  CausalHash
  BranchHash
  (Branch Transaction)
  (Branch Transaction)
cb -> Causal
  Transaction
  CausalHash
  BranchHash
  (Branch Transaction)
  (Branch Transaction)
-> Transaction
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Causal
  Transaction
  CausalHash
  BranchHash
  (Branch Transaction)
  (Branch Transaction)
cb
    Maybe
  (Causal
     Transaction
     CausalHash
     BranchHash
     (Branch Transaction)
     (Branch Transaction))
Nothing -> do
      branch :: Branch Transaction
branch@Branch {Map
  NameSegment
  (Causal
     Transaction
     CausalHash
     BranchHash
     (Branch Transaction)
     (Branch Transaction))
children :: Map
  NameSegment
  (Causal
     Transaction
     CausalHash
     BranchHash
     (Branch Transaction)
     (Branch Transaction))
$sel:children:Branch :: forall (m :: * -> *). Branch m -> Map NameSegment (CausalBranch m)
children} <- Transaction (Branch Transaction)
value
      Map
  NameSegment
  (Causal
     Transaction
     CausalHash
     BranchHash
     (Branch Transaction)
     (Branch Transaction))
squashedChildren <- (Causal
   Transaction
   CausalHash
   BranchHash
   (Branch Transaction)
   (Branch Transaction)
 -> Transaction
      (Causal
         Transaction
         CausalHash
         BranchHash
         (Branch Transaction)
         (Branch Transaction)))
-> Map
     NameSegment
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction))
-> Transaction
     (Map
        NameSegment
        (Causal
           Transaction
           CausalHash
           BranchHash
           (Branch Transaction)
           (Branch Transaction)))
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) -> Map NameSegment a -> f (Map NameSegment b)
traverse (HashHandle
-> Causal
     Transaction
     CausalHash
     BranchHash
     (Branch Transaction)
     (Branch Transaction)
-> Transaction
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction))
squashCausal HashHandle
hashHandle) Map
  NameSegment
  (Causal
     Transaction
     CausalHash
     BranchHash
     (Branch Transaction)
     (Branch Transaction))
children
      let squashedBranchHead :: Branch Transaction
squashedBranchHead = Branch Transaction
branch {children = squashedChildren}
      BranchHash
squashedBranchHash <- Branch Transaction -> Transaction BranchHash
forall (m :: * -> *). Monad m => Branch m -> m BranchHash
hashBranch Branch Transaction
squashedBranchHead
      let squashedCausalHash :: CausalHash
squashedCausalHash = BranchHash -> Set CausalHash -> CausalHash
hashCausal BranchHash
squashedBranchHash Set CausalHash
forall a. Monoid a => a
mempty
      let squashedCausalBranch :: Causal
  Transaction
  CausalHash
  BranchHash
  (Branch Transaction)
  (Branch Transaction)
squashedCausalBranch =
            Causal
              { $sel:causalHash:Causal :: CausalHash
causalHash = CausalHash
squashedCausalHash,
                $sel:valueHash:Causal :: BranchHash
valueHash = BranchHash
squashedBranchHash,
                $sel:parents:Causal :: Map
  CausalHash
  (Transaction
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction)))
parents = Map
  CausalHash
  (Transaction
     (Causal
        Transaction
        CausalHash
        BranchHash
        (Branch Transaction)
        (Branch Transaction)))
forall a. Monoid a => a
mempty,
                $sel:value:Causal :: Transaction (Branch Transaction)
value = Branch Transaction -> Transaction (Branch Transaction)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Branch Transaction
squashedBranchHead
              }
      HashHandle
-> Causal
     Transaction
     CausalHash
     BranchHash
     (Branch Transaction)
     (Branch Transaction)
-> Transaction (BranchObjectId, CausalHashId)
SqliteOps.saveBranch HashHandle
hashHandle Causal
  Transaction
  CausalHash
  BranchHash
  (Branch Transaction)
  (Branch Transaction)
squashedCausalBranch
      BranchHash -> CausalHash -> Transaction ()
SqliteOps.saveSquashResult BranchHash
unsquashedBranchHash CausalHash
squashedCausalHash
      pure Causal
  Transaction
  CausalHash
  BranchHash
  (Branch Transaction)
  (Branch Transaction)
squashedCausalBranch