More working commands

main.rkt

@@ -27,11 +27,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
@@ -66,6 +69,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 +554,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 +587,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 +610,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
@@ -833,10 +903,17 @@
     [(add) (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)]