sx-git Phase 7: porcelain — init/add/commit/branch/checkout/tag/reset/merge/log/diff (TDD)
End-to-end topology story: fork, diverge, real merge commit (parents in order), fast-forward + up-to-date, annotated + lightweight tags, soft/mixed reset, detached HEAD commits, staged/unstaged unified diffs. Conflicted merges park MERGE_HEAD + stage the marker tree; git/merge-commit! concludes with two parents after resolution. Extensible commit meta flows through porcelain (agentic-sx shape verified). 40/40 — ROADMAP COMPLETE 227/227. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
241
lib/git/porcelain.sx
Normal file
241
lib/git/porcelain.sx
Normal file
@@ -0,0 +1,241 @@
|
||||
; lib/git/porcelain.sx — sx-git Phase 7: the user-facing verbs.
|
||||
; init/add/commit/branch/checkout/tag/reset/merge/log/diff composed from
|
||||
; object+ref+dag+worktree+diff+merge. Branch advances go through ref CAS.
|
||||
; A conflicted merge parks the other head in <prefix>/MERGE_HEAD (like git's
|
||||
; MERGE_HEAD) and stages the marker tree; resolve with git/add! then
|
||||
; git/merge-commit!, which writes the two-parent commit and clears it.
|
||||
; Requires: all previous lib/git modules.
|
||||
|
||||
(define
|
||||
git/init!
|
||||
(fn
|
||||
(db name)
|
||||
(let
|
||||
((repo (git/repo-named db name)))
|
||||
(begin (git/head-set! repo "main") (git/index-init! repo nil) repo))))
|
||||
|
||||
; advance whatever HEAD points at: the branch via CAS, or the detached pin
|
||||
(define
|
||||
git/porc-advance!
|
||||
(fn
|
||||
(repo old new)
|
||||
(let
|
||||
((target (git/head-target repo)))
|
||||
(if
|
||||
(equal? target nil)
|
||||
(git/head-detach! repo new)
|
||||
(git/ref-cas! repo target old new)))))
|
||||
|
||||
; commit the index; parent = current HEAD (none on an unborn branch)
|
||||
(define
|
||||
git/commit!
|
||||
(fn
|
||||
(repo meta)
|
||||
(let
|
||||
((tree (git/index-tree! repo)))
|
||||
(let
|
||||
((parent (git/head repo)))
|
||||
(let
|
||||
((cid (git/write repo (git/commit tree (if (equal? parent nil) (list) (list parent)) meta))))
|
||||
(begin
|
||||
(git/porc-advance! repo parent cid)
|
||||
(git/index-write! repo {:base tree :staged {}})
|
||||
cid))))))
|
||||
|
||||
; branch at HEAD (create-only)
|
||||
(define
|
||||
git/branch!
|
||||
(fn (repo name) (git/branch-create! repo name (git/head repo))))
|
||||
|
||||
; switch HEAD + index to a branch; returns the materialized files dict
|
||||
(define
|
||||
git/checkout!
|
||||
(fn
|
||||
(repo branch)
|
||||
(let
|
||||
((cid (git/branch-get repo branch)))
|
||||
(begin
|
||||
(git/head-set! repo branch)
|
||||
(git/index-init! repo cid)
|
||||
(if (equal? cid nil) {} (git/commit-files repo cid))))))
|
||||
|
||||
(define
|
||||
git/checkout-detached!
|
||||
(fn
|
||||
(repo cid)
|
||||
(begin
|
||||
(git/head-detach! repo cid)
|
||||
(git/index-init! repo cid)
|
||||
(git/commit-files repo cid))))
|
||||
|
||||
; annotated tag: tag OBJECT at HEAD, ref points at the tag object
|
||||
(define
|
||||
git/tag!
|
||||
(fn
|
||||
(repo name meta)
|
||||
(let
|
||||
((cid (git/write repo (git/tag (git/head repo) name meta))))
|
||||
(begin (git/tag-set! repo name cid) cid))))
|
||||
|
||||
(define
|
||||
git/tag-lightweight!
|
||||
(fn
|
||||
(repo name)
|
||||
(begin (git/tag-set! repo name (git/head repo)) (git/head repo))))
|
||||
|
||||
; reset current branch to cid; "soft" keeps the index, "mixed" resets it
|
||||
(define
|
||||
git/reset!
|
||||
(fn
|
||||
(repo cid mode)
|
||||
(begin
|
||||
(git/porc-advance! repo (git/head repo) cid)
|
||||
(when (equal? mode "mixed") (git/index-init! repo cid))
|
||||
cid)))
|
||||
|
||||
; ---- merge a branch into HEAD ----
|
||||
(define
|
||||
git/merge-head-key
|
||||
(fn (repo) (str (get repo :prefix) "/MERGE_HEAD")))
|
||||
(define
|
||||
git/merge-in-progress?
|
||||
(fn
|
||||
(repo)
|
||||
(not
|
||||
(equal? (persist/kv-get (get repo :db) (git/merge-head-key repo)) nil))))
|
||||
|
||||
(define
|
||||
git/merge!
|
||||
(fn
|
||||
(repo branch meta)
|
||||
(let
|
||||
((ours (git/head repo)) (theirs (git/branch-get repo branch)))
|
||||
(let
|
||||
((m (git/merge-commits repo ours theirs)))
|
||||
(cond
|
||||
((equal? (get m :result) "up-to-date") m)
|
||||
((equal? (get m :result) "fast-forward")
|
||||
(begin
|
||||
(git/porc-advance! repo ours theirs)
|
||||
(git/index-init! repo theirs)
|
||||
m))
|
||||
((equal? (get m :result) "merged")
|
||||
(let
|
||||
((cid (git/write repo (git/commit (get m :tree) (list ours theirs) meta))))
|
||||
(begin
|
||||
(git/porc-advance! repo ours cid)
|
||||
(git/index-write! repo {:base (get m :tree) :staged {}})
|
||||
{:conflicts (list) :cid cid :result "merged"})))
|
||||
(else
|
||||
(begin
|
||||
(persist/kv-put
|
||||
(get repo :db)
|
||||
(git/merge-head-key repo)
|
||||
theirs)
|
||||
(git/index-write! repo {:base (get m :tree) :staged {}})
|
||||
m)))))))
|
||||
|
||||
; conclude a conflicted merge: commit the (resolved) index with two parents
|
||||
(define
|
||||
git/merge-commit!
|
||||
(fn
|
||||
(repo meta)
|
||||
(let
|
||||
((theirs (persist/kv-get (get repo :db) (git/merge-head-key repo))))
|
||||
(if
|
||||
(equal? theirs nil)
|
||||
{:error "no merge in progress"}
|
||||
(let
|
||||
((tree (git/index-tree! repo)))
|
||||
(let
|
||||
((parent (git/head repo)))
|
||||
(let
|
||||
((cid (git/write repo (git/commit tree (list parent theirs) meta))))
|
||||
(begin
|
||||
(git/porc-advance! repo parent cid)
|
||||
(git/index-write! repo {:base tree :staged {}})
|
||||
(persist/kv-delete (get repo :db) (git/merge-head-key repo))
|
||||
cid))))))))
|
||||
|
||||
; ---- porcelain diff/log ----
|
||||
(define
|
||||
git/log-branch
|
||||
(fn (repo branch) (git/log repo (git/branch-get repo branch))))
|
||||
|
||||
; unified diff across two path->data dicts (added, deleted, then modified)
|
||||
(define
|
||||
git/diff-files-unified
|
||||
(fn
|
||||
(fa fb)
|
||||
(let
|
||||
((d (git/files-diff (git/files-cids fa) (git/files-cids fb))))
|
||||
(str
|
||||
(reduce
|
||||
(fn
|
||||
(acc p)
|
||||
(str
|
||||
acc
|
||||
"diff --sx a/"
|
||||
p
|
||||
" b/"
|
||||
p
|
||||
"\n--- /dev/null\n+++ b/"
|
||||
p
|
||||
"\n"
|
||||
(git/diff-unified "" (get fb p))))
|
||||
""
|
||||
(get d :added))
|
||||
(reduce
|
||||
(fn
|
||||
(acc p)
|
||||
(str
|
||||
acc
|
||||
"diff --sx a/"
|
||||
p
|
||||
" b/"
|
||||
p
|
||||
"\n--- a/"
|
||||
p
|
||||
"\n+++ /dev/null\n"
|
||||
(git/diff-unified (get fa p) "")))
|
||||
""
|
||||
(get d :deleted))
|
||||
(reduce
|
||||
(fn
|
||||
(acc p)
|
||||
(str
|
||||
acc
|
||||
"diff --sx a/"
|
||||
p
|
||||
" b/"
|
||||
p
|
||||
"\n--- a/"
|
||||
p
|
||||
"\n+++ b/"
|
||||
p
|
||||
"\n"
|
||||
(git/diff-unified (get fa p) (get fb p))))
|
||||
""
|
||||
(get d :modified))))))
|
||||
|
||||
(define
|
||||
git/porc-head-files
|
||||
(fn
|
||||
(repo)
|
||||
(let
|
||||
((h (git/head repo)))
|
||||
(if (equal? h nil) {} (git/commit-files repo h)))))
|
||||
|
||||
; staged: HEAD vs index; unstaged: index vs the caller's worktree value
|
||||
(define
|
||||
git/diff-staged
|
||||
(fn
|
||||
(repo)
|
||||
(git/diff-files-unified
|
||||
(git/porc-head-files repo)
|
||||
(git/index-files repo))))
|
||||
(define
|
||||
git/diff-unstaged
|
||||
(fn
|
||||
(repo worktree-files)
|
||||
(git/diff-files-unified (git/index-files repo) worktree-files)))
|
||||
Reference in New Issue
Block a user