coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

sx-git Phase 6: merge — diff3 textual 3-way, tree merge, ff detection (TDD)

Browse Source 
Textual diff3 built on the Myers scripts: non-eq regions clustered by strict
base-interval overlap (same-point insert pairs cluster too); one-sided
clusters apply, two-sided take shared result or emit <<<<<<</|||||||/=======/
>>>>>>> markers with base section. Per-path 3-way tree merge with blob-level
auto-merge and delete/modify flagging; merge-commits handles up-to-date /
fast-forward / merged / conflicts, unrelated histories merge over an empty
base. (Content CvRDT not reused deliberately: its state-based LWW block
semantics differ from base-anchored 3-way; the path-set merge here is the
same idea applied natively.) 28/28, total 187/187.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
giles
2026-07-03 12:22:35 +00:00
parent 4d5a60a754
commit 989dc278c1
6 changed files with 488 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files

224
lib/git/merge.sx Normal file
View File

@@ -0,0 +1,224 @@
; lib/git/merge.sx — sx-git Phase 6: 3-way merge.
; Textual diff3: regions (non-eq runs of the Myers script base->side) are
; clustered by strict base-interval overlap (same-point insertions from both
; sides also cluster); one-sided clusters apply cleanly, two-sided clusters
; take the shared result or emit diff3 conflict markers with the base section.
; Tree merge: per-path 3-way over flattened trees with blob-level textual
; auto-merge; delete/modify keeps the surviving side and flags the path.
; Commit merge: up-to-date / fast-forward detection, else merge via merge-base
; (empty base for unrelated histories).
; Requires: lib/git/object.sx, dag.sx, worktree.sx, diff.sx.
(define
git/m3-concat
(fn (ls) (reduce (fn (acc l) (append acc l)) (list) ls)))
; ---- regions: non-eq runs as {:s :e :repl} over base indices ----
(define
git/m3-regions
(fn
(script)
(let
((st (reduce (fn (acc o) (let ((op (get o :op))) (cond ((equal? op "eq") (if (get acc :open) {:repl (list) :s 0 :open false :out (append (get acc :out) (list {:repl (get acc :repl) :e (get acc :bi) :s (get acc :s)})) :bi (+ (get acc :bi) 1)} (assoc acc :bi (+ (get acc :bi) 1)))) ((equal? op "del") (if (get acc :open) (assoc acc :bi (+ (get acc :bi) 1)) (merge acc {:s (get acc :bi) :open true :bi (+ (get acc :bi) 1)}))) (else (if (get acc :open) (assoc acc :repl (append (get acc :repl) (list (get o :line)))) (merge acc {:repl (list (get o :line)) :s (get acc :bi) :open true})))))) {:repl (list) :s 0 :open false :out (list) :bi 0} script)))
(if
(get st :open)
(append (get st :out) (list {:repl (get st :repl) :e (get st :bi) :s (get st :s)}))
(get st :out)))))
; ---- stable sort by :s (insert after equals: a-side stays before b-side) ----
(define
git/m3-ins
(fn
(sorted r)
(cond
((empty? sorted) (list r))
((< (get r :s) (get (first sorted) :s)) (cons r sorted))
(else (cons (first sorted) (git/m3-ins (rest sorted) r))))))
(define
git/m3-sort
(fn (rs) (reduce (fn (acc r) (git/m3-ins acc r)) (list) rs)))
; ---- clustering ----
(define
git/m3-has-insert-at?
(fn
(ms p)
(reduce
(fn (acc m) (or acc (and (= (get m :s) p) (= (get m :e) p))))
false
ms)))
(define
git/m3-cluster-overlap?
(fn
(cur r)
(or
(< (get r :s) (get cur :ce))
(and
(= (get r :s) (get r :e))
(= (get r :s) (get cur :ce))
(git/m3-has-insert-at? (get cur :members) (get r :s))))))
(define
git/m3-clusters
(fn
(regions)
(let
((res (reduce (fn (acc r) (let ((cur (nth acc 1))) (if (equal? cur nil) (list (first acc) {:ce (get r :e) :members (list r) :cs (get r :s)}) (if (git/m3-cluster-overlap? cur r) (list (first acc) {:ce (max (get cur :ce) (get r :e)) :members (append (get cur :members) (list r)) :cs (get cur :cs)}) (list (append (first acc) (list cur)) {:ce (get r :e) :members (list r) :cs (get r :s)}))))) (list (list) nil) regions)))
(if
(equal? (nth res 1) nil)
(first res)
(append (first res) (list (nth res 1)))))))
; ---- apply one side's regions across a base span ----
(define
git/m3-bslice
(fn
(bv from to)
(if
(>= from to)
(list)
(cons (git/dget bv from) (git/m3-bslice bv (+ from 1) to)))))
(define
git/m3-apply-side
(fn
(bv members side cs ce)
(let
((res (reduce (fn (acc m) (list (get m :e) (append (nth acc 1) (append (git/m3-bslice bv (first acc) (get m :s)) (get m :repl))))) (list cs (list)) (filter (fn (m) (equal? (get m :side) side)) members))))
(append (nth res 1) (git/m3-bslice bv (first res) ce)))))
; ---- evaluate a cluster: clean lines or a conflict block ----
(define
git/m3-eval-cluster
(fn
(bv cl)
(let
((ms (get cl :members)))
(let
((has-a (reduce (fn (acc m) (or acc (equal? (get m :side) "a"))) false ms))
(has-b
(reduce
(fn (acc m) (or acc (equal? (get m :side) "b")))
false
ms))
(aout (git/m3-apply-side bv ms "a" (get cl :cs) (get cl :ce)))
(bout (git/m3-apply-side bv ms "b" (get cl :cs) (get cl :ce))))
(cond
((and has-a has-b (not (= aout bout))) {:conflict true :lines (git/m3-concat (list (list "<<<<<<< ours") aout (list "||||||| base") (git/m3-bslice bv (get cl :cs) (get cl :ce)) (list "=======") bout (list ">>>>>>> theirs")))})
(has-a {:conflict false :lines aout})
(else {:conflict false :lines bout}))))))
; ---- diff3 over line lists ----
(define
git/merge3-lines
(fn
(base-lines a-lines b-lines)
(let
((bv (git/dvec base-lines)))
(let
((all (git/m3-sort (append (map (fn (r) (assoc r :side "a")) (git/m3-regions (git/diff-script-lines base-lines a-lines))) (map (fn (r) (assoc r :side "b")) (git/m3-regions (git/diff-script-lines base-lines b-lines)))))))
(let
((res (reduce (fn (acc cl) (let ((ev (git/m3-eval-cluster bv cl))) (list (get cl :ce) (append (nth acc 1) (append (git/m3-bslice bv (first acc) (get cl :cs)) (get ev :lines))) (+ (nth acc 2) (if (get ev :conflict) 1 0))))) (list 0 (list) 0) (git/m3-clusters all))))
{:clean (= (nth res 2) 0) :conflicts (nth res 2) :lines (append (nth res 1) (git/m3-bslice bv (first res) (len base-lines)))})))))
(define
git/m3-unlines
(fn
(ls)
(if
(empty? ls)
""
(str
(reduce (fn (acc l) (str acc "\n" l)) (first ls) (rest ls))
"\n"))))
; textual 3-way over strings: {:clean :conflicts :text}
(define
git/merge3-text
(fn
(base ours theirs)
(let
((r (git/merge3-lines (git/diff-lines base) (git/diff-lines ours) (git/diff-lines theirs))))
{:clean (get r :clean) :text (git/m3-unlines (get r :lines)) :conflicts (get r :conflicts)})))
; ---- tree building from path -> blob cid (no data reread) ----
(define
git/tree-from-cids
(fn
(repo files)
(let
((g (git/wt-group files)))
(let
((with-blobs (reduce (fn (acc name) (assoc acc name (git/tree-entry "blob" (get (get g :files) name)))) {} (keys (get g :files)))))
(let
((entries (reduce (fn (acc dir) (assoc acc dir (git/tree-entry "tree" (git/tree-from-cids repo (get (get g :dirs) dir))))) with-blobs (keys (get g :dirs)))))
(git/write repo (git/tree entries)))))))
; ---- per-path 3-way tree merge: {:files path->cid :conflicts (paths)} ----
(define
git/m3-union-paths
(fn (fa fb fc) (artdag/sort-strings (keys (merge (merge fa fb) fc)))))
(define
git/merge-trees
(fn
(repo base-t a-t b-t)
(let
((fb (if (equal? base-t nil) {} (git/tree-flatten repo base-t)))
(fa (git/tree-flatten repo a-t))
(ft (git/tree-flatten repo b-t)))
(reduce
(fn
(acc path)
(let
((bc (get fb path)) (ac (get fa path)) (tc (get ft path)))
(cond
((equal? ac tc)
(if
(equal? ac nil)
acc
(assoc acc :files (assoc (get acc :files) path ac))))
((equal? bc ac)
(if
(equal? tc nil)
acc
(assoc acc :files (assoc (get acc :files) path tc))))
((equal? bc tc)
(if
(equal? ac nil)
acc
(assoc acc :files (assoc (get acc :files) path ac))))
((or (equal? ac nil) (equal? tc nil)) (merge acc {:conflicts (append (get acc :conflicts) (list path)) :files (assoc (get acc :files) path (if (equal? ac nil) tc ac))}))
(else
(let
((m (git/merge3-text (if (equal? bc nil) "" (git/blob-data (git/read repo bc))) (git/blob-data (git/read repo ac)) (git/blob-data (git/read repo tc)))))
(let
((cid (git/write-blob repo (get m :text))))
(if
(get m :clean)
(assoc acc :files (assoc (get acc :files) path cid))
(merge acc {:conflicts (append (get acc :conflicts) (list path)) :files (assoc (get acc :files) path cid)}))))))))
{:conflicts (list) :files {}}
(git/m3-union-paths fb fa ft)))))
; ---- commit-level merge ----
; can merging `theirs` into `ours` fast-forward?
(define git/ff? (fn (repo ours theirs) (git/is-ancestor? repo ours theirs)))
(define
git/merge-commits
(fn
(repo ours theirs)
(cond
((git/is-ancestor? repo theirs ours) {:cid ours :result "up-to-date"})
((git/is-ancestor? repo ours theirs) {:cid theirs :result "fast-forward"})
(else
(let
((mb (git/merge-base repo ours theirs)))
(let
((mt (git/merge-trees repo (if (equal? mb nil) nil (git/commit-tree (git/read repo mb))) (git/commit-tree (git/read repo ours)) (git/commit-tree (git/read repo theirs)))))
(let
((tc (git/tree-from-cids repo (get mt :files))))
(if (empty? (get mt :conflicts)) {:conflicts (list) :tree tc :result "merged"} {:conflicts (get mt :conflicts) :tree tc :result "conflicts"}))))))))