hans/git-cli
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

missing commands git 'version/'switch and branch merge commands added

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-11 15:30:24 +02:00
parent 856c9bd58e
commit 1c7d71ab07
4 changed files with 118 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files
info.rkt
+1 -1
View File
@@ -2,7 +2,7 @@
(define collection "git")
(define pkg-desc "Command-line-like Git operations for Racket, implemented with libgit2")
(define version "0.2.10")
(define version "0.2.11")
(define pkg-authors '("Hans Dijkema"))
(define license 'MIT)
main.rkt
+97 -5
View File
@@ -1,6 +1,8 @@
#lang racket/base
(require ffi/unsafe
racket/runtime-path
setup/getinfo
racket/async-channel
racket/list
racket/match
@@ -11,6 +13,7 @@
(provide git
dgit
git-version
git-repository?
git-root
git-init
@@ -27,11 +30,14 @@
git-commit
git-head
git-current-branch
git-switch
git-branches
git-branch-create
git-branch
git-branch-delete
git-checkout
git-checkout-new
git-merge
git-tags
git-tag
git-tag-delete
@@ -58,6 +64,14 @@
(struct git-status-entry (path code flags) #:transparent)
(struct git-log-entry (id summary time) #:transparent)
(define-runtime-path git-command-directory ".")
(define (git-version)
(define info (get-info/full git-command-directory))
(unless info
(error 'git-version "cannot read info.rkt"))
(info 'version (lambda () (error 'git-version "info.rkt has no version"))))
(define zero-oid-string (make-string GIT_OID_HEXSZ #\0))
(define branch-prefix "refs/heads/")
(define tag-prefix "refs/tags/")
@@ -66,6 +80,7 @@
(define GIT-CREDTYPE-USERNAME #x0020)
(define GIT-PASSTHROUGH -30)
(define GIT-CHECKOUT-OPTIONS-VERSION 1)
(define GIT-MERGE-OPTIONS-VERSION 1)
(define (git-credential-callback out url username-from-url allowed-types _payload)
;; Never let a Racket exception escape through a C callback. In particular,
@@ -550,18 +565,23 @@
#"")
(sort branches string<?))
(define (create-branch name)
(define (git-branch-create name [start-point "HEAD"])
(define repo (open-repository))
(define commit (head-commit repo))
(unless commit
(error 'git-branch "cannot create a branch before the first commit"))
(define object
(with-handlers ([exn:fail?
(lambda (_)
(error 'git-branch-create
"cannot resolve start point: ~a"
start-point))])
(git_revparse_single repo (format "~a^{commit}" start-point))))
(define commit (git_commit_lookup repo (git_object_id object)))
(git_branch_create repo name commit #f)
name)
(define git-branch
(case-lambda
[() (git-branches)]
[(name) (create-branch name)]))
[(name) (git-branch-create name)]))
(define (git-branch-delete name)
(define repo (open-repository))
@@ -578,6 +598,12 @@
(git_checkout_options_init options GIT-CHECKOUT-OPTIONS-VERSION)
options)
(define (make-merge-options)
(define options
(cast (malloc _git_merge_opts 'atomic) _pointer _git_merge_opts-pointer))
(git_merge_options_init options GIT-MERGE-OPTIONS-VERSION)
options)
(define (git-checkout name)
(define repo (open-repository))
(define options (make-safe-checkout-options))
@@ -595,10 +621,65 @@
(git_repository_set_head_detached repo (git_object_id object))])
(git-head))
(define (git-switch name)
(unless (member name (git-branches))
(error 'git-switch "no such local branch: ~a" name))
(git-checkout name))
(define (git-checkout-new name)
(git-branch name)
(git-checkout name))
(define (git-merge name [message #f])
(define repo (open-repository))
(define branch (git-current-branch))
(unless branch
(error 'git-merge "merge requires an attached local branch"))
(define ours (head-commit repo))
(unless ours
(error 'git-merge "cannot merge into a repository without commits"))
(define target-object
(with-handlers ([exn:fail?
(lambda (_)
(error 'git-merge "cannot resolve merge target: ~a" name))])
(git_revparse_single repo (format "~a^{commit}" name))))
(define theirs (git_commit_lookup repo (git_object_id target-object)))
(define ours-id (git_commit_id ours))
(define theirs-id (git_commit_id theirs))
(cond
;; The target is already contained in HEAD.
[(or (git_oid_equal ours-id theirs-id)
(git_graph_descendant_of repo ours-id theirs-id))
#f]
;; HEAD is an ancestor of the target: do a real fast-forward, including
;; index and worktree, and keep HEAD attached to the current branch.
[(git_graph_descendant_of repo theirs-id ours-id)
(git_checkout_tree repo target-object (make-safe-checkout-options))
(define local-ref
(git_reference_lookup repo (string-append branch-prefix branch)))
(git_reference_set_target
local-ref theirs-id (format "merge ~a: fast-forward" name))
(git_oid_fmt theirs-id)]
[else
;; Build the merge in an in-memory index first. Conflicts therefore leave
;; HEAD, the worktree, and the repository index untouched.
(define merge-index (git_merge_commits repo ours theirs (make-merge-options)))
(when (git_index_has_conflicts merge-index)
(error 'git-merge "merge conflicts while merging ~a" name))
(define tree-id (blank-oid))
(git_index_write_tree_to tree-id merge-index repo)
(define tree (git_tree_lookup repo tree-id))
;; Safe checkout refuses to overwrite uncommitted worktree changes.
(git_checkout_tree repo (cast tree _git_tree _git_object)
(make-safe-checkout-options))
(define signature (git_signature_default repo))
(define commit-id (blank-oid))
(git_commit_create_v
commit-id repo "HEAD" signature signature #f
(or message (format "Merge branch '~a'" name))
tree 2 ours theirs)
(git_oid_fmt commit-id)]))
(define (git-tags)
(define tags null)
(git_tag_foreach
@@ -826,6 +907,10 @@
(unless (symbol? command)
(raise-argument-error 'git "symbol?" command))
(case command
[(version)
(unless (null? args)
(error 'git "version takes no arguments"))
(git-version)]
[(init) (apply git-init args)]
[(clone) (keyword-apply git-clone '(#:quiet) (list quiet) args)]
[(status) (apply git-status args)]
@@ -836,10 +921,17 @@
(apply git-add args))]
[(config) (apply git-config args)]
[(commit) (apply git-commit args)]
[(branch-current)
(unless (null? args)
(error 'git "branch-current takes no arguments"))
(git-current-branch)]
[(branch)
(match args
[(list '-d name) (git-branch-delete name)]
[_ (apply git-branch args)])]
[(branch-create) (apply git-branch-create args)]
[(switch) (apply git-switch args)]
[(merge) (apply git-merge args)]
[(checkout)
(match args
[(list '-b name) (git-checkout-new name)]
scribblings/git.scrbl
+16 -1
View File
@@ -35,6 +35,14 @@ Calls @racket[git], displays its result in a compact human-readable form, and re
(dgit 'status)
]
@section{Version}
@defproc[(git-version) string?]{Returns the package version from @tt{info.rkt}. The command form is @racket[(git 'version)]. The version is not duplicated in @tt{main.rkt}; @tt{info.rkt} is the single source of truth.}
@racketblock[
(git 'version) ; => "0.2.11"
]
@section{Repository}
@defproc[(git-repository? [path path-string? (current-directory)]) boolean?]{Returns whether @racket[path] is inside a Git repository.}
@@ -60,7 +68,12 @@ Calls @racket[git], displays its result in a compact human-readable form, and re
[(git-diff [option (or/c '--cached)]) string?])]{Returns a unified patch as a string. With no arguments it compares the index with the worktree, like @tt{git diff}. With @racket['--cached] it compares HEAD with the index, like @tt{git diff --cached}.}
@defproc[(git-add [path path-string?] ...) void?]{Stages the given paths. With no paths, stages the whole repository, including tracked removals.}
@defproc[(git-add [path path-string?] ...) void?]{Stages the given paths. With no paths, stages the whole repository, including tracked removals. The command form @racket[(git 'add '-A)] stages all current status entries, including new, modified, and removed paths.}
@racketblock[
(git 'add '-A)
(git 'commit "Update all changed files")
]
@section{Configuration and commits}
@@ -143,10 +156,12 @@ Remote HTTPS operations automatically use credentials from the @tt{racket-git} c
The following command-like forms are supported directly:
@racketblock[
(git 'version)
(git 'init)
(git 'clone "https://example/repo.git")
(git 'status)
(git 'add "file.rkt")
(git 'add '-A)
(git 'config "user.name" "Name")
(git 'commit "message")
(git 'branch-current)
tests/branch-merge.rkt
+4
View File
@@ -4,6 +4,10 @@
racket/file
git)
(check-equal? (git 'version) "0.2.11")
(check-equal? (git-version) "0.2.11")
(define tmp (make-temporary-file "racket-git-branch-merge-test~a" 'directory))
(define (write-file path text)