rose-ash/lib/git/merge.sx

; 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"}))))))))