refactor MergeLocalBranchI to produce only one root update [...]

* refactored `propagatePatch` to delay the actual propagation,
* add `Branch.adjustHeadMN` which is kind of like `git commit --amend`
* use `adjustHeadMN` to rewrite the head of the merged branch with the result of propagation

* introduced or fixed a bug relating to applying conflicted patch in diff.md ?
* changed output in delete.output.md ?

parser-typechecker/src/Unison/Codebase/Branch.hs

@@ -37,6 +37,7 @@ module Unison.Codebase.Branch
   , stepEverywhere
   , uncons
   , merge
+  , adjustHeadMN
 
     -- * Branch children
     -- ** Children lenses
@@ -212,6 +213,13 @@ toNames0 :: Branch0 m -> Names0
 toNames0 b = Names (R.swap . deepTerms $ b)
                    (R.swap . deepTypes $ b)
 
+adjustHeadMN :: (Monad m, Monad n)
+  => (Branch0 m -> n (Branch0 m))
+  -> (forall a. m a -> n a)
+  -> Branch m
+  -> n (Maybe (Branch m))
+adjustHeadMN f g = (fmap . fmap) Branch . Causal.adjustHeadMN f g . _history
+
 -- This stops searching for a given ShortHash once it encounters
 -- any term or type in any Branch0 that satisfies that ShortHash.
 findHistoricalSHs
@@ -562,7 +570,7 @@ isEmpty = (== empty)
 step :: Applicative m => (Branch0 m -> Branch0 m) -> Branch m -> Branch m
 step f = over history (Causal.stepDistinct f)
 
-stepM :: Monad m => (Branch0 m -> m (Branch0 m)) -> Branch m -> m (Branch m)
+stepM :: (Monad m, Monad n) => (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m)
 stepM f = mapMOf history (Causal.stepDistinctM f)
 
 cons :: Applicative m => Branch0 m -> Branch m -> Branch m
@@ -600,8 +608,8 @@ stepAtM p f = modifyAtM p g where
     b0' <- f (Causal.head b)
     pure $ Branch . Causal.consDistinct b0' $ b
 
-stepManyAtM :: (Monad m, Foldable f)
-            => f (Path, Branch0 m -> m (Branch0 m)) -> Branch m -> m (Branch m)
+stepManyAtM :: (Monad m, Monad n, Foldable f)
+            => f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m)
 stepManyAtM actions = stepM (stepManyAt0M actions)
 
 -- starting at the leaves, apply `f` to every level of the branch.
@@ -691,9 +699,9 @@ stepManyAt0 :: (Applicative m, Foldable f)
            -> Branch0 m -> Branch0 m
 stepManyAt0 actions b = foldl' (\b (p, f) -> stepAt0 p f b) b actions
 
-stepManyAt0M :: (Monad m, Foldable f)
-             => f (Path, Branch0 m -> m (Branch0 m))
-             -> Branch0 m -> m (Branch0 m)
+stepManyAt0M :: (Monad m, Monad n, Foldable f)
+             => f (Path, Branch0 m -> n (Branch0 m))
+             -> Branch0 m -> n (Branch0 m)
 stepManyAt0M actions b = Monad.foldM (\b (p, f) -> stepAt0M p f b) b actions
 
 stepAt0M :: forall n m. (Functor n, Applicative m)

parser-typechecker/src/Unison/Codebase/Causal.hs

@@ -172,6 +172,20 @@ children (One _ _         ) = Seq.empty
 children (Cons  _ _ (_, t)) = Seq.singleton t
 children (Merge _ _ ts    ) = Seq.fromList $ Map.elems ts
 
+adjustHeadMN :: (Monad m, Monad n, Hashable e)
+  => (e -> n e)
+  -> (forall a. m a -> n a)
+  -> Causal m h e
+  -> n (Maybe (Causal m h e))
+adjustHeadMN f g = \case
+  One{} -> pure Nothing
+  Cons _ e (_, tl) ->
+    fmap Just . cons <$> f e <*> g tl
+  Merge _ e tails -> do
+    e' <- f e
+    let h' = RawHash $ hash (e', Map.keys tails)
+    pure . Just $ Merge h' e' tails
+
 threeWayMerge
   :: forall m h e d
    . (Show d, Monad m, Hashable e, Semigroup d)
