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:
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