diff --git a/lib/git/conformance.sh b/lib/git/conformance.sh index 72876385..89a22eab 100755 --- a/lib/git/conformance.sh +++ b/lib/git/conformance.sh @@ -13,7 +13,7 @@ if [ ! -x "$SX_SERVER" ]; then exit 1 fi -SUITES=(object ref dag worktree diff) +SUITES=(object ref dag worktree diff merge) OUT_JSON="lib/git/scoreboard.json" OUT_MD="lib/git/scoreboard.md" @@ -47,6 +47,7 @@ run_suite() { (load "lib/git/dag.sx") (load "lib/git/worktree.sx") (load "lib/git/diff.sx") +(load "lib/git/merge.sx") (epoch 2) (eval "(define git-test-pass 0)") (eval "(define git-test-fail 0)") diff --git a/lib/git/diff.sx b/lib/git/diff.sx index 4737f213..5c5183dc 100644 --- a/lib/git/diff.sx +++ b/lib/git/diff.sx @@ -145,30 +145,33 @@ (nth r 2))))))))))) ; ---- edit script over two strings ---- +(define + git/diff-script-lines + (fn + (al bl) + (let + ((rt (git/myers-run (git/dvec al) (git/dvec bl) (len al) (len bl) (assoc {} "1" 0) 0 (list)))) + (git/myers-back + (git/dvec al) + (git/dvec bl) + (first rt) + (nth rt 1) + (len al) + (len bl) + (list))))) + (define git/diff-script (fn (a-data b-data) - (let - ((al (git/diff-lines a-data)) (bl (git/diff-lines b-data))) - (let - ((rt (git/myers-run (git/dvec al) (git/dvec bl) (len al) (len bl) (assoc {} "1" 0) 0 (list)))) - (git/myers-back - (git/dvec al) - (git/dvec bl) - (first rt) - (nth rt 1) - (len al) - (len bl) - (list)))))) + (git/diff-script-lines (git/diff-lines a-data) (git/diff-lines b-data)))) +; reconstruction invariants: old = eq+del lines, new = eq+add lines (define git/diff-changes (fn (script) (len (filter (fn (o) (not (equal? (get o :op) "eq"))) script)))) - -; reconstruction invariants: old = eq+del lines, new = eq+add lines (define git/diff-old-lines (fn @@ -176,6 +179,8 @@ (map (fn (o) (get o :line)) (filter (fn (o) (not (equal? (get o :op) "add"))) script)))) + +; ---- unified rendering ---- (define git/diff-new-lines (fn @@ -184,7 +189,6 @@ (fn (o) (get o :line)) (filter (fn (o) (not (equal? (get o :op) "del"))) script)))) -; ---- unified rendering ---- (define git/diff-annotate (fn @@ -312,6 +316,7 @@ "" ops)))))) +; ---- object-level diffs ---- (define git/diff-unified (fn @@ -328,7 +333,6 @@ "" (git/diff-hunk-ranges ann 3))))) -; ---- object-level diffs ---- (define git/blob-diff (fn @@ -343,6 +347,7 @@ (repo t1 t2) (git/files-diff (git/tree-flatten repo t1) (git/tree-flatten repo t2)))) +; ---- whole-commit unified render: added, deleted, then modified paths ---- (define git/commit-diff (fn @@ -352,7 +357,6 @@ (git/commit-tree (git/read repo c1)) (git/commit-tree (git/read repo c2))))) -; ---- whole-commit unified render: added, deleted, then modified paths ---- (define git/diff-path-data (fn diff --git a/lib/git/merge.sx b/lib/git/merge.sx new file mode 100644 index 00000000..0d9ff787 --- /dev/null +++ b/lib/git/merge.sx @@ -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"})))))))) diff --git a/lib/git/scoreboard.json b/lib/git/scoreboard.json index dc7a8b28..18b8adc7 100644 --- a/lib/git/scoreboard.json +++ b/lib/git/scoreboard.json @@ -4,9 +4,10 @@ "ref": {"pass": 38, "fail": 0}, "dag": {"pass": 30, "fail": 0}, "worktree": {"pass": 26, "fail": 0}, - "diff": {"pass": 27, "fail": 0} + "diff": {"pass": 27, "fail": 0}, + "merge": {"pass": 28, "fail": 0} }, - "total_pass": 159, + "total_pass": 187, "total_fail": 0, - "total": 159 + "total": 187 } diff --git a/lib/git/scoreboard.md b/lib/git/scoreboard.md index 1a56a213..d906fabd 100644 --- a/lib/git/scoreboard.md +++ b/lib/git/scoreboard.md @@ -9,4 +9,5 @@ _Generated by `lib/git/conformance.sh`_ | dag | 30 | 0 | 30 | | worktree | 26 | 0 | 26 | | diff | 27 | 0 | 27 | -| **Total** | **159** | **0** | **159** | +| merge | 28 | 0 | 28 | +| **Total** | **187** | **0** | **187** | diff --git a/lib/git/tests/merge.sx b/lib/git/tests/merge.sx new file mode 100644 index 00000000..243e5b29 --- /dev/null +++ b/lib/git/tests/merge.sx @@ -0,0 +1,235 @@ +; Phase 6 — merge: textual diff3 with conflict markers, per-path 3-way tree +; merge with blob auto-merge, fast-forward/up-to-date detection. + +(define gmg-db (persist/mem-backend)) +(define gmg (git/repo gmg-db)) + +(define + gmg-commit! + (fn + (files parents msg) + (git/write + gmg + (git/commit (git/tree-from-files gmg files) parents {:message msg})))) + +; ---- textual 3-way ---- +(git-test "merge3: untouched" (git/merge3-text "x\n" "x\n" "x\n") {:clean true :text "x\n" :conflicts 0}) +(git-test + "merge3: ours-only change wins" + (get (git/merge3-text "a\nb\n" "a\nB\n" "a\nb\n") :text) + "a\nB\n") +(git-test + "merge3: theirs-only change wins" + (get (git/merge3-text "a\nb\n" "a\nb\n" "a\nB\n") :text) + "a\nB\n") +(git-test + "merge3: identical change on both sides is clean" + (git/merge3-text "a\nb\n" "a\nZ\n" "a\nZ\n") + {:clean true :text "a\nZ\n" :conflicts 0}) +(git-test + "merge3: non-overlapping changes both apply" + (git/merge3-text "a\nb\nc\n" "A\nb\nc\n" "a\nb\nC\n") + {:clean true :text "A\nb\nC\n" :conflicts 0}) +(git-test + "merge3: adjacent line changes merge cleanly" + (get (git/merge3-text "l1\nl2\nl3\nl4\n" "l1\nX\nl3\nl4\n" "l1\nl2\nY\nl4\n") :text) + "l1\nX\nY\nl4\n") +(git-test + "merge3: append and prepend both apply" + (get (git/merge3-text "m\n" "m\ne\n" "s\nm\n") :text) + "s\nm\ne\n") +(git-test + "merge3: clean deletion" + (get (git/merge3-text "a\nb\nc\n" "a\nc\n" "a\nb\nc\n") :text) + "a\nc\n") + +(git-test + "merge3: overlapping edits conflict with diff3 markers" + (git/merge3-text "a\nb\nc\n" "a\nX\nc\n" "a\nY\nc\n") + {:clean false :text "a\n<<<<<<< ours\nX\n||||||| base\nb\n=======\nY\n>>>>>>> theirs\nc\n" :conflicts 1}) +(git-test + "merge3: delete vs modify conflicts" + (git/merge3-text "a\nb\nc\n" "a\nc\n" "a\nY\nc\n") + {:clean false :text "a\n<<<<<<< ours\n||||||| base\nb\n=======\nY\n>>>>>>> theirs\nc\n" :conflicts 1}) +(git-test + "merge3: same-point insertions with different content conflict" + (git/merge3-text "" "A\n" "B\n") + {:clean false :text "<<<<<<< ours\nA\n||||||| base\n=======\nB\n>>>>>>> theirs\n" :conflicts 1}) +(git-test + "merge3: same-point insertions with the same content are clean" + (git/merge3-text "a\n" "a\nx\n" "a\nx\n") + {:clean true :text "a\nx\n" :conflicts 0}) +(git-test + "merge3: two separated conflicts are counted" + (get + (git/merge3-text + "a\nb\nc\nd\ne\nf\ng\nh\ni\n" + "a\nX1\nc\nd\ne\nf\ng\nX2\ni\n" + "a\nY1\nc\nd\ne\nf\ng\nY2\ni\n") + :conflicts) + 2) + +; ---- tree-from-cids ---- +(git-test + "tree-from-cids equals tree-from-files" + (equal? + (git/tree-from-cids + gmg + (assoc + (assoc {} "a.txt" (git/write-blob gmg "1\n")) + "s/b.txt" + (git/write-blob gmg "2\n"))) + (git/tree-from-files + gmg + (assoc (assoc {} "a.txt" "1\n") "s/b.txt" "2\n"))) + true) + +; ---- tree merge ---- +(define + gmg-base-files + (assoc (assoc {} "f.txt" "a\nb\nc\n") "g.txt" "same\n")) +(define gmg-base-tree (git/tree-from-files gmg gmg-base-files)) + +(git-test + "merge-trees: disjoint paths merge clean" + (let + ((ta (git/tree-from-files gmg (assoc gmg-base-files "ours.txt" "o\n"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "theirs.txt" "t\n")))) + (let + ((m (git/merge-trees gmg gmg-base-tree ta tb))) + (list + (get m :conflicts) + (= + (git/tree-files gmg (git/tree-from-cids gmg (get m :files))) + (assoc (assoc gmg-base-files "ours.txt" "o\n") "theirs.txt" "t\n"))))) + (list (list) true)) +(git-test + "merge-trees: same file, non-overlapping lines auto-merge" + (let + ((ta (git/tree-from-files gmg (assoc gmg-base-files "f.txt" "A\nb\nc\n"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "f.txt" "a\nb\nC\n")))) + (let + ((m (git/merge-trees gmg gmg-base-tree ta tb))) + (list + (get m :conflicts) + (git/blob-data (git/read gmg (get (get m :files) "f.txt")))))) + (list (list) "A\nb\nC\n")) +(git-test + "merge-trees: overlapping edits flag the path" + (let + ((ta (git/tree-from-files gmg (assoc gmg-base-files "f.txt" "a\nX\nc\n"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "f.txt" "a\nY\nc\n")))) + (let + ((m (git/merge-trees gmg gmg-base-tree ta tb))) + (= + (list + (get m :conflicts) + (contains? + (git/blob-data (git/read gmg (get (get m :files) "f.txt"))) + "<<<<<<< ours")) + (list (list "f.txt") true)))) + true) +(git-test + "merge-trees: both delete is clean" + (let + ((ta (git/tree-from-files gmg (dissoc gmg-base-files "f.txt"))) + (tb (git/tree-from-files gmg (dissoc gmg-base-files "f.txt")))) + (let + ((m (git/merge-trees gmg gmg-base-tree ta tb))) + (list (get m :conflicts) (has-key? (get m :files) "f.txt")))) + (list (list) false)) +(git-test + "merge-trees: delete vs modify keeps the modified side and flags it" + (let + ((ta (git/tree-from-files gmg (dissoc gmg-base-files "f.txt"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "f.txt" "a\nY\nc\n")))) + (let + ((m (git/merge-trees gmg gmg-base-tree ta tb))) + (= + (list + (get m :conflicts) + (git/blob-data (git/read gmg (get (get m :files) "f.txt")))) + (list (list "f.txt") "a\nY\nc\n")))) + true) +(git-test + "merge-trees: both add the same file identically" + (let + ((ta (git/tree-from-files gmg (assoc gmg-base-files "n.txt" "n\n"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "n.txt" "n\n")))) + (get (git/merge-trees gmg gmg-base-tree ta tb) :conflicts)) + (list)) +(git-test + "merge-trees: both add the same file differently" + (let + ((ta (git/tree-from-files gmg (assoc gmg-base-files "n.txt" "N1\n"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "n.txt" "N2\n")))) + (= + (get (git/merge-trees gmg gmg-base-tree ta tb) :conflicts) + (list "n.txt"))) + true) + +; ---- commit-level ---- +(define gmg-c0 (gmg-commit! gmg-base-files (list) "base")) +(define + gmg-ca + (gmg-commit! (assoc gmg-base-files "f.txt" "A\nb\nc\n") (list gmg-c0) "ours")) +(define + gmg-cb + (gmg-commit! + (assoc gmg-base-files "f.txt" "a\nb\nC\n") + (list gmg-c0) + "theirs")) +(define + gmg-cx + (gmg-commit! (assoc gmg-base-files "f.txt" "a\nX\nc\n") (list gmg-c0) "ox")) +(define + gmg-cy + (gmg-commit! (assoc gmg-base-files "f.txt" "a\nY\nc\n") (list gmg-c0) "oy")) + +(git-test "ff? when ours is behind" (git/ff? gmg gmg-c0 gmg-ca) true) +(git-test "ff? false for diverged heads" (git/ff? gmg gmg-ca gmg-cb) false) +(git-test + "merge-commits: up-to-date when theirs is an ancestor" + (git/merge-commits gmg gmg-ca gmg-c0) + {:cid gmg-ca :result "up-to-date"}) +(git-test + "merge-commits: fast-forward when ours is an ancestor" + (git/merge-commits gmg gmg-c0 gmg-ca) + {:cid gmg-ca :result "fast-forward"}) +(git-test + "merge-commits: clean 3-way produces the merged tree" + (let + ((m (git/merge-commits gmg gmg-ca gmg-cb))) + (list + (get m :result) + (get m :conflicts) + (= + (git/tree-files gmg (get m :tree)) + (assoc gmg-base-files "f.txt" "A\nb\nC\n")))) + (list "merged" (list) true)) +(git-test + "merge-commits: conflicting 3-way reports paths and marker tree" + (let + ((m (git/merge-commits gmg gmg-cx gmg-cy))) + (= + (list + (get m :result) + (get m :conflicts) + (contains? + (get (git/tree-files gmg (get m :tree)) "f.txt") + ">>>>>>> theirs")) + (list "conflicts" (list "f.txt") true))) + true) +(git-test + "merge-commits: unrelated histories merge over an empty base" + (let + ((r1 (gmg-commit! (assoc {} "x.txt" "x\n") (list) "rx")) + (r2 (gmg-commit! (assoc {} "y.txt" "y\n") (list) "ry"))) + (let + ((m (git/merge-commits gmg r1 r2))) + (list + (get m :result) + (= + (git/tree-files gmg (get m :tree)) + (assoc (assoc {} "x.txt" "x\n") "y.txt" "y\n"))))) + (list "merged" true))