;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; git.scm - libgit2 bindings for Chicken Scheme
;;;
;;; Copyright (c) 2013-2014, 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 record-instance?
                        make-locative move-memory! number-of-bytes)
          (rename (only data-structures o) (o compose))
          (prefix (except git-lolevel git-error) git-)
          (rename (only chicken make-blob blob?)
                  (blob? chicken-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))
             (pred?     (s+ name '?))
             (->pointer (s+ name '->pointer))
             (pointer-> (s+ 'pointer-> name)))
        `(begin
           (define-record-type ,name
             (,make pointer ,@slots)
             ,pred?
             (pointer ,->pointer)
             ,@(map (lambda (s)
                      `(,s ,(symbol-append name '- s)
                           ,(symbol-append name '- s '-set!)))
                    slots))
           (define-record-printer (,name ,name out)
             (display ,printer out))
           (define (,pointer-> ,@slots ptr)
             (and-let* ((ptr) ; TODO This check should go away.
                        (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)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Types
;;;

(define-type blob*             (struct blob))
(define-type commit            (struct commit))
(define-type config            (struct config))
(define-type config-entry      (struct config-entry))
(define-type diff              (struct diff))
(define-type diff-delta        (struct diff-delta))
(define-type diff-file         (struct diff-file))
(define-type diff-hunk         (struct diff-hunk))
(define-type diff-line         (struct diff-line))
(define-type index             (struct index))
(define-type index-entry       (struct index-entry))
(define-type note              (struct note))
(define-type odb               (struct odb))
(define-type odb-object        (struct odb-object))
(define-type oid               (struct oid))
(define-type patch             (struct patch))
(define-type reference         (struct reference))
(define-type refspec           (struct refspec))
(define-type repository        (struct repository))
(define-type remote            (struct remote))
(define-type signature         (struct signature))
(define-type tag               (struct tag))
(define-type transfer-progress (struct transfer-progress))
(define-type tree              (struct tree))
(define-type tree-builder      (struct tree-builder))
(define-type tree-entry        (struct tree-entry))

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

(define-type object  (or blob* commit tag tree))
(define-type oid-ish (or oid string reference object))

(: merge-base (repository oid oid -> commit))
(: object->oid (object -> oid))
(: object-id (object -> oid))
(: object-sha (object -> string))
(: object-type (object -> (or symbol false)))
(: object=? (object object -> boolean))
(: oid->path (oid -> string))
(: oid->string (oid #!optional fixnum -> string))
(: oid=? (oid oid -> boolean))
(: string->oid (string -> oid))

;; 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 (not (memq type '(ext1 ext2))) type)))

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

(define (object-sha obj #!optional (len 40))
  (oid->string (object->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 (object->oid obj)
  (cond ((oid? obj) obj)
        ((string? obj) (string->oid obj))
        ((reference? obj) (reference-target obj))
        ((record-instance? obj) (object-id obj))
        (else (error 'object->oid "Can't convert to OID" obj))))

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

(define (object->reference-name obj)
  (cond ((string? obj) obj)
        ((reference? obj) (reference-name obj))
        (else (git-error 'object->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
;;;

(: make-signature (string string #!optional fixnum fixnum -> signature))
(: signature-email (signature -> string))
(: signature-name (signature -> string))
(: signature-time (signature -> fixnum))
(: signature-time-offset (signature -> fixnum))
(: signature? (* --> boolean : signature))

(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
  (case-lambda
    ((repo)
     (pointer->signature (git-signature-default (repository->pointer repo))))
    ((name email)
     (pointer->signature (git-signature-now name email)))
    ((name email time offset)
     (pointer->signature (git-signature-new name email time offset)))))

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

(: create-repository (#!optional string * -> repository))
(: repository-bare? (repository -> boolean))
(: repository-empty? (repository -> boolean))
(: repository-head (repository -> reference))
(: repository-head-detached? (repository -> boolean))
(: repository-head-unborn? (repository -> boolean))
(: repository-open (#!optional string -> repository))
(: repository-path (repository -> string))
(: repository-ref (repository oid-ish #!optional symbol -> (or object false)))
(: repository-working-directory (repository -> string))
(: repository? (* --> boolean : repository))

(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)
      (object->oid->pointer ref)
      type))
    ((git) #f)))

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

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

(: parse-revision-specification
   (repository string -> (or object false) (or object false)))

(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
;;;

(: create-reference (repository #!rest -> reference))
(: reference (repository string -> reference))
(: reference-branch? (reference -> boolean))
(: reference-delete (reference -> void))
(: reference-name (reference -> string))
(: reference-remote? (reference -> boolean))
(: reference-rename (reference string #!optional * -> reference))
(: reference-repository (reference -> repository))
(: reference-resolve (reference -> reference))
(: reference-tag? (reference -> boolean))
(: reference-target (reference -> oid))
(: reference-target-set! (reference oid-ish -> void))
(: reference-type (reference -> symbol))
(: reference? (* --> boolean : reference))
(: references (repository #!optional string -> (list-of reference)))
(: references-fold
   (forall (a b)
           ((reference a -> b) a repository #!optional string -> (or a b))))

(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-tag?    (compose git-reference-is-tag    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 glob)
  (begin0-let ((state knil))
    (let* ((*repo    (repository->pointer repo))
           (callback (lambda (name)
                       (set! state
                         (kons (pointer->reference
                                repo
                                (git-reference-lookup *repo name))
                               state)))))
      (cond
        (glob (git-reference-foreach-glob *repo glob callback))
        (else (git-reference-foreach-name *repo callback))))))

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

(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 (object->oid->pointer target) force)
         ;; Symbolic references require the target to be given by a string.
         (git-reference-symbolic-create repo* name (object->reference-name target) force)))))

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

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

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

(: create-tree (repository #!optional index -> tree))
(: tree (repository oid-ish -> tree))
(: tree-entries (tree -> (list-of (pair string tree-entry))))
(: tree-entrycount (tree -> fixnum))
(: tree-fold (forall (a b) ((string tree-entry a -> b) a tree #!optional symbol -> (or a b))))
(: tree-id (tree -> oid))
(: tree-ref (tree (or fixnum oid string) -> (or tree-entry false)))
(: tree-repository (tree -> repository))
(: tree? (* --> boolean : tree))

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

(: tree-entry->object ((or repository tree-entry) #!optional tree-entry -> object))
(: tree-entry-attributes (tree-entry -> fixnum))
(: tree-entry-id (tree-entry -> oid))
(: tree-entry-name (tree-entry -> string))
(: tree-entry-owner (tree-entry -> (or tree tree-builder)))
(: tree-entry-type (tree-entry -> symbol))
(: tree-entry? (* --> boolean : tree-entry))

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

(define (tree-entry-attributes e)
  (git-filemode->int (tree-entry-filemode e)))

(define (tree repo ref)
  (pointer->tree
   repo
   (git-tree-lookup
    (repository->pointer repo)
    (object->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))
  (begin0-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)))

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

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

(: make-tree-builder (#!optional tree -> tree-builder))
(: tree-builder-clear (tree-builder -> void))
(: tree-builder-insert (tree-builder oid-ish string fixnum -> tree-entry))
(: tree-builder-ref (tree-builder string -> (or tree-entry false)))
(: tree-builder-remove (tree-builder string -> void))
(: tree-builder-write (repository tree-builder -> tree))
(: tree-builder? (* --> boolean : tree-builder))

(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
     (object->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-type branch reference)

(: branch (repository string #!optional symbol -> branch))
(: branch-delete (branch -> void))
(: branch-head? (branch -> boolean))
(: branch-name (branch -> string))
(: branch-rename (branch string #!optional boolean -> branch))
(: branches (repository #!optional symbol -> (list-of branch)))
(: branches-fold (forall (a b) ((branch a -> b) a repository #!optional symbol -> (or a b))))
(: create-branch (repository #!rest -> branch))

(define (branch repo name #!optional (type 'local))
  (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
;;;

(: checkout (repository #!optional (or index object) -> void))

(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) (object->oid->pointer object) git-checkout-options-default))))

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

(: commit (repository oid-ish -> commit))
(: commit-ancestor (commit #!optional fixnum -> (or commit false)))
(: commit-author (commit -> signature))
(: commit-committer (commit -> signature))
(: commit-header (commit -> string))
(: commit-id (commit -> oid))
(: commit-message (commit -> string))
(: commit-message-encoding (commit -> string))
(: commit-message-raw (commit -> string))
(: commit-parent (commit #!optional fixnum -> (or commit false)))
(: commit-parent-id (commit -> (or oid false)))
(: commit-parentcount (commit -> fixnum))
(: commit-parents (commit -> (list-of commit)))
(: commit-repository (commit -> repository))
(: commit-time (commit -> fixnum))
(: commit-time-offset (commit -> fixnum))
(: commit-tree (commit -> tree))
(: commit-tree-id (commit -> oid))
(: commit? (* --> boolean : commit))
(: commits (repository #!rest -> (list-of commit)))
(: commits-fold (forall (a b) ((commit a -> b) a repository #!rest -> (or a b))))
(: create-commit (repository #!rest -> commit))

(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-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-id c #!optional (n 0))
  (and-let* ((*id (git-commit-parent-id (commit->pointer c) n)))
    (pointer->oid (git-oid-cpy *id))))

(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)
    (object->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)))
          (cond ; Set the initial revision.
            ((not initial)
             (git-revwalk-push-head iter))
            ((list? initial)
             (for-each (lambda (r) (git-revwalk-push iter r))
                       (map object->oid->pointer initial)))
            (else
             (git-revwalk-push iter (object->oid->pointer initial))))
          ;; Set sort mode, from '(none topo time rev).
          (git-revwalk-sorting iter sort)
          ;; Set hidden commits.
          (for-each (lambda (h) (git-revwalk-hide iter (object->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 (object->reference-name reference))
     (signature->pointer author)
     (signature->pointer committer)
     message
     (tree->pointer tree)
     (map commit->pointer parents)))))

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

(: blob (repository oid-ish -> blob*))
(: blob-binary? (blob* -> boolean))
(: blob-content (blob* -> blob))
(: blob-id (blob* -> oid))
(: blob-length (blob* -> fixnum))
(: blob-repository (blob* -> repository))
(: blob? (* --> boolean : blob*))
(: create-blob (repository (or blob string) -> blob*))

(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)
    (object->oid->pointer ref))))

(define (create-blob repo source)
  (let ((repo* (repository->pointer repo)))
    (pointer->blob
     repo
     (git-blob-lookup
      repo*
      (cond ((chicken-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)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Ignore
;;;

(: path-ignored? (repository string -> boolean))
(: ignore-add! (repository string -> void))
(: ignore-clear! (repository -> void))

(define (path-ignored? repo path)
  (git-ignore-path-is-ignored (repository->pointer repo) path))

(define (ignore-add! repo path)
  (git-ignore-add-rule (repository->pointer repo) path))

(define (ignore-clear! repo)
  (git-ignore-clear-internal-rules (repository->pointer repo)))

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

(: index-add (index (or index-entry string) -> void))
(: index-clear (index -> void))
(: index-entrycount (index -> fixnum))
(: index-find (index string -> (or fixnum false)))
(: index-open ((or string repository) -> index))
(: index-read (index #!optional boolean -> void))
(: index-ref (index (or fixnum string) -> (or index-entry false)))
(: index-remove (index fixnum -> void))
(: index-write (index -> fixnum))
(: index? (* --> boolean : index))

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

(: index-entry-ctime (index-entry -> fixnum))
(: index-entry-dev (index-entry -> fixnum))
(: index-entry-extended (index-entry -> fixnum))
(: index-entry-flags (index-entry -> fixnum))
(: index-entry-gid (index-entry -> fixnum))
(: index-entry-id (index-entry -> oid))
(: index-entry-ino (index-entry -> fixnum))
(: index-entry-mode (index-entry -> fixnum))
(: index-entry-mtime (index-entry -> fixnum))
(: index-entry-owner (index-entry -> index))
(: index-entry-path (index-entry -> string))
(: index-entry-size (index-entry -> fixnum))
(: index-entry-stage (index-entry -> fixnum))
(: index-entry-uid (index-entry -> fixnum))
(: index-entry? (* --> boolean : index-entry))

(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))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; File status
;;;

(define-type status (or symbol (list-of symbol)))

(: file-ignored? (repository string -> boolean))
(: file-status (repository string -> status))
(: file-statuses (repository -> (list-of (pair string status))))
(: file-statuses-fold
   (forall (a b) ((string status a -> b) a repository -> (or a b))))

(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
;;;

(: create-note (repository #!rest -> note))
(: delete-note (repository #!rest -> void))
(: note (repository oid-ish #!optional string -> note))
(: note-id (note -> oid))
(: note-message (note -> string))
(: note-repository (note -> repository))
(: note? (* --> boolean : note))
(: notes (repository #!optional reference -> (list-of note)))
(: notes-fold
   (forall (a b) ((note a -> b) a repository #!optional reference -> (or a b))))

(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
    (object->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)
   (object->oid->pointer target)))

(define (create-note repo #!key message target reference author (committer author) force)
  (let ((repo* (repository->pointer repo))
        (oid*  (object->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
;;;

(: odb-has-object? (odb oid-ish -> boolean))
(: odb-hash (* #!optional symbol -> oid))
(: odb-object-data (odb-object -> blob))
(: odb-object-id (odb-object -> oid))
(: odb-object-owner (odb-object -> odb))
(: odb-object-size (odb-object -> fixnum))
(: odb-object-type (odb-object -> symbol))
(: odb-object? (* --> boolean : odb-object))
(: odb-open ((or string repository) -> odb))
(: odb-read (odb oid-ish -> odb-object))
(: odb-write (odb * #!optional symbol -> oid))
(: odb? (* --> boolean : 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)
   (object->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)
    (object->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
;;;

(: create-tag (repository #!rest -> tag))
(: tag (repository oid-ish -> tag))
(: tag-delete (tag -> void))
(: tag-id (tag -> oid))
(: tag-message (tag -> string))
(: tag-name (tag -> string))
(: tag-peel (tag -> object))
(: tag-repository (tag -> repository))
(: tag-tagger (tag -> signature))
(: tag-target (tag -> object))
(: tag? (* --> boolean : tag))
(: tags (repository -> (list-of tag)))
(: tags-fold (forall (a b) ((tag a -> b) a repository -> (or a b))))

(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)
    (object->oid->pointer ref))))

(define (tags-fold kons knil repo)
  (begin0-let ((state knil)
               (repo* (repository->pointer repo)))
    (git-tag-foreach
     (lambda (name oid*)
       ;; Skip lightweight tags (for which git_tag_lookup fails).
       (and-let* ((tag* (condition-case
                          (git-tag-lookup repo* oid*)
                          ((git) #f))))
         (set! state (kons (pointer->tag repo tag*) state))))
     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
;;;

(: diff (repository #!optional (or index tree) (or index tree) -> diff))
(: diff->string (diff -> string))
(: diff-delta-hunks (diff-delta -> (list-of diff-hunk)))
(: diff-delta-new-file (diff-delta -> (or diff-file false)))
(: diff-delta-old-file (diff-delta -> (or diff-file false)))
(: diff-delta-path (diff-delta -> string))
(: diff-delta-status (diff-delta -> symbol))
(: diff-delta? (* --> boolean : diff-delta))
(: diff-deltas (diff -> (list-of diff-delta)))
(: diff-file-flags (diff-file -> fixnum))
(: diff-file-id (diff-file -> oid))
(: diff-file-mode (diff-file -> fixnum))
(: diff-file-path (diff-file -> string))
(: diff-file-size (diff-file -> fixnum))
(: diff-file? (* --> boolean : diff-file))
(: diff-fold (forall (a b) ((diff-delta a -> b) a diff -> (or a b))))
(: diff-hunk-header (diff-hunk -> string))
(: diff-hunk-header-len (deprecated diff-hunk-header-length))
(: diff-hunk-header-length (diff-hunk -> fixnum))
(: diff-hunk-lines (diff-hunk -> (list-of diff-line)))
(: diff-hunk-new-lines (diff-hunk -> fixnum))
(: diff-hunk-new-start (diff-hunk -> fixnum))
(: diff-hunk-old-lines (diff-hunk -> fixnum))
(: diff-hunk-old-start (diff-hunk -> fixnum))
(: diff-hunk? (* --> boolean : diff-hunk))
(: diff-line-content (diff-line -> string))
(: diff-line-content-len (deprecated diff-line-content-length))
(: diff-line-content-length (diff-line -> fixnum))
(: diff-line-content-offset (diff-line -> fixnum))
(: diff-line-new-lineno (diff-line -> fixnum))
(: diff-line-num-lines (diff-line -> fixnum))
(: diff-line-old-lineno (diff-line -> fixnum))
(: diff-line-origin (diff-line -> char))
(: diff-line? (* --> boolean : diff-line))
(: diff-num-deltas (diff -> fixnum))
(: diff-patch (diff fixnum -> patch))
(: diff-patches (diff -> (list-of patch)))
(: diff-repository (diff -> repository))
(: diff? (* --> boolean : diff))
(: diffs (deprecated diff-deltas))

(define-git-record-type diff
  ((diff repository) num-deltas)
  (format "#<diff (~a)>" (diff-num-deltas diff))
  (git-diff-free))

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

(define-git-record-type diff-delta
  ((diff-delta diff hunks) old-file new-file status)
  (format "#<diff-delta (~a) ~s>" (diff-delta-status diff-delta) (diff-delta-path diff-delta)))

(define-git-record-type diff-hunk
  ((diff-hunk diff lines) old-start old-lines new-start new-lines header-length header)
  (format "#<diff-hunk ~s>" (diff-hunk-header diff-hunk)))

(define-git-record-type diff-line
  ((diff-line diff content) origin old-lineno new-lineno num-lines content-length content-offset)
  (format "#<diff-line (~a)>" (diff-line-origin diff-line)))

(define diff-delta-old-file (preserve-owner pointer->diff-file diff-delta-old-file))
(define diff-delta-new-file (preserve-owner pointer->diff-file diff-delta-new-file))

(define diff-hunk-header-len diff-hunk-header-length)
(define diff-line-content-len diff-line-content-length)

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

(define (diff-fold kons knil diff)
  ;; This is ugly: the git_diff_{hunk,line} structs associated with a
  ;; git_diff are only valid for the duration of the callbacks that
  ;; produce them (and the git_diff_delta only until its git_diff is
  ;; freed), so any non-immediate data we want to be available later
  ;; (like the structs themselves, and anything accessed by reference
  ;; through their fields) have to be copied out. Some of this is done
  ;; in git-lolevel.scm (`git_diff_file_cb` et al.), and some is done
  ;; below.
  (begin0-let ((state knil)
               (delta #f)
               (hunk #f))
    (let ((yield!
           (lambda ()
             (diff-delta-hunks-set!
              delta
              (foldl (lambda (a hunk)
                       (diff-hunk-lines-set!
                        hunk
                        (reverse (diff-hunk-lines hunk)))
                       (cons hunk a))
                     '()
                     (diff-delta-hunks delta)))
             (begin0-let ((state* (kons delta state)))
               (set! state state*)))))
      (git-diff-foreach
       (lambda (*delta)
         (when delta (yield!))
         (set! delta (pointer->diff-delta diff '() *delta)))
       (lambda (*delta *hunk)
         (set! hunk (pointer->diff-hunk delta '() *hunk))
         (diff-delta-hunks-set! delta (cons hunk (diff-delta-hunks delta))))
       (lambda (*delta *hunk *line)
         (let* ((len  (git-diff-line-content-length *line))
                (str  (make-string len))
                (line (pointer->diff-line hunk str *line)))
           (move-memory! (git-diff-line-content *line) str len)
           (diff-hunk-lines-set! hunk (cons line (diff-hunk-lines hunk)))))
       (diff->pointer diff))
      (when delta (yield!)))))

(define diff
  (case-lambda
    ((repo)
     (diff repo (index-open repo)))
    ((repo object)
     (pointer->diff
      repo ; Stored as the diff's parent object.
      (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)
     (pointer->diff
      repo ; Stored as the diff's parent object.
      (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))))))))

(define diff-deltas
  (case-lambda
    ((diff)
     (diff-fold cons '() diff))
    (args ; Deprecated.
     (diff-fold cons '() (apply diff args)))))

;; Deprecated (above).
(define diffs diff-deltas)

(define (diff-patch diff i)
  (pointer->patch
   (diff-repository diff)
   (git-patch-from-diff (diff->pointer diff) i)))

(define (diff-patches diff)
  (do ((n (fx- (diff-num-deltas diff) 1)
          (fx- n 1))
       (a (list)
          (cons (diff-patch diff n) a)))
      ((fx< n 0) a)))

(define (diff->string diff)
  (do ((n (fx- (diff-num-deltas diff) 1)
          (fx- n 1))
       (s (string)
          (string-append (patch->string (diff-patch diff n)) s)))
      ((fx= n 0) s)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Patch
;;;

(: patch (blob* (or string blob) -> patch))
(: patch->string (patch -> string))
(: patch-size (patch -> fixnum))
(: patch-stats (patch -> (vector fixnum fixnum fixnum)))
(: patch? (* --> boolean : patch))

(define-git-record-type patch
  ((patch repository) num-hunks line-stats)
  (format "#<patch (~a)>" (patch-num-hunks patch))
  (git-patch-free))

(define patch-stats patch-line-stats)

(define patch->string
  (compose git-patch-to-str patch->pointer))

(define (patch-size patch)
  (git-patch-size
   (patch->pointer patch)
   #t   ; Context.
   #t   ; Hunk headers.
   #t)) ; Line headers.

;; TODO How best to pass the path arguments?
(define (patch blob1 object2)
  (pointer->patch
   (blob-repository blob1)
   (cond
     ((blob? object2)
      (git-patch-from-blobs
       (blob->pointer blob1)
       #f      ; blob1 pathname.
       (blob->pointer blob1)
       #f      ; blob2 pathname.
       #f))    ; diff options.
     ((or (string? object2)
          (chicken-blob? object2))
      (git-patch-from-blob-and-buffer
       (blob->pointer blob1)
       #f      ; blob1 pathname.
       (make-locative object2)
       (number-of-bytes object2)
       #f      ; object2 pathname.
       #f))))) ; diff options.

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

(define-git-record-type remote
  ((remote repository) clear-refspecs connected disconnect fetch name pushurl refspec-count stop save update-fetchhead update-tips url)
  (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-source refspec) (refspec-destination 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 refspec-force? refspec-force)

(define remote-clear-refspecs! remote-clear-refspecs)
(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-disconnect! remote-disconnect)
(define remote-fetch! remote-fetch)
(define remote-update-tips! remote-update-tips)
(define remote-update-fetchhead? remote-update-fetchhead)

(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-refspec-add! rem spec #!optional (direction 'fetch))
  (case direction
    ((fetch) (git-remote-add-fetch (remote->pointer rem) spec))
    ((push)  (git-remote-add-push  (remote->pointer rem) spec))
    (else    (git-error 'remote-refspec-add! "Invalid refspec direction" direction))))

(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! rem)
  (cond ((remote-connected? rem)
         (git-remote-download (remote->pointer rem))
         (remote-stats rem))
        (else
         (remote-connect! rem)
         (remote-download! rem)
         (remote-disconnect! rem)
         (remote-stats rem))))

(define (create-remote repo name url)
  (pointer->remote repo (git-remote-create (repository->pointer repo) name url)))

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

(: clone (string string -> repository))

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

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

(define-type config-value (or string boolean number))

(: config-get (config string #!optional symbol -> config-value))
(: config-open (#!optional (or string symbol repository) -> config))
(: config-path (#!optional symbol -> string))
(: config-set! (config string config-value -> void))
(: config-unset! (config string -> void))
(: config? (* --> boolean : config))

(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! config name)
  (git-config-delete-entry (config->pointer config) name)))