sx-git Phase 4: worktree — tree materialization, index overlay, status (TDD)
Worktree is a value (path->data dict). tree-from-files/tree-files round-trip
through real tree objects (cid-identical to hand-built trees); index =
{:base tree-cid :staged overlay} in kv with add!/rm!/unstage!/index-tree!;
status = three-way dict diff (HEAD vs index vs worktree) with
staged/unstaged/untracked. 26/26, total 132/132.
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)
|
||||
SUITES=(object ref dag worktree)
|
||||
|
||||
OUT_JSON="lib/git/scoreboard.json"
|
||||
OUT_MD="lib/git/scoreboard.md"
|
||||
@@ -45,6 +45,7 @@ run_suite() {
|
||||
(load "lib/git/object.sx")
|
||||
(load "lib/git/ref.sx")
|
||||
(load "lib/git/dag.sx")
|
||||
(load "lib/git/worktree.sx")
|
||||
(epoch 2)
|
||||
(eval "(define git-test-pass 0)")
|
||||
(eval "(define git-test-fail 0)")
|
||||
|
||||
@@ -2,9 +2,10 @@
|
||||
"suites": {
|
||||
"object": {"pass": 38, "fail": 0},
|
||||
"ref": {"pass": 38, "fail": 0},
|
||||
"dag": {"pass": 30, "fail": 0}
|
||||
"dag": {"pass": 30, "fail": 0},
|
||||
"worktree": {"pass": 26, "fail": 0}
|
||||
},
|
||||
"total_pass": 106,
|
||||
"total_pass": 132,
|
||||
"total_fail": 0,
|
||||
"total": 106
|
||||
"total": 132
|
||||
}
|
||||
|
||||
@@ -7,4 +7,5 @@ _Generated by `lib/git/conformance.sh`_
|
||||
| object | 38 | 0 | 38 |
|
||||
| ref | 38 | 0 | 38 |
|
||||
| dag | 30 | 0 | 30 |
|
||||
| **Total** | **106** | **0** | **106** |
|
||||
| worktree | 26 | 0 | 26 |
|
||||
| **Total** | **132** | **0** | **132** |
|
||||
|
||||
253
lib/git/tests/worktree.sx
Normal file
253
lib/git/tests/worktree.sx
Normal file
@@ -0,0 +1,253 @@
|
||||
; Phase 4 — worktree: tree materialization (files-dict <-> tree objects),
|
||||
; index as staged-tree overlay, three-way status.
|
||||
|
||||
(define gwt-db (persist/mem-backend))
|
||||
(define gwt (git/repo gwt-db))
|
||||
|
||||
(define
|
||||
gwt-files
|
||||
(assoc
|
||||
(assoc (assoc {} "a.txt" "hello\n") "b.txt" "world\n")
|
||||
"sub/c.txt"
|
||||
"sub\n"))
|
||||
|
||||
(define gwt-tree (git/tree-from-files gwt gwt-files))
|
||||
(define gwt-c1 (git/write gwt (git/commit gwt-tree (list) {:message "c1"})))
|
||||
|
||||
; fresh repo with the fixture committed, HEAD on main, index clean
|
||||
(define
|
||||
gwt-fresh!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((r (git/repo (persist/mem-backend))))
|
||||
(let
|
||||
((tc (git/tree-from-files r gwt-files)))
|
||||
(let
|
||||
((c (git/write r (git/commit tc (list) {:message "c1"}))))
|
||||
(begin
|
||||
(git/branch-set! r "main" c)
|
||||
(git/head-set! r "main")
|
||||
(git/index-init! r c)
|
||||
r))))))
|
||||
|
||||
(define gwt-clean {:untracked (list) :staged {:deleted (list) :modified (list) :added (list)} :unstaged {:deleted (list) :modified (list)}})
|
||||
|
||||
; ---- tree building + materialization ----
|
||||
(git-test
|
||||
"tree-from-files writes a tree object"
|
||||
(git/tree? (git/read gwt gwt-tree))
|
||||
true)
|
||||
(git-test
|
||||
"tree-files round-trips the files dict"
|
||||
(= (git/tree-files gwt gwt-tree) gwt-files)
|
||||
true)
|
||||
(git-test
|
||||
"tree-from-files is deterministic"
|
||||
(equal? (git/tree-from-files gwt gwt-files) gwt-tree)
|
||||
true)
|
||||
(git-test
|
||||
"matches a manually built tree"
|
||||
(equal?
|
||||
(git/write
|
||||
gwt
|
||||
(git/tree
|
||||
(assoc
|
||||
(assoc
|
||||
(assoc
|
||||
{}
|
||||
"a.txt"
|
||||
(git/tree-entry "blob" (git/write-blob gwt "hello\n")))
|
||||
"b.txt"
|
||||
(git/tree-entry "blob" (git/write-blob gwt "world\n")))
|
||||
"sub"
|
||||
(git/tree-entry
|
||||
"tree"
|
||||
(git/write
|
||||
gwt
|
||||
(git/tree
|
||||
(assoc
|
||||
{}
|
||||
"c.txt"
|
||||
(git/tree-entry "blob" (git/write-blob gwt "sub\n")))))))))
|
||||
gwt-tree)
|
||||
true)
|
||||
(git-test
|
||||
"flatten lists nested paths"
|
||||
(=
|
||||
(artdag/sort-strings (keys (git/tree-flatten gwt gwt-tree)))
|
||||
(list "a.txt" "b.txt" "sub/c.txt"))
|
||||
true)
|
||||
(git-test
|
||||
"flatten maps a path to its blob cid"
|
||||
(get (git/tree-flatten gwt gwt-tree) "a.txt")
|
||||
(git/cid (git/blob "hello\n")))
|
||||
(git-test
|
||||
"commit-files materializes through the commit"
|
||||
(= (git/commit-files gwt gwt-c1) gwt-files)
|
||||
true)
|
||||
(git-test
|
||||
"deep nesting round-trips"
|
||||
(let
|
||||
((files (assoc {} "x/y/z.txt" "deep")))
|
||||
(= (git/tree-files gwt (git/tree-from-files gwt files)) files))
|
||||
true)
|
||||
(git-test
|
||||
"empty files dict is an empty tree"
|
||||
(= (git/tree-files gwt (git/tree-from-files gwt {})) {})
|
||||
true)
|
||||
|
||||
; ---- index ----
|
||||
(git-test
|
||||
"default index is empty over no base"
|
||||
(= (git/index-read (git/repo (persist/mem-backend))) {:base nil :staged {}})
|
||||
true)
|
||||
(git-test
|
||||
"index-init! bases the index on the commit tree"
|
||||
(let ((r (gwt-fresh!))) (= (git/index-files r) gwt-files))
|
||||
true)
|
||||
(git-test
|
||||
"add! stages new content"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(begin
|
||||
(git/add! r "new.txt" "fresh")
|
||||
(get (git/index-files r) "new.txt")))
|
||||
"fresh")
|
||||
(git-test
|
||||
"add! overlays an existing path"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(begin (git/add! r "a.txt" "changed") (get (git/index-files r) "a.txt")))
|
||||
"changed")
|
||||
(git-test
|
||||
"rm! stages a removal"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(begin (git/rm! r "b.txt") (has-key? (git/index-files r) "b.txt")))
|
||||
false)
|
||||
(git-test
|
||||
"unstage! reverts to the base"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(begin
|
||||
(git/add! r "a.txt" "changed")
|
||||
(git/unstage! r "a.txt")
|
||||
(get (git/index-files r) "a.txt")))
|
||||
"hello\n")
|
||||
(git-test
|
||||
"index-tree! of a clean index reproduces the commit tree cid"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(equal?
|
||||
(git/index-tree! r)
|
||||
(git/commit-tree (git/read r (git/head r)))))
|
||||
true)
|
||||
(git-test
|
||||
"index-tree! materializes staged changes"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(begin
|
||||
(git/add! r "a.txt" "changed")
|
||||
(git/rm! r "b.txt")
|
||||
(=
|
||||
(git/tree-files r (git/index-tree! r))
|
||||
(assoc (assoc {} "a.txt" "changed") "sub/c.txt" "sub\n"))))
|
||||
true)
|
||||
|
||||
; ---- status ----
|
||||
(git-test
|
||||
"clean repo, clean worktree"
|
||||
(= (git/status (gwt-fresh!) gwt-files) gwt-clean)
|
||||
true)
|
||||
(git-test
|
||||
"staged addition"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(begin
|
||||
(git/add! r "new.txt" "fresh")
|
||||
(=
|
||||
(get (get (git/status r gwt-files) :staged) :added)
|
||||
(list "new.txt"))))
|
||||
true)
|
||||
(git-test
|
||||
"staged modification"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(begin
|
||||
(git/add! r "a.txt" "changed")
|
||||
(=
|
||||
(get
|
||||
(get (git/status r (assoc gwt-files "a.txt" "changed")) :staged)
|
||||
:modified)
|
||||
(list "a.txt"))))
|
||||
true)
|
||||
(git-test
|
||||
"staged deletion"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(begin
|
||||
(git/rm! r "b.txt")
|
||||
(=
|
||||
(get
|
||||
(get (git/status r (dissoc gwt-files "b.txt")) :staged)
|
||||
:deleted)
|
||||
(list "b.txt"))))
|
||||
true)
|
||||
(git-test
|
||||
"unstaged modification"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(=
|
||||
(get
|
||||
(get (git/status r (assoc gwt-files "a.txt" "edited")) :unstaged)
|
||||
:modified)
|
||||
(list "a.txt")))
|
||||
true)
|
||||
(git-test
|
||||
"unstaged deletion"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(=
|
||||
(get
|
||||
(get (git/status r (dissoc gwt-files "sub/c.txt")) :unstaged)
|
||||
:deleted)
|
||||
(list "sub/c.txt")))
|
||||
true)
|
||||
(git-test
|
||||
"untracked file"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(=
|
||||
(get (git/status r (assoc gwt-files "notes.md" "hi")) :untracked)
|
||||
(list "notes.md")))
|
||||
true)
|
||||
(git-test
|
||||
"combined status"
|
||||
(let
|
||||
((r (gwt-fresh!)))
|
||||
(begin
|
||||
(git/add! r "staged.txt" "s")
|
||||
(git/add! r "a.txt" "changed")
|
||||
(git/rm! r "b.txt")
|
||||
(=
|
||||
(git/status
|
||||
r
|
||||
(assoc
|
||||
(assoc
|
||||
(assoc
|
||||
(dissoc (dissoc gwt-files "b.txt") "sub/c.txt")
|
||||
"a.txt"
|
||||
"changed-again")
|
||||
"staged.txt"
|
||||
"s")
|
||||
"wild.txt"
|
||||
"w"))
|
||||
{:untracked (list "wild.txt") :staged {:deleted (list "b.txt") :modified (list "a.txt") :added (list "staged.txt")} :unstaged {:deleted (list "sub/c.txt") :modified (list "a.txt")}})))
|
||||
true)
|
||||
(git-test
|
||||
"no HEAD, no index: everything untracked"
|
||||
(let
|
||||
((r (git/repo (persist/mem-backend))))
|
||||
(= (git/status r (assoc {} "f.txt" "x")) {:untracked (list "f.txt") :staged {:deleted (list) :modified (list) :added (list)} :unstaged {:deleted (list) :modified (list)}}))
|
||||
true)
|
||||
234
lib/git/worktree.sx
Normal file
234
lib/git/worktree.sx
Normal file
@@ -0,0 +1,234 @@
|
||||
; lib/git/worktree.sx — sx-git Phase 4: tree materialization, index, status.
|
||||
; The "worktree" is a VALUE: a dict of path -> file data (no filesystem).
|
||||
; The index is a staged-tree overlay {:base <tree-cid|nil> :staged
|
||||
; {path -> {:data d} | {:removed true}}} stored in kv at <prefix>/index.
|
||||
; status = three-way dict diff: HEAD tree vs index vs worktree.
|
||||
; Requires: lib/git/object.sx, lib/git/ref.sx.
|
||||
|
||||
(define
|
||||
git/wt-join
|
||||
(fn
|
||||
(segs)
|
||||
(if
|
||||
(empty? segs)
|
||||
""
|
||||
(reduce (fn (acc s) (str acc "/" s)) (first segs) (rest segs)))))
|
||||
|
||||
; ---- tree flattening: tree-cid -> dict path -> blob cid ----
|
||||
(define
|
||||
git/wt-flatten-into
|
||||
(fn
|
||||
(repo tree-cid prefix acc)
|
||||
(let
|
||||
((tree (git/read repo tree-cid)))
|
||||
(reduce
|
||||
(fn
|
||||
(a name)
|
||||
(let
|
||||
((e (git/tree-entry-for tree name)))
|
||||
(let
|
||||
((path (if (equal? prefix "") name (str prefix "/" name))))
|
||||
(if
|
||||
(equal? (git/entry-kind e) "tree")
|
||||
(git/wt-flatten-into repo (git/entry-cid e) path a)
|
||||
(assoc a path (git/entry-cid e))))))
|
||||
acc
|
||||
(git/tree-names tree)))))
|
||||
|
||||
(define
|
||||
git/tree-flatten
|
||||
(fn (repo tree-cid) (git/wt-flatten-into repo tree-cid "" {})))
|
||||
|
||||
; ---- materialization: tree/commit -> dict path -> data ----
|
||||
(define
|
||||
git/tree-files
|
||||
(fn
|
||||
(repo tree-cid)
|
||||
(let
|
||||
((flat (git/tree-flatten repo tree-cid)))
|
||||
(reduce
|
||||
(fn
|
||||
(a p)
|
||||
(assoc a p (git/blob-data (git/read repo (get flat p)))))
|
||||
{}
|
||||
(keys flat)))))
|
||||
|
||||
(define
|
||||
git/commit-files
|
||||
(fn
|
||||
(repo commit-cid)
|
||||
(git/tree-files repo (git/commit-tree (git/read repo commit-cid)))))
|
||||
|
||||
; ---- inverse: dict path -> data => written tree, returns root tree cid ----
|
||||
(define
|
||||
git/wt-group
|
||||
(fn
|
||||
(files)
|
||||
(reduce
|
||||
(fn
|
||||
(acc path)
|
||||
(let
|
||||
((segs (split path "/")))
|
||||
(if
|
||||
(= (len segs) 1)
|
||||
(assoc
|
||||
acc
|
||||
:files (assoc (get acc :files) path (get files path)))
|
||||
(let
|
||||
((dir (first segs)))
|
||||
(let
|
||||
((cur (get (get acc :dirs) dir)))
|
||||
(assoc
|
||||
acc
|
||||
:dirs (assoc
|
||||
(get acc :dirs)
|
||||
dir
|
||||
(assoc
|
||||
(if (dict? cur) cur {})
|
||||
(git/wt-join (rest segs))
|
||||
(get files path)))))))))
|
||||
{:files {} :dirs {}}
|
||||
(keys files))))
|
||||
|
||||
(define
|
||||
git/tree-from-files
|
||||
(fn
|
||||
(repo files)
|
||||
(let
|
||||
((g (git/wt-group files)))
|
||||
(let
|
||||
((with-blobs (reduce (fn (acc name) (assoc acc name (git/tree-entry "blob" (git/write-blob repo (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-files repo (get (get g :dirs) dir))))) with-blobs (keys (get g :dirs)))))
|
||||
(git/write repo (git/tree entries)))))))
|
||||
|
||||
; ---- index: staged overlay over a base tree ----
|
||||
(define git/index-key (fn (repo) (str (get repo :prefix) "/index")))
|
||||
|
||||
(define
|
||||
git/index-read
|
||||
(fn
|
||||
(repo)
|
||||
(let
|
||||
((v (persist/kv-get (get repo :db) (git/index-key repo))))
|
||||
(if (dict? v) v {:base nil :staged {}}))))
|
||||
|
||||
(define
|
||||
git/index-write!
|
||||
(fn
|
||||
(repo idx)
|
||||
(begin (persist/kv-put (get repo :db) (git/index-key repo) idx) idx)))
|
||||
|
||||
; reset the index to a commit's tree (nil commit = empty index)
|
||||
(define
|
||||
git/index-init!
|
||||
(fn (repo commit-cid) (git/index-write! repo {:base (if (equal? commit-cid nil) nil (git/commit-tree (git/read repo commit-cid))) :staged {}})))
|
||||
|
||||
(define
|
||||
git/wt-stage!
|
||||
(fn
|
||||
(repo path entry)
|
||||
(let
|
||||
((idx (git/index-read repo)))
|
||||
(git/index-write!
|
||||
repo
|
||||
(assoc idx :staged (assoc (get idx :staged) path entry))))))
|
||||
|
||||
(define git/add! (fn (repo path data) (git/wt-stage! repo path {:data data})))
|
||||
(define git/rm! (fn (repo path) (git/wt-stage! repo path {:removed true})))
|
||||
|
||||
(define
|
||||
git/unstage!
|
||||
(fn
|
||||
(repo path)
|
||||
(let
|
||||
((idx (git/index-read repo)))
|
||||
(git/index-write!
|
||||
repo
|
||||
(assoc idx :staged (dissoc (get idx :staged) path))))))
|
||||
|
||||
; apply the overlay: base entries -> overridden/removed by staged
|
||||
(define
|
||||
git/wt-overlay
|
||||
(fn
|
||||
(base staged entry-fn)
|
||||
(reduce
|
||||
(fn
|
||||
(acc path)
|
||||
(let
|
||||
((s (get staged path)))
|
||||
(if
|
||||
(has-key? s :removed)
|
||||
(dissoc acc path)
|
||||
(assoc acc path (entry-fn s)))))
|
||||
base
|
||||
(keys staged))))
|
||||
|
||||
; effective index as path -> blob cid
|
||||
(define
|
||||
git/index-cids
|
||||
(fn
|
||||
(repo)
|
||||
(let
|
||||
((idx (git/index-read repo)))
|
||||
(git/wt-overlay
|
||||
(if
|
||||
(equal? (get idx :base) nil)
|
||||
{}
|
||||
(git/tree-flatten repo (get idx :base)))
|
||||
(get idx :staged)
|
||||
(fn (s) (git/cid (git/blob (get s :data))))))))
|
||||
|
||||
; effective index as path -> data
|
||||
(define
|
||||
git/index-files
|
||||
(fn
|
||||
(repo)
|
||||
(let
|
||||
((idx (git/index-read repo)))
|
||||
(git/wt-overlay
|
||||
(if
|
||||
(equal? (get idx :base) nil)
|
||||
{}
|
||||
(git/tree-files repo (get idx :base)))
|
||||
(get idx :staged)
|
||||
(fn (s) (get s :data))))))
|
||||
|
||||
; write the staged state as a real tree; returns the root tree cid
|
||||
(define
|
||||
git/index-tree!
|
||||
(fn (repo) (git/tree-from-files repo (git/index-files repo))))
|
||||
|
||||
; ---- status ----
|
||||
(define
|
||||
git/files-cids
|
||||
(fn
|
||||
(files)
|
||||
(reduce
|
||||
(fn (acc p) (assoc acc p (git/cid (git/blob (get files p)))))
|
||||
{}
|
||||
(keys files))))
|
||||
|
||||
(define git/files-diff (fn (old new) {:deleted (artdag/sort-strings (filter (fn (p) (not (has-key? new p))) (keys old))) :modified (artdag/sort-strings (filter (fn (p) (and (has-key? old p) (not (equal? (get old p) (get new p))))) (keys new))) :added (artdag/sort-strings (filter (fn (p) (not (has-key? old p))) (keys new)))}))
|
||||
|
||||
(define
|
||||
git/head-tree-cids
|
||||
(fn
|
||||
(repo)
|
||||
(let
|
||||
((h (git/head repo)))
|
||||
(if
|
||||
(equal? h nil)
|
||||
{}
|
||||
(git/tree-flatten repo (git/commit-tree (git/read repo h)))))))
|
||||
|
||||
; worktree-files: dict path -> data (the caller's working copy value)
|
||||
(define
|
||||
git/status
|
||||
(fn
|
||||
(repo worktree-files)
|
||||
(let
|
||||
((headc (git/head-tree-cids repo))
|
||||
(idxc (git/index-cids repo))
|
||||
(wtc (git/files-cids worktree-files)))
|
||||
(let ((unstaged (git/files-diff idxc wtc))) {:untracked (get unstaged :added) :staged (git/files-diff headc idxc) :unstaged {:deleted (get unstaged :deleted) :modified (get unstaged :modified)}}))))
|
||||
Reference in New Issue
Block a user