;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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!)
          (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      (cadr e))
             (spec      (caddr e))
             (printer   (cadddr e))
             (free      (cddddr e))
             (slots     (cdar spec))
             (attrs     (cdr spec))
             (make      (s+ 'make- name))
             (%make     (s+ '%make- name))
             (->pointer (s+ name '->pointer))
             (pointer-> (s+ 'pointer-> name)))
        `(begin
           (define-record ,name >pointer ,@slots)
           (define ,%make ,make)
           (define-record-printer (,name ,name out)
             (display ,printer out))
           (define (,pointer-> ,@slots ptr)
             (and-let* ((ptr)
                        (obj (,%make ptr ,@slots)))
               ,(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)))))))
                  attrs))))))

(define-syntax begin0-let
  (syntax-rules ()
    ((_ ((n e) . rest) . body)
     (let ((n e) . rest) (begin . body) n))))

(define ((git-record-attribute-setter f) r v) (f (object->pointer r) v))
(define ((set-owner m f) o) (m o (f o)))
(define ((preserve-owner m f) o) (m (object-owner o) (f o)))

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

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

;; The first slot in all Git record types is the object pointer.
(define (object->pointer obj) (record-instance-slot obj 0))

;; If an object has an owner, it's in the second slot.
(define (object-owner obj) (record-instance-slot obj 1))

;; 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 repo ptr)
  (case (git-object-type ptr)
    ((blob)   (pointer->blob repo ptr))
    ((commit) (pointer->commit repo ptr))
    ((tag)    (pointer->tag repo ptr))
    ((tree)   (pointer->tree repo ptr))
    (else     (git-error 'pointer->object "Not a valid object pointer" ptr))))

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

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

(define-git-record-type signature
  ((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
  ((repository) is-empty is-bare path workdir head-unborn 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-unborn? repository-head-unborn)
(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
     repo
     (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)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 repo 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 repo (git-revspec-from revspec))
                 (pointer->object repo (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
  ((reference repository) type name delete)
  (format "#<reference ~S>" (reference-name reference))
  (git-reference-free))

(define repository-head   (set-owner pointer->reference (compose git-repository-head repository->pointer)))
(define reference-resolve (preserve-owner pointer->reference (compose 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 repo (git-reference-lookup (repository->pointer repo) name)))

(define (references-fold kons knil repo #!optional (type 'all))
  (begin0-let ((state knil))
    (git-reference-foreach-name
     (repository->pointer repo)
     (lambda (name)
       (set! state
         (kons (pointer->reference
                repo
                (git-reference-lookup
                 (repository->pointer repo)
                 name))
               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
     repo
     (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
   (reference-repository ref)
   (git-reference-rename (reference->pointer ref) name force)))

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

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

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

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

(define (tree-ref tree key)
  (pointer->tree-entry
   tree
   (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
  (case-lambda
    ((entry)
     (let ((owner (tree-entry-owner entry)))
       (if (tree? owner)
           (tree-entry->object (tree-repository owner) entry)
           (git-error 'tree-entry->object "Can't determine owning repository" entry))))
    ((repo entry)
     (pointer->object
      repo
      (git-tree-entry-to-object
       (repository->pointer repo)
       (tree-entry->pointer entry))))))

(define (create-tree repo #!optional (index (index-open repo)))
  (pointer->tree
   repo
   (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 tree (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
  ((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 tb (git-tree-entry-dup entry*))))

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

(define (tree-builder-write repo tb)
  (pointer->tree
   repo
   (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 repo (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
   (reference-repository ref)
   (git-branch-move (reference->pointer ref) name force)))

;; XXX Returns a reference.
(define (create-branch repo #!key name target force)
  (pointer->reference
   repo
   (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* ((repo* (repository->pointer repo))
         (iter  (set-finalizer! (git-branch-iterator-new repo* type) git-branch-iterator-free)))
     (let loop ((state knil))
       (let ((b (condition-case
                  (git-branch-next iter)
                  ((git) #f))))
         (if (not b)
             state
             (loop (kons (pointer->reference repo b) 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) git-checkout-options-default))
    ((index? object)
     (git-checkout-index (repository->pointer repo) (index->pointer object) git-checkout-options-default))
    ((memq (object-type object) '(commit tag tree))
     (git-checkout-tree (repository->pointer repo) (object->pointer object) git-checkout-options-default))
    (else
     (git-checkout-tree (repository->pointer repo) (->oid->pointer object) git-checkout-options-default))))

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

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

(define commit-header commit-raw-header)

(define commit-tree      (preserve-owner pointer->tree (compose 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
     (commit-repository cmt)
     (git-commit-parent (commit->pointer cmt) n))
    ((git) #f)))

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

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

(define (commit repo ref)
  (pointer->commit
   repo
   (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)))
    (if (git-repository-head-unborn repo*)
        '() ; No HEAD means no commits.
        (let ((iter (set-finalizer! (git-revwalk-new repo*) git-revwalk-free)))
          (if initial ; Set the initial revision.
              (git-revwalk-push iter (->oid->pointer initial))
              (git-revwalk-push-head iter))
          ;; Set sort mode, from '(none topo time rev).
          (git-revwalk-sorting iter sort)
          ;; Set hidden commits.
          (for-each (lambda (h) (git-revwalk-hide iter (->oid->pointer h))) hide)
          ;; Iterate commits.
          (let loop ((state knil))
            (let ((c (condition-case
                       (git-revwalk-next iter)
                       ((git) #f))))
              (if (not c)
                  state ; Exhausted iterator.
                  (loop (kons (pointer->commit
                               repo
                               (git-commit-lookup repo* c))
                              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
   repo
   (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
  ((blob repository) 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
   repo
   (git-blob-lookup
    (repository->pointer repo)
    (->oid->pointer ref))))

(define (create-blob repo source)
  (let ((repo* (repository->pointer repo)))
    (pointer->blob
     repo
     (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
  ((index) entrycount write clear)
  "#<index>"
  (git-index-free))

(define-git-record-type index-entry
  ((index-entry owner) 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-read ix #!optional force)
  (git-index-read (index->pointer ix) force))

(define (index-ref ix key)
  (let ((ix* (index->pointer ix)))
    (pointer->index-entry
     ix
     (cond ((number? key)
            (git-index-get-byindex ix* key))
           ((string? key)
            (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)
  (begin0-let ((state knil))
    (git-status-foreach
     (lambda (path status)
       (set! state (kons path status state)))
     (repository->pointer repo))))

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

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

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

(define (note repo object #!optional reference)
  (pointer->note
   repo
   (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
     repo
     (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
            (begin0-let ((state knil))
              (git-note-foreach
               repo*
               reference
               (lambda (bid* oid*)
                 (set! state
                   (kons (pointer->note repo (git-note-read repo* reference oid*)) state))))))))))

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

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

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

(define-git-record-type odb-object
  ((odb-object owner) 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
   odb
   (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
  ((tag repository) id name message)
  (format "#<tag ~S>" (tag-name tag))
  (git-tag-free))

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

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

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

(define tag-peel   (preserve-owner pointer->object (compose git-tag-peel tag->pointer)))
(define tag-target (preserve-owner pointer->object (compose 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
   repo
   (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
  ((diff-file owner) 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
  ((diff-delta owner) 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   (set-owner pointer->diff-file diff-delta-old-file))
(define diff-new-file   (set-owner pointer->diff-file diff-delta-new-file))

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

(define diff
  (let ((build-diff-list
         (lambda (diffs)
           (begin0-let ((acc '()))
             (git-diff-foreach
              (lambda (delta* progress)
                (set! acc (cons (pointer->diff-delta diffs delta*) acc)))
              diffs)))))
    (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
  ((remote repository) 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
  ((refspec remote) src dst string direction force)
  (format "#<refspec ~S ~S>" (refspec-src refspec) (refspec-dst refspec)))

(define-git-record-type transfer-progress
  ((transfer-progress remote) 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 lp ((i 0)
           (a '()))
    (cond ((git-remote-get-refspec (remote->pointer rem) i) =>
           (lambda (refspec)
             (lp (fx+ i 1)
                 (cons (pointer->refspec rem refspec) a))))
          (else a))))

(define (remote repo name)
  (pointer->remote repo (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
   rem
   (git-remote-stats (remote->pointer rem))))

;(define remote-download
;  (let ((make-remote-download-callback
;         (lambda (rem fn)
;           (and fn (lambda (tp*)
;                     (fn (pointer->transfer-progress rem tp*)))))))
;    (lambda (rem #!optional fn)
;      (if (remote-connected? rem)
;          (git-remote-download
;           (remote->pointer rem)
;           (make-remote-download-callback rem fn))
;          (dynamic-wind
;           (lambda ()
;             (remote-connect rem))
;           (lambda ()
;             (remote-download rem (make-remote-download-callback rem fn))
;             (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))
  "#<config>"
  (git-config-free))

(define-git-record-type config-entry
  ((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)))