;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; git.scm - libgit2 bindings for Chicken Scheme
;;;
;;; Copyright (c) 2013, Evan Hanson
;;; See LICENSE for details.
;;;
;;; Pretty stable.
;;; Please report bugs (see README).
;;;

(require-library extras posix files lolevel data-structures git-lolevel)

(module git ()
  (import scheme)
  (import (except chicken repository-path make-blob blob?))
  (import (only extras format)
          (only git-lolevel git-error)
          (only posix current-directory regular-file?)
          (only files normalize-pathname make-pathname)
          (only lolevel record-instance-slot number-of-bytes move-memory! tag-pointer)
          (rename (only data-structures o) (o compose))
          (prefix (except git-lolevel git-error) git-)
          (rename (only chicken make-blob)
                  (make-blob make-chicken-blob)))
  (include "git-exports.scm")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Syntax helpers.
;;;

(define-syntax define-git-record-type
  (let ((s+ symbol-append))
    (lambda (e . c)
      (let* ((name (caadr e))
             (attr (cdadr e))
             (free (cdddr e))
             (printer (caddr e))
             (make (s+ 'make- name))
             (%make (s+ '%make- name))
             (->pointer (s+ name '->pointer))
             (pointer-> (s+ 'pointer-> name)))
        `(begin
           (define-record ,name >pointer) ; XXX this is lazy
           (define ,%make ,make)
           (define-record-printer (,name ,name out)
             (display ,printer out))
           (define (,pointer-> ptr)
             (and-let* ((ptr)
                        (obj (,%make ptr)))
               ,(if (null? free)
                    'obj
                    `(set-finalizer! obj
                      (lambda (o)
                        (,(caar free) (,->pointer o)))))))
           ,@(map (lambda (attr)
                    (let ((getter (s+ name '- attr)))
                      (case attr
                        ((id oid)
                         `(define (,(s+ name '-id) obj)
                            (pointer->oid (,(s+ 'git- getter) (,->pointer obj)))))
                        (else
                         `(define (,getter obj)
                            (,(s+ 'git- getter) (,->pointer obj)))))))
                  attr))))))

(define ((pointer-tagger t) p) (and p (tag-pointer p t)))
(define ((git-record-attribute-setter f) r v) (f (object->pointer r) v))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Generics & OIDs
;;;

;; OIDs are allocated/freed by git-lolevel.scm.
(define-git-record-type
  (oid)
  (format "#<oid ~S>" (oid->string oid 7)))

;; All git record types consist of a single field, the object pointer.
(define (object->pointer obj) (record-instance-slot obj 0))

;; The type symbol of the given object as reported by Git, or #f.
;; Only valid for the Commit, Tree, Blob & Tag types.
(define (object-type obj)
  (let ((type (git-object-type (object->pointer obj))))
    (and (symbol? type) type)))

(define (object=? obj1 obj2)
  (oid=? (object-id obj1) (object-id obj2)))

(define (object-sha obj #!optional (len 40))
  (oid->string (->oid obj) len))

(define (oid=? oid1 oid2)
  (git-oid-equal (oid->pointer oid1) (oid->pointer oid2)))

(define (oid->string id #!optional (len 40))
  (git-oid-tostr (min len 40) (oid->pointer id)))

(define oid->path   (compose git-oid-pathfmt oid->pointer))
(define string->oid (compose pointer->oid git-oid-fromstr))
(define object-id   (compose pointer->oid git-oid-cpy git-object-id object->pointer))

(define (->oid obj)
  (cond ((oid? obj) obj)
        ((string? obj) (string->oid obj))
        ((reference? obj) (reference-target obj))
        (else (object-id obj))))

(define ->oid->pointer
  (compose oid->pointer ->oid))

(define (->reference-name obj)
  (cond ((string? obj) obj)
        ((reference? obj) (reference-name obj))
        (else (git-error '->reference-name "Not a valid reference" obj))))

(define (pointer->object ptr)
  (case (git-object-type ptr)
    ((blob)   (pointer->blob ptr))
    ((commit) (pointer->commit ptr))
    ((tag)    (pointer->tag ptr))
    ((tree)   (pointer->tree ptr))
    (else     (git-error 'pointer->object "Not a valid object pointer" ptr))))

(define (merge-base r a b)
  (pointer->commit
   (git-commit-lookup
    (repository->pointer r)
    (pointer->oid
     (git-merge-base
      (repository->pointer r)
      (oid->pointer a)
      (oid->pointer b))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Signatures
;;;

(define-git-record-type
  (signature name email)
  (format "#<signature \"~A <~A>\">" (signature-name signature) (signature-email signature))
  (git-signature-free))

(define signature-time        (compose git-time-time git-signature-time signature->pointer))
(define signature-time-offset (compose git-time-offset git-signature-time signature->pointer))

(define (make-signature name email #!optional time (offset 0))
  (pointer->signature
   (cond (time (git-signature-new name email time offset))
         (else (git-signature-now name email)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Repositories
;;;

(define-git-record-type
  (repository is-empty is-bare path workdir head-orphan head-detached)
  (format "#<repository ~S>" (repository-path repository))
  (git-repository-free))

(define repository-empty? repository-is-empty)
(define repository-bare? repository-is-bare)
(define repository-head-orphan? repository-head-orphan)
(define repository-head-detached? repository-head-detached)
(define repository-working-directory repository-workdir)

(define (repository-open #!optional (path (current-directory)))
  (let ((path (normalize-pathname path)))
    (pointer->repository
     (condition-case
       (git-repository-open path)
       ((git) (git-repository-open (git-repository-discover path)))))))

(define (repository-ref repo ref #!optional (type 'any))
  (condition-case
    (pointer->object
     (git-object-lookup
      (repository->pointer repo)
      (->oid->pointer ref)
      type))
    ((git) #f)))

(define (create-repository #!optional (path (current-directory)) bare)
  (pointer->repository (git-repository-init path bare)))

(define object-owner (compose pointer->repository git-object-owner object->pointer))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Revspec

(define (parse-revision-specification repo str)
  (condition-case
    ;; Try a single revision first.
    (let ((revspec (git-revparse-single (repository->pointer repo) str)))
      (values (pointer->object revspec) #f))
    ((git)
     (condition-case
       ;; If str didn't specify a single revision, try parsing it as a range.
       (let ((revspec (git-revparse (repository->pointer repo) str)))
         (values (pointer->object (git-revspec-from revspec))
                 (pointer->object (git-revspec-to revspec))))
       ((git)
        ;; Neither a single revision nor a range, return falses.
        ;; XXX Error here?
        (values #f #f))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; References

(define-git-record-type
  (reference type name delete)
  (format "#<reference ~S>" (reference-name reference))
  (git-reference-free))

(define repository-head   (compose pointer->reference git-repository-head repository->pointer))
(define reference-resolve (compose pointer->reference git-reference-resolve reference->pointer))

(define reference-branch? (compose git-reference-is-branch reference->pointer))
(define reference-remote? (compose git-reference-is-remote reference->pointer))

(define (reference-target ref)
  ;; We have to dig out the intermediate reference in order to free it.
  (let* ((ref* (git-reference-resolve (reference->pointer ref)))
         (oid* (git-oid-cpy (git-reference-target ref*))))
    (git-reference-free ref*)
    (pointer->oid oid*)))

(define (reference repo name)
  (pointer->reference (git-reference-lookup (repository->pointer repo) name)))

(define (references-fold kons knil repo #!optional (type 'all))
  (let ((state knil))
    (git-reference-foreach-name
     (repository->pointer repo)
     (lambda (name)
       (set! state
         (kons (pointer->reference
                (git-reference-lookup
                 (repository->pointer repo)
                 name))
               state))))
    state))

(define (references repo #!optional (type 'all))
  (references-fold cons '() repo type))

(define (create-reference repo #!key name target symbolic force)
  (let ((repo* (repository->pointer repo)))
    (pointer->reference
     (if (not symbolic)
         ;; Direct references are created by OID.
         (git-reference-create repo* name (->oid->pointer target) force)
         ;; Symbolic references require the target to be given by a string.
         (git-reference-symbolic-create repo* name (->reference-name target) force)))))

(define (reference-target-set! ref target)
  (git-reference-set-target
   (reference->pointer ref)
   (->oid->pointer target)))

(define (reference-rename ref name #!optional force)
  (pointer->reference (git-reference-rename (reference->pointer ref) name force)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Trees

(define-git-record-type
  (tree id entrycount)
  (format "#<tree ~S>" (oid->string (tree-id tree) 7))
  (git-tree-free))

(define-git-record-type
  (tree-entry id name type)
  (format "#<tree-entry ~S>" (tree-entry-name tree-entry))
  (git-tree-entry-free))

(define (tree repo ref)
  (pointer->tree
   (git-tree-lookup
    (repository->pointer repo)
    (->oid->pointer ref))))

(define (tree-ref tree key)
  (pointer->tree-entry
   (let ((tree* (tree->pointer tree)))
     ;; dup the resulting entry so it's under our control w.r.t. GC.
     (cond ((number? key)
            (git-tree-entry-dup (git-tree-entry-byindex tree* key)))
           ((oid? key)
            (git-tree-entry-dup (git-tree-entry-byoid tree* key)))
           ((string? key)
            (cond
              ((git-tree-entry-byname tree* key) => git-tree-entry-dup)
              (else
               ;; Entries retrieved by path are already owned by the user.
               (condition-case
                 (git-tree-entry-bypath tree* key)
                 ((git) #f)))))
           (else
            (git-error 'tree-ref "Invalid key" key))))))

(define (tree-entry->object repo entry)
  (pointer->object
   (git-tree-entry-to-object
    (repository->pointer repo)
    (tree-entry->pointer entry))))

(define (create-tree repo #!optional (index (index-open repo)))
  (pointer->tree
   (git-tree-lookup
    (repository->pointer repo)
    (git-index-write-tree (index->pointer index)))))

(define (tree-fold kons knil tree #!optional (mode 'post))
  (let ((state knil))
    (git-tree-walk
     (tree->pointer tree)
     (lambda (path entry*)
       (set! state
         (kons path (pointer->tree-entry (git-tree-entry-dup entry*)) state)))
     mode)
    state))

(define (tree-entries tree)
  (tree-fold (lambda (path entry acc) (cons (cons path entry) acc)) '() tree))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tree Builders

(define-git-record-type
  (tree-builder clear)
  "#<tree-builder>"
  (git-tree-builder-free))

(define (make-tree-builder #!optional tree)
  (pointer->tree-builder
   (git-tree-builder-create
    (and tree (tree->pointer tree)))))

(define (tree-builder-ref tb path)
  (and-let* ((entry* (git-tree-builder-get (tree-builder->pointer tb) path)))
    (pointer->tree-entry (tag-pointer (git-tree-entry-dup entry*) tb))))

(define (tree-builder-insert builder obj path attributes)
  (pointer->tree-entry
   (git-tree-entry-dup
    (git-tree-builder-insert
     (tree-builder->pointer builder)
     path
     (->oid->pointer obj)
     attributes))))

(define (tree-builder-write repo tb)
  (pointer->tree
   (git-tree-lookup
    (repository->pointer repo)
    (git-tree-builder-write
     (repository->pointer repo)
     (tree-builder->pointer tb)))))

(define (tree-builder-remove tb path)
  (git-tree-builder-remove (tree-builder->pointer tb) path))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Branches

(define (branch repo name #!optional (type 'all))
  (pointer->reference (git-branch-lookup (repository->pointer repo) name type)))

;; I'm changing branch-move to branch-rename here, perhaps gratuitously.
;; I'm just so sick of typing `git branch rename foo bar` and having
;; git whine at me, consider this payback.
(define (branch-rename ref name #!optional force)
  (pointer->reference (git-branch-move (reference->pointer ref) name force)))

;; XXX Returns a reference.
(define (create-branch repo #!key name target force)
  (pointer->reference
   (git-branch-create
    (repository->pointer repo)
    name
    (commit->pointer target)
    force)))

(define branch-name     (compose git-branch-name reference->pointer))
(define branch-delete   (compose git-branch-delete reference->pointer))
(define branch-head?    (compose git-branch-is-head reference->pointer))

(define (branches-fold kons knil repo #!optional (type 'all))
  (let ((state knil))
    (git-branch-foreach
     (repository->pointer repo)
     type
     (lambda (name type)
       (set! state
         (kons (pointer->reference
                (git-branch-lookup
                 (repository->pointer repo)
                 name
                 type))
               state))))
    state))

(define (branches repo #!optional (type 'all))
  (branches-fold cons '() repo type))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Checkout

(define (checkout repo #!optional object)
  (cond
    ((not object)
     (git-checkout-head (repository->pointer repo) #f))
    ((index? object)
     (git-checkout-index (repository->pointer repo) (index->pointer object) #f))
    (else
     (git-checkout-tree (repository->pointer repo) (object->pointer object) #f))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Commits

(define-git-record-type
  (commit id message message-encoding time time-offset parentcount)
  (format "#<commit ~S>" (oid->string (commit-id commit) 7))
  (git-commit-free))

(define commit-tree      (compose pointer->tree git-commit-tree commit->pointer))
(define commit-tree-id   (compose pointer->oid git-oid-cpy git-commit-tree-id commit->pointer))
(define commit-parent-id (compose pointer->oid git-oid-cpy git-commit-parent-id commit->pointer))
(define commit-author    (compose pointer->signature git-signature-dup git-commit-author commit->pointer))
(define commit-committer (compose pointer->signature git-signature-dup git-commit-committer commit->pointer))

(define (commit-parent cmt #!optional (n 0))
  (condition-case
    (pointer->commit (git-commit-parent (commit->pointer cmt) n))
    ((git) #f)))

(define (commit-parents c)
  (let ((n (commit-parentcount c)))
    (let lp ((i 0)
             (p '()))
      (if (= i n)
          (reverse p)
          (lp (+ i 1)
              (cons (commit-parent c i) p))))))

(define (commit-ancestor cmt #!optional (n 1))
  (condition-case
    (pointer->commit (git-commit-nth-gen-ancestor (commit->pointer cmt) n))
    ((git) #f)))

(define (commit repo ref)
  (pointer->commit
   (git-commit-lookup
    (repository->pointer repo)
    (->oid->pointer ref))))

(define (commits-fold kons knil repo #!key initial (hide '()) (sort 'none))
  (let* ((repo*  (repository->pointer repo))
         (walker (set-finalizer! (git-revwalk-new repo*) git-revwalk-free)))
    (call-with-current-continuation
     (lambda (k)
       ;; Sort mode, one of '(none topo time rev)
       (git-revwalk-sorting walker sort)
       ;; Set hidden commits. These exclude full branches from the
       ;; traversal, rather than just the commits.
       (for-each (lambda (h) (git-revwalk-hide walker (->oid->pointer h))) hide)
       (condition-case
         (if initial ; Set the initial revision.
             (git-revwalk-push walker (->oid->pointer initial))
             (git-revwalk-push-head walker))
         ((git) (k '())))
       (let loop ((state knil))
         (loop (kons (pointer->commit
                      (git-commit-lookup
                       repo*
                       (condition-case
                         (git-revwalk-next walker)
                         ((git) (k state)))))
                     state)))))))

(define (commits repo #!rest rest)
  (apply commits-fold cons '() repo rest))

(define (create-commit repo #!key message author (committer author) (tree (create-tree repo)) (reference #f) (parents '()))
  (pointer->commit
   (git-commit-lookup
    (repository->pointer repo)
    (git-commit-create
     (repository->pointer repo)
     (and reference (->reference-name reference))
     (signature->pointer author)
     (signature->pointer committer)
     message
     (tree->pointer tree)
     (map commit->pointer parents)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Blobs

(define-git-record-type
  (blob id rawsize rawcontent is-binary)
  (format "#<blob ~S>" (oid->string (blob-id blob) 7))
  (git-blob-free))

(define blob-length  blob-rawsize)
(define blob-content blob-rawcontent)
(define blob-binary? blob-is-binary)

(define (blob-content blob)
  (let* ((size (blob-rawsize blob))
         (dest (make-chicken-blob size)))
    (move-memory! (blob-rawcontent blob) dest size)
    dest))

(define (blob repo ref)
  (pointer->blob
   (git-blob-lookup
    (repository->pointer repo)
    (->oid->pointer ref))))

(define (create-blob repo source)
  (let ((repo* (repository->pointer repo)))
    (pointer->blob
     (git-blob-lookup
      repo*
      (cond ((blob? source)
             (git-blob-create-frombuffer repo* source))
            ((string? source)
             (if (regular-file? source)
                 (git-blob-create-fromdisk repo* source)
                 (git-blob-create-fromworkdir repo* source)))
            (else
             (git-error 'create-blob "Invalid blob source" source)))))))

(define blob* blob)
(define blob*-binary? blob-binary?)
(define blob*-content blob-content)
(define blob*-id blob-id)
(define blob*-size blob-length)
(define blob*? blob?)
(define create-blob* create-blob)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Index

(define-git-record-type
  (index entrycount read write clear)
  "#<index>"
  (git-index-free))

(define-git-record-type
  (index-entry dev oid ino mode uid gid size stage flags extended path)
  (format "#<index-entry ~S>" (index-entry-path index-entry)))

(define index-entry-ctime (compose git-index-time-seconds git-index-entry-mtime index-entry->pointer))
(define index-entry-mtime (compose git-index-time-seconds git-index-entry-mtime index-entry->pointer))

(define (index-open loc)
  (pointer->index
   (cond ((string? loc)
          (git-index-open loc))
         ((repository? loc)
          (git-repository-index (repository->pointer loc)))
         (else
          (git-error 'index-open "Invalid index location" loc)))))

(define (index-find ix path)
  (if (not (string? path))
      (git-error 'index-find "String required" path)
      (and-let* ((pos (git-index-find #f (index->pointer ix) path)))
        (and (<= 0 pos) pos))))

(define (index-add ix arg)
  (cond ((index-entry? arg)
         (git-index-add (index->pointer ix) arg 0))
        ((string? arg)
         (git-index-add-bypath (index->pointer ix) arg))
        (else
         (git-error 'index-open "Cannot add to index" arg))))

(define (index-remove ix ref)
  (git-index-remove (index->pointer ix) ref 0))

(define (index-ref ix key)
  (let ((ix* (index->pointer ix))
        (tag (pointer-tagger ix)))
    (pointer->index-entry
     (cond ((number? key)
            (tag (git-index-get-byindex ix* key)))
           ((string? key)
            (tag (git-index-get-bypath ix* key 0)))
           (else
            (git-error 'index-ref "Invalid key" key))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Status

(define (file-status repo path)
  (git-status-file (repository->pointer repo) path))

(define (file-ignored? repo path)
  (git-status-should-ignore (repository->pointer repo) path))

(define (file-statuses-fold kons knil repo)
  (let ((state knil))
    (git-status-foreach
     (lambda (path status)
       (set! state (kons path status state)))
     (repository->pointer repo))
    state))

(define (file-statuses repo)
  (file-statuses-fold
   (lambda (path status acc)
     (cons (cons path status) acc))
   '()
   repo))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Notes

(define-git-record-type
  (note message oid)
  "#<note>"
  (git-note-free))

(define (note repo object #!optional reference)
  (pointer->note
   (git-note-read
    (repository->pointer repo)
    reference
    (->oid->pointer object))))

(define (delete-note repo #!key target reference author (committer author))
  (git-note-remove
   (repository->pointer repo)
   reference
   (signature->pointer author)
   (signature->pointer committer)
   (->oid->pointer target)))

(define (create-note repo #!key message target reference author (committer author) force)
  (let ((repo* (repository->pointer repo))
        (oid*  (->oid->pointer target)))
    ;; git-note-create returns the new note's OID, but AFAIK there's no
    ;; way to look up a note by OID. So, to return the new note, we
    ;; first create it...
    (git-note-create
     repo*
     (signature->pointer author)
     (signature->pointer committer)
     reference
     oid*
     message
     force)
    ;; ... Then retrieve it by reading it from the target object.
    (pointer->note
     (git-note-read
      repo*
      reference
      oid*))))

(define notes-fold
  (let ((reference-exists?
         (lambda (repo* ref)
           (condition-case
             (and (git-reference-free (git-reference-lookup repo* ref)) #t)
             ((git) #f)))))
    (lambda (kons knil repo #!optional reference)
      (let ((repo* (repository->pointer repo)))
        ;; If the notes reference doesn't exist, return knil immediately.
        (if (not (reference-exists? repo* (or reference (git-note-default-ref repo*))))
            knil
            (let ((state knil))
              (git-note-foreach
               repo*
               reference
               (lambda (bid* oid*)
                 (set! state
                   (kons (pointer->note (git-note-read repo* reference oid*)) state))))
              state))))))

(define (notes repo #!optional reference)
  (notes-fold cons '() repo reference))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ODB

(define-git-record-type
  (odb)
  "#<odb>"
  (git-odb-free))

(define-git-record-type
  (odb-object id size type)
  "#<odb-object>"
  (git-odb-object-free))

(define (odb-has-object? odb obj)
  (git-odb-exists
   (odb->pointer odb)
   (->oid->pointer obj)))

(define (odb-open loc)
  (pointer->odb
   (cond ((string? loc)
          (git-odb-open loc))
         ((repository? loc)
          (git-repository-odb (repository->pointer loc)))
         (else
          (git-error 'odb-open "Invalid odb location" loc)))))

(define (odb-read odb obj)
  (pointer->odb-object
   (git-odb-read
    (odb->pointer odb)
    (->oid->pointer obj))))

(define (odb-write odb data #!optional (type 'blob))
  (pointer->oid (git-odb-write (odb->pointer odb) data (number-of-bytes data) type)))

(define (odb-hash data #!optional (type 'blob))
  (pointer->oid (git-odb-hash data (number-of-bytes data) type)))

(define (odb-object-data obj)
  (let* ((data (git-odb-object-data (odb-object->pointer obj)))
         (size (odb-object-size obj))
         (dest (make-chicken-blob size)))
    (move-memory! data dest size)
    dest))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tags

(define-git-record-type
  (tag id name message)
  (format "#<tag ~S>" (tag-name tag))
  (git-tag-free))

(define (tag repo ref)
  (pointer->tag
   (git-tag-lookup
    (repository->pointer repo)
    (->oid->pointer ref))))

(define (tags-fold kons knil repo)
  (let ((state knil))
    (git-tag-foreach
     (lambda (name oid*)
       (set! state
         (kons (pointer->tag
                (git-tag-lookup
                 (repository->pointer repo)
                 oid*))
               state)))
     (repository->pointer repo))
    state))

(define (tags repo)
  (tags-fold cons '() repo))

(define tag-peel   (compose pointer->object git-tag-peel tag->pointer))
(define tag-target (compose pointer->object git-tag-target tag->pointer))
(define tag-tagger (compose pointer->signature git-signature-dup git-tag-tagger tag->pointer))

(define (tag-delete tag)
  (git-tag-delete (git-object-owner (tag->pointer tag)) (tag-name tag)))

(define (create-tag repo #!key target name message tagger force)
  (pointer->tag
   (git-tag-lookup
    (repository->pointer repo)
    (git-tag-create
     (repository->pointer repo)
     name
     (object->pointer target)
     (signature->pointer tagger)
     message
     force))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Diffs

(define-git-record-type
  (diff-file oid mode path size flags)
  (format "#<diff-file ~S>" (diff-file-path diff-file)))

;; The `diff-delta` record type is renamed to just `diff`.
(define-git-record-type
  (diff-delta old-file new-file status similarity)
  (format "#<diff ~S>" (diff-file-path (diff-new-file diff-delta))))

(define diff?           diff-delta?)
(define diff-status     diff-delta-status)
(define diff-similarity diff-delta-similarity)
(define diff-old-file   (compose pointer->diff-file diff-delta-old-file))
(define diff-new-file   (compose pointer->diff-file diff-delta-new-file))

(define (diff-path diff)
  (diff-file-path
   (or (diff-new-file diff)
       (diff-old-file diff))))

;; Helper for `diff`, below.
;;
;; Adds a refcount to the diff-list, to delay GC until all its
;; diff-deltas are unreachable.
(define (build-diff-list diffs)
  (let ((acc '())
        (tag (pointer-tagger diffs)))
    (git-diff-foreach
     (lambda (delta* progress)
       (set! acc (cons (pointer->diff-delta (tag delta*)) acc)))
     diffs)
    acc))

(define diff
  (case-lambda
    ((repo)
     (diff repo (index-open repo)))
    ((repo object)
     (build-diff-list
      (let ((repo* (repository->pointer repo)))
        (cond ((index? object)
               (git-diff-index-to-workdir repo* (index->pointer object)))
              ((tree? object)
               (git-diff-tree-to-workdir repo* (tree->pointer  object)))
              (else
               (git-error 'diff "Undiffable object" object))))))
    ((repo tree object)
     (build-diff-list
      (let ((repo* (repository->pointer repo))
            (tree* (tree->pointer tree)))
        (cond ((tree? object)
               (git-diff-tree-to-tree repo* tree* (tree->pointer object)))
              ((index? object)
               (git-diff-tree-to-index repo* tree* (index->pointer object)))
              (else
               (git-error 'diff "Undiffable object" object))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Remotes
;;;

(define-git-record-type
  (remote name url pushurl connect connected disconnect update-tips update-fetchhead stop save)
  (format "#<remote ~S (~a)>"
          (remote-name remote)
          (if (remote-connected? remote) "connected" "disconnected"))
  (git-remote-free))

(define-git-record-type
  (refspec src dst string direction force)
  (format "#<refspec ~S ~S>" (refspec-src refspec) (refspec-dst refspec)))

(define-git-record-type
  (transfer-progress total-objects indexed-objects received-objects received-bytes)
  "#<transfer-progress>")

(define refspec-source refspec-src)
(define refspec-destination refspec-dst)

(define remote-connected? remote-connected)
(define remote-url-valid? git-remote-valid-url)
(define remote-url-supported? git-remote-supported-url)
(define remote-name-valid? git-remote-is-valid-name)

(define remote-url-set!              (git-record-attribute-setter git-remote-set-url))
(define remote-pushurl-set!          (git-record-attribute-setter git-remote-set-pushurl))
(define remote-update-fetchhead-set! (git-record-attribute-setter git-remote-update-fetchhead))

(define (remote-refspecs rem)
  (let ((tag (compose pointer->refspec (pointer-tagger rem))))
    (let lp ((i 0)
             (a '()))
      (cond ((git-remote-get-refspec (remote->pointer rem) i) =>
             (lambda (refspec)
               (lp (fx+ i 1)
                   (cons (tag refspec) a))))
            (else a)))))

(define (remote repo name)
  (pointer->remote (git-remote-load (repository->pointer repo) name)))

(define (remotes repo)
  (map (lambda (name) (remote repo name))
       (git-remote-list (repository->pointer repo))))

(define (remote-connect rem #!optional (direction 'fetch))
  (git-remote-connect (remote->pointer rem) direction))

(define (remote-rename rem name #!optional callback)
  (git-remote-rename (remote->pointer rem) name callback))

(define (remote-stats rem)
  (pointer->transfer-progress
   (tag-pointer (git-remote-stats (remote->pointer rem)) rem)))

(define (remote-download rem #!optional callback)
  (if (remote-connected? rem)
      (git-remote-download
       (remote->pointer rem)
       (and callback (compose callback pointer->transfer-progress)))
      (dynamic-wind
       (lambda ()
         (remote-connect rem))
       (lambda ()
         (remote-download rem callback)
         (remote-update-tips rem)
         (remote-stats rem))
       (lambda ()
         (remote-disconnect rem)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Cloning
;;;

(define (clone url path) (pointer->repository (git-clone url path #f)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Configs

(define-git-record-type
  (config)
  "#<config>"
  (git-config-free))

(define-git-record-type
  (config-entry name value level)
  (format "#<config-entry ~S>" (config-entry-name config-entry)))

(define (config-path #!optional (type 'user))
  (case type
    ((user)
     (git-config-find-global))
    ((system)
     (git-config-find-system))
    ((xdg)
     (git-config-find-xdg))
    (else
     (git-error 'config-path "Invalid configuration file path type" type))))

(define (config-open #!optional target)
  (pointer->config
   (cond ((not target)
          (git-config-open-default))
         ((string? target)
          (git-config-open-ondisk target))
         ((symbol? target)
          (git-config-open-ondisk (config-path target)))
         ((repository? target)
          (git-repository-config
           (repository->pointer target)))
         (else
          (git-error 'config-open "Invalid configuration file source" target)))))

(define (config-get config name #!optional (type 'string))
  ((case type
     ((boolean) git-config-get-bool)
     ((string)  git-config-get-string)
     ((number)  git-config-get-int64)
     (else (git-error 'config-get "Invalid value type specifier" type)))
   (config->pointer config)
   name))

(define (config-set! config name value)
  ((cond
     ((boolean? value) git-config-set-bool)
     ((string? value)  git-config-set-string)
     ((number? value)  git-config-set-int64)
     (else (git-error 'config-set "Invalid value type" value)))
   (config->pointer config)
   name
   value))

(define (config-unset! cfg name)
  (git-config-delete-entry (config->pointer cfg) name)))