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:
@@ -13,7 +13,7 @@ if [ ! -x "$SX_SERVER" ]; then
|
||||
exit 1
|
||||
fi
|
||||
|
||||
SUITES=(object ref dag worktree diff merge)
|
||||
SUITES=(object ref dag worktree diff merge porcelain)
|
||||
|
||||
OUT_JSON="lib/git/scoreboard.json"
|
||||
OUT_MD="lib/git/scoreboard.md"
|
||||
@@ -48,6 +48,7 @@ run_suite() {
|
||||
(load "lib/git/worktree.sx")
|
||||
(load "lib/git/diff.sx")
|
||||
(load "lib/git/merge.sx")
|
||||
(load "lib/git/porcelain.sx")
|
||||
(epoch 2)
|
||||
(eval "(define git-test-pass 0)")
|
||||
(eval "(define git-test-fail 0)")
|
||||
|
||||
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)))
|
||||
@@ -5,9 +5,10 @@
|
||||
"dag": {"pass": 30, "fail": 0},
|
||||
"worktree": {"pass": 26, "fail": 0},
|
||||
"diff": {"pass": 27, "fail": 0},
|
||||
"merge": {"pass": 28, "fail": 0}
|
||||
"merge": {"pass": 28, "fail": 0},
|
||||
"porcelain": {"pass": 40, "fail": 0}
|
||||
},
|
||||
"total_pass": 187,
|
||||
"total_pass": 227,
|
||||
"total_fail": 0,
|
||||
"total": 187
|
||||
"total": 227
|
||||
}
|
||||
|
||||
@@ -10,4 +10,5 @@ _Generated by `lib/git/conformance.sh`_
|
||||
| worktree | 26 | 0 | 26 |
|
||||
| diff | 27 | 0 | 27 |
|
||||
| merge | 28 | 0 | 28 |
|
||||
| **Total** | **187** | **0** | **187** |
|
||||
| porcelain | 40 | 0 | 40 |
|
||||
| **Total** | **227** | **0** | **227** |
|
||||
|
||||
261
lib/git/tests/porcelain.sx
Normal file
261
lib/git/tests/porcelain.sx
Normal file
@@ -0,0 +1,261 @@
|
||||
; Phase 7 — porcelain: init/add/commit/branch/checkout/tag/reset/merge/log/diff
|
||||
; as one end-to-end topology story, plus the conflicted-merge flow.
|
||||
|
||||
(define gpc-db (persist/mem-backend))
|
||||
(define gpc (git/init! gpc-db "proj"))
|
||||
|
||||
; ---- init ----
|
||||
(git-test
|
||||
"init points HEAD at an unborn main"
|
||||
(git/head-target gpc)
|
||||
"heads/main")
|
||||
(git-test "init has no commits yet" (git/head gpc) nil)
|
||||
(git-test
|
||||
"init status is clean and empty"
|
||||
(= (git/status gpc {}) {:untracked (list) :staged {:deleted (list) :modified (list) :added (list)} :unstaged {:deleted (list) :modified (list)}})
|
||||
true)
|
||||
|
||||
; ---- first commit on main ----
|
||||
(git-test
|
||||
"staged files show before the first commit"
|
||||
(begin
|
||||
(git/add! gpc "README.md" "hello\n")
|
||||
(git/add! gpc "src/main.sx" "(main)\n")
|
||||
(=
|
||||
(get (get (git/status gpc {}) :staged) :added)
|
||||
(list "README.md" "src/main.sx")))
|
||||
true)
|
||||
|
||||
(define gpc-c1 (git/commit! gpc {:message "c1" :author "ada"}))
|
||||
|
||||
(git-test "commit! advances HEAD through main" (git/head gpc) gpc-c1)
|
||||
(git-test "commit! moved the branch ref" (git/branch-get gpc "main") gpc-c1)
|
||||
(git-test
|
||||
"the commit carries the author"
|
||||
(git/commit-author (git/read gpc gpc-c1))
|
||||
"ada")
|
||||
(git-test
|
||||
"first commit has no parents"
|
||||
(= (git/commit-parents (git/read gpc gpc-c1)) (list))
|
||||
true)
|
||||
(git-test
|
||||
"commit materializes the staged files"
|
||||
(=
|
||||
(git/commit-files gpc gpc-c1)
|
||||
(assoc (assoc {} "README.md" "hello\n") "src/main.sx" "(main)\n"))
|
||||
true)
|
||||
(git-test "after commit! the index is clean" (git/diff-staged gpc) "")
|
||||
(git-test
|
||||
"extensible meta flows through porcelain"
|
||||
(let
|
||||
((r (git/init! (persist/mem-backend) "x")))
|
||||
(begin
|
||||
(git/add! r "f" "1\n")
|
||||
(get (git/read r (git/commit! r {:message "m" :agent "claude-fable"})) :agent)))
|
||||
"claude-fable")
|
||||
|
||||
; ---- branch + checkout ----
|
||||
(git-test "branch! forks at HEAD" (git/branch! gpc "feature") gpc-c1)
|
||||
(git-test
|
||||
"checkout! returns the materialized worktree"
|
||||
(= (git/checkout! gpc "feature") (git/commit-files gpc gpc-c1))
|
||||
true)
|
||||
(git-test "checkout! retargets HEAD" (git/head-target gpc) "heads/feature")
|
||||
|
||||
(define
|
||||
gpc-c2
|
||||
(begin
|
||||
(git/add! gpc "src/feature.sx" "(feature)\n")
|
||||
(git/commit! gpc {:message "c2" :author "ada"})))
|
||||
|
||||
(git-test
|
||||
"feature moved, main did not"
|
||||
(=
|
||||
(list (git/branch-get gpc "feature") (git/branch-get gpc "main"))
|
||||
(list gpc-c2 gpc-c1))
|
||||
true)
|
||||
(git-test
|
||||
"checkout back to main drops the feature file"
|
||||
(has-key? (git/checkout! gpc "main") "src/feature.sx")
|
||||
false)
|
||||
|
||||
(define
|
||||
gpc-c3
|
||||
(begin
|
||||
(git/add! gpc "README.md" "hello\nworld\n")
|
||||
(git/commit! gpc {:message "c3" :author "ada"})))
|
||||
|
||||
; ---- real merge ----
|
||||
(define gpc-m (git/merge! gpc "feature" {:message "merge feature" :author "ada"}))
|
||||
|
||||
(git-test
|
||||
"diverged branches produce a merge commit"
|
||||
(get gpc-m :result)
|
||||
"merged")
|
||||
(git-test
|
||||
"merge commit has both parents in order"
|
||||
(=
|
||||
(git/commit-parents (git/read gpc (get gpc-m :cid)))
|
||||
(list gpc-c3 gpc-c2))
|
||||
true)
|
||||
(git-test
|
||||
"merge result is where HEAD is now"
|
||||
(git/head gpc)
|
||||
(get gpc-m :cid))
|
||||
(git-test
|
||||
"merged tree unions both changes"
|
||||
(=
|
||||
(git/commit-files gpc (git/head gpc))
|
||||
(assoc
|
||||
(assoc
|
||||
(assoc {} "README.md" "hello\nworld\n")
|
||||
"src/main.sx"
|
||||
"(main)\n")
|
||||
"src/feature.sx"
|
||||
"(feature)\n"))
|
||||
true)
|
||||
(git-test "no merge left in progress" (git/merge-in-progress? gpc) false)
|
||||
(git-test
|
||||
"log walks the merged topology newest-first"
|
||||
(=
|
||||
(git/log-messages gpc (git/head gpc))
|
||||
(list "merge feature" "c2" "c3" "c1"))
|
||||
true)
|
||||
(git-test
|
||||
"merge-base of the two legs is the fork point"
|
||||
(git/merge-base gpc gpc-c2 gpc-c3)
|
||||
gpc-c1)
|
||||
|
||||
; ---- fast-forward + up-to-date ----
|
||||
(define gpc-c4 (get gpc-m :cid))
|
||||
(define
|
||||
gpc-c5
|
||||
(begin
|
||||
(git/branch! gpc "hotfix")
|
||||
(git/checkout! gpc "hotfix")
|
||||
(git/add! gpc "fix.txt" "patched\n")
|
||||
(git/commit! gpc {:message "c5" :author "ada"})))
|
||||
|
||||
(git-test
|
||||
"merging a descendant fast-forwards"
|
||||
(begin
|
||||
(git/checkout! gpc "main")
|
||||
(get (git/merge! gpc "hotfix" {:message "unused"}) :result))
|
||||
"fast-forward")
|
||||
(git-test
|
||||
"fast-forward moved main to the hotfix tip"
|
||||
(git/branch-get gpc "main")
|
||||
gpc-c5)
|
||||
(git-test
|
||||
"merging it again is up-to-date"
|
||||
(get (git/merge! gpc "hotfix" {:message "unused"}) :result)
|
||||
"up-to-date")
|
||||
|
||||
; ---- tags ----
|
||||
(git-test
|
||||
"tag! writes an annotated tag object at HEAD"
|
||||
(begin
|
||||
(git/tag! gpc "v1" {:tagger "ada"})
|
||||
(git/tag-target (git/read gpc (git/tag-get gpc "v1"))))
|
||||
gpc-c5)
|
||||
(git-test
|
||||
"lightweight tag points straight at the commit"
|
||||
(begin (git/tag-lightweight! gpc "tip") (git/tag-get gpc "tip"))
|
||||
gpc-c5)
|
||||
|
||||
; ---- reset ----
|
||||
(git-test
|
||||
"soft reset moves the branch but keeps the index"
|
||||
(begin
|
||||
(git/reset! gpc gpc-c4 "soft")
|
||||
(list (git/head gpc) (contains? (git/diff-staged gpc) "+patched")))
|
||||
(list gpc-c4 true))
|
||||
(git-test
|
||||
"mixed reset also resets the index"
|
||||
(begin
|
||||
(git/reset! gpc gpc-c5 "mixed")
|
||||
(list (git/head gpc) (git/diff-staged gpc)))
|
||||
(list gpc-c5 ""))
|
||||
|
||||
; ---- detached HEAD ----
|
||||
(git-test
|
||||
"detached checkout pins the cid"
|
||||
(begin
|
||||
(git/checkout-detached! gpc gpc-c1)
|
||||
(list (git/detached? gpc) (git/head gpc)))
|
||||
(list true gpc-c1))
|
||||
(git-test
|
||||
"committing while detached moves only the pin"
|
||||
(let
|
||||
((c6 (begin (git/add! gpc "scratch.txt" "s\n") (git/commit! gpc {:message "c6"}))))
|
||||
(list (git/head gpc) (git/branch-get gpc "main")))
|
||||
(list (git/head gpc) gpc-c5))
|
||||
(git-test
|
||||
"checkout! reattaches to a branch"
|
||||
(begin (git/checkout! gpc "main") (git/head-target gpc))
|
||||
"heads/main")
|
||||
|
||||
; ---- unstaged diff ----
|
||||
(git-test
|
||||
"diff-unstaged renders worktree edits"
|
||||
(contains?
|
||||
(git/diff-unstaged
|
||||
gpc
|
||||
(assoc (git/commit-files gpc (git/head gpc)) "fix.txt" "patched\nedit\n"))
|
||||
"+edit")
|
||||
true)
|
||||
|
||||
; ---- conflicted merge flow ----
|
||||
(define gcf (git/init! (persist/mem-backend) "cf"))
|
||||
(define
|
||||
gcf-c1
|
||||
(begin (git/add! gcf "f.txt" "a\nb\nc\n") (git/commit! gcf {:message "base"})))
|
||||
(define
|
||||
gcf-c2
|
||||
(begin
|
||||
(git/branch! gcf "left")
|
||||
(git/add! gcf "f.txt" "a\nX\nc\n")
|
||||
(git/commit! gcf {:message "ours"})))
|
||||
(define
|
||||
gcf-c3
|
||||
(begin
|
||||
(git/checkout! gcf "left")
|
||||
(git/add! gcf "f.txt" "a\nY\nc\n")
|
||||
(git/commit! gcf {:message "theirs"})))
|
||||
(define
|
||||
gcf-m
|
||||
(begin (git/checkout! gcf "main") (git/merge! gcf "left" {:message "m"})))
|
||||
|
||||
(git-test
|
||||
"conflicting merge reports the paths"
|
||||
(=
|
||||
(list (get gcf-m :result) (get gcf-m :conflicts))
|
||||
(list "conflicts" (list "f.txt")))
|
||||
true)
|
||||
(git-test
|
||||
"a conflicted merge is in progress"
|
||||
(git/merge-in-progress? gcf)
|
||||
true)
|
||||
(git-test
|
||||
"the conflicted file is staged with markers"
|
||||
(contains? (get (git/index-files gcf) "f.txt") "<<<<<<< ours")
|
||||
true)
|
||||
(git-test "HEAD did not move on conflict" (git/head gcf) gcf-c2)
|
||||
(git-test
|
||||
"merge-commit! concludes with two parents"
|
||||
(begin
|
||||
(git/add! gcf "f.txt" "a\nXY\nc\n")
|
||||
(let
|
||||
((mc (git/merge-commit! gcf {:message "resolved"})))
|
||||
(=
|
||||
(list
|
||||
(git/head gcf)
|
||||
(git/commit-parents (git/read gcf mc))
|
||||
(get (git/commit-files gcf mc) "f.txt")
|
||||
(git/merge-in-progress? gcf))
|
||||
(list mc (list gcf-c2 gcf-c3) "a\nXY\nc\n" false))))
|
||||
true)
|
||||
(git-test
|
||||
"merge-commit! without a merge in progress errors"
|
||||
(get (git/merge-commit! gcf {:message "x"}) :error)
|
||||
"no merge in progress")
|
||||
Reference in New Issue
Block a user