@@ -279,7 +293,8 @@ stepM
 stepM f c = (`cons` c) <$> f (head c)
 
 stepDistinctM
-  :: (Applicative m, Eq e, Hashable e) => (e -> m e) -> Causal m h e -> m (Causal m h e)
+  :: (Applicative m, Functor n, Eq e, Hashable e)
+  => (e -> n e) -> Causal m h e -> n (Causal m h e)
 stepDistinctM f c = (`consDistinct` c) <$> f (head c)
 
 one :: Hashable e => e -> Causal m h e

parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs

@@ -214,6 +214,11 @@ loop = do
         let (p, seg) = Path.toAbsoluteSplit currentPath' patchPath'
         b <- getAt p
         eval . Eval $ Branch.getPatch seg (Branch.head b)
+      getPatchAt' :: Path.Split' -> Branch0 m -> Action' m v Patch
+      getPatchAt' patchPath' b = do
+        let (p, seg) = Path.toAbsoluteSplit currentPath' patchPath'
+            b' = Branch.getAt0 (Path.unabsolute p) b
+        eval . Eval $ Branch.getPatch seg b'
       withFile ambient sourceName lexed@(text, tokens) k = do
         let
           getHQ = \case
@@ -485,12 +490,17 @@ loop = do
         else do
           destb <- getAt dest
           merged <- eval . Eval $ Branch.merge srcb destb
