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

info.rkt

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

@@ -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))
+  (define object
-  (unless commit
+    (with-handlers ([exn:fail?
-    (error 'git-branch "cannot create a branch before the first commit"))
+                     (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

@@ -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,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)