-          b <- updateAtM dest $ const (pure merged)
-          if b then do
-            diffHelper (Branch.head destb) (Branch.head merged) >>=
+          let merged0 = Branch.head merged
+          patch <- getPatchAt' defaultPatchPath merged0
+          if (merged /= destb) then do
+            let (applyPatch, printMsg) = propagatePatch' @m @v patch dest
+            merged' <-
+              -- fromJust is safe as long as Branch.merge doesn't produce a Causal.One! 
+              fromJust <$> Branch.adjustHeadMN applyPatch (eval . Eval) merged
+            updateAtM dest $ const (pure merged')
+            diffHelper (Branch.head destb) (Branch.head merged') >>=
               respondNumbered . uncurry (ShowDiffAfterMerge dest0 dest)
-            patch <- getPatchAt defaultPatchPath
-            void $ propagatePatch inputDescription patch dest
+            when (merged' /= merged) printMsg
           else respond (NothingTodo input)
 
       PreviewMergeLocalBranchI src0 dest0 -> do
@@ -979,7 +989,7 @@ loop = do
 
           -- type query
           ":" : ws -> ExceptT (parseSearchType input (unwords ws)) >>= \typ -> ExceptT $ do
-            let named = Branch.deepReferents (Branch.head root')
+            let named = Branch.deepReferents root0
             matches <- fmap toList . eval $ GetTermsOfType typ
             matches <- filter (`Set.member` named) <$>
               if null matches then do
@@ -1535,11 +1545,25 @@ resolveShortBranchHash hash = do
 propagatePatch :: (Monad m, Var v) =>
   Text -> Patch -> Path.Absolute -> Action' m v Bool
 propagatePatch inputDescription patch scopePath = do
-  changed <- do
-    updateAtM (inputDescription <> " (patch propagation)")
-              scopePath
-              (lift . lift . Propagate.propagateAndApply patch)
-  when changed $ do
+  let (f, msg) = propagatePatch' patch scopePath
+  changed <- stepAtM' (inputDescription <> " (patch propagation)")
+                      (Path.unabsolute scopePath, f)
+  when changed msg
+  pure changed
+
+-- Returns a function that updates a Branch0 according to the patch,
+-- and a an action that prints todo output, suitable for running if the branch
+--  was updated
+propagatePatch' :: forall m v. (Monad m, Var v)
+  => Patch
+  -> Path.Absolute
+  -> ( Branch0 m -> Action' m v (Branch0 m)
+     , Action' m v () )
+propagatePatch' patch scopePath =
+  let applyPatch :: Branch0 m -> Action' m v (Branch0 m)
+      applyPatch = lift . lift . Propagate.propagateAndApply patch in
+  ( applyPatch
+  , do
     scope <- getAt scopePath
     let names0 = Branch.toNames0 (Branch.head scope)
     -- this will be different AFTER the update succeeds
@@ -1547,7 +1571,7 @@ propagatePatch inputDescription patch scopePath = do
           names <- makePrintNamesFromLabeled' (Patch.labeledDependencies patch)
           prettyPrintEnvDecl names
     showTodoOutput getPpe patch names0
-  pure changed
+  )
 
 -- | Show todo output if there are any conflicts or edits.
 showTodoOutput
@@ -1842,6 +1866,12 @@ stepAtM :: forall m i v. Monad m
         -> Action m i v ()
 stepAtM cause = stepManyAtM @m @[] cause . pure
 
+stepAtM' :: forall m i v. Monad m
+        => Text
+        -> (Path, Branch0 m -> Action m i v (Branch0 m))
+        -> Action m i v Bool
+stepAtM' cause = stepManyAtM' @m @[] cause . pure
+
 stepManyAt :: (Applicative m, Foldable f)
            => Text
            -> f (Path, Branch0 m -> Branch0 m)
@@ -1860,6 +1890,16 @@ stepManyAtM reason actions = do
     b' <- eval . Eval $ Branch.stepManyAtM actions b
     updateRoot b b' reason
 
+stepManyAtM' :: (Monad m, Foldable f)
+           => Text
+           -> f (Path, Branch0 m -> Action m i v (Branch0 m))
+           -> Action m i v Bool
+stepManyAtM' reason actions = do
+    b <- use root
+    b' <- Branch.stepManyAtM actions b
+    updateRoot b b' reason
+    pure (b /= b')
+
 updateRoot :: Branch m -> Branch m -> Text -> Action m i v ()
 updateRoot old new reason = when (old /= new) $ do
   root .= new

parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs

@@ -11,9 +11,7 @@ import           Data.Configurator              ( )
 import qualified Data.Graph                    as Graph
 import qualified Data.Map                      as Map
 import qualified Data.Set                      as Set
-import           Unison.Codebase.Branch         ( Branch(..)
-                                                , Branch0(..)
-                                                )
+import           Unison.Codebase.Branch         ( Branch0(..) )
 import           Unison.Prelude
 import qualified Unison.Codebase.Branch        as Branch
 import           Unison.Codebase.Editor.Command
@@ -71,12 +69,13 @@ propagateAndApply
   :: forall m i v
    . (Applicative m, Var v)
   => Patch
-  -> Branch m
-  -> F m i v (Branch m)
+  -> Branch0 m
+  -> F m i v (Branch0 m)
 propagateAndApply patch branch = do
   edits <- propagate patch branch
   f     <- applyPropagate patch edits
-  pure $ Branch.step (f . applyDeprecations patch) branch
+  (pure . f . applyDeprecations patch) branch
+
 
 -- Creates a mapping from old data constructors to new data constructors
 -- by looking at the original names for the data constructors which are
@@ -133,7 +132,7 @@ propagate
   :: forall m i v
    . (Applicative m, Var v)
   => Patch
-  -> Branch m
+  -> Branch0 m
   -> F m i v (Edits v)
 propagate patch b = case validatePatch patch of
   Nothing -> do
@@ -142,9 +141,9 @@ propagate patch b = case validatePatch patch of
   Just (initialTermEdits, initialTypeEdits) -> do
     let
       entireBranch = Set.union
-        (Branch.deepTypeReferences $ Branch.head b)
+        (Branch.deepTypeReferences b)
         (Set.fromList
-          [ r | Referent.Ref r <- Set.toList . Branch.deepReferents $ Branch.head b ]
+          [ r | Referent.Ref r <- Set.toList $ Branch.deepReferents b ]
         )
     initialDirty <-
       R.dom <$> computeFrontier (eval . GetDependents) patch names0
@@ -326,7 +325,7 @@ propagate patch b = case validatePatch patch of
       (zip (view _1 . getReference <$> Graph.topSort graph) [0 ..])
     -- vertex i precedes j whenever i has an edge to j and not vice versa.
     -- vertex i precedes j when j is a dependent of i.
-  names0 = (Branch.toNames0 . Branch.head) b
+  names0 = Branch.toNames0 b
   validatePatch
     :: Patch -> Maybe (Map Reference TermEdit, Map Reference TypeEdit)
   validatePatch p =