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

(module git
  (object-id object-type object-sha object-owner object=?
   string->oid oid->string oid->path oid? oid=? merge-base
   repository? create-repository repository-open repository-path repository-working-directory
   repository-empty? repository-bare? repository-head-orphan? repository-head-detached?
   repository-ref repository-head
   reference? reference references create-reference reference-resolve
   reference-name reference-target reference-type
   reference-target-set! reference-rename reference-delete
   commit? commit commits commits-fold create-commit commit-id
   commit-message commit-message-encoding
   commit-time commit-time-offset commit-parentcount
   commit-author commit-committer commit-parent commit-tree commit-tree-id
   blob*? blob* create-blob* blob*-content blob*-size blob*-binary?
   index? index-open index-find index-ref
   index-clear index-add index-remove index-read index-write index-entrycount
   index-entry? index-entry-dev index-entry-ino index-entry-mode
   index-entry-uid index-entry-gid index-entry-size index-entry-stage
   index-entry-flags index-entry-extended index-entry-path
   index-entry-id index-entry-ctime index-entry-mtime
   odb? odb-open odb-has-object? odb-read odb-write odb-hash
   odb-object? odb-object-id odb-object-data odb-object-size odb-object-type
   remote remotes remote-name remote-url remote-pushurl remote-pushspec remote-fetchspec
   remote-connect remote-connected? remote-disconnect remote-download
   remote-pushspec-set! remote-fetchspec-set! remote-url-set! remote-pushurl-set! remote-update-fetchhead-set!
   remote-url-valid? remote-url-supported?
   refspec-source refspec-destination
   transfer-progress-total-objects transfer-progress-indexed-objects
   transfer-progress-received-objects transfer-progress-received-bytes
   signature? make-signature signature-name signature-email signature-time signature-time-offset
   tag? tag tags tags-fold create-tag tag-id tag-name tag-message tag-delete tag-tagger tag-target tag-peel
   tree? tree tree-id tree-entrycount create-tree tree-ref tree-fold tree-entries
   tree-entry? tree-entry-id tree-entry-name tree-entry-type tree-entry->object
   make-tree-builder tree-builder-ref tree-builder-insert tree-builder-remove tree-builder-clear tree-builder-write
   diff? diff diff-similarity diff-status diff-path diff-old-file diff-new-file
   diff-file? diff-file-id diff-file-mode diff-file-path diff-file-size diff-file-flags
   config? config-open config-path config-get config-set! config-unset!
   file-status file-statuses file-statuses-fold file-ignored?)
  (import scheme
    (except chicken repository-path)
    (only extras format)
    (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-)
    (only git-lolevel git-error))
  (require-library extras posix files lolevel data-structures git-lolevel)

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

(define-for-syntax (s+ . args)
  (string->symbol (apply string-append (map symbol->string args))))

(define-syntax define-git-record-type
  (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)))
                    `(define (,getter obj)
                       ,(case attr
                          ((id)
                           `(pointer->oid (,(s+ 'git- getter) (,->pointer obj))))
                          (else
                           `(,(s+ 'git- getter) (,->pointer obj)))))))
                attr)))))

(define ((partial f . a) . b) (apply f (append a b)))
(define ((pointer-tagger t) p) (and p (tag-pointer p t)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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-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 (->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 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)))
  ;; Try opening path as a "normal" repo first (i.e. a workdir with a
  ;; `.git` directory), and if that doesn't work try as a "bare" repo.
  (let ((path (normalize-pathname path)))
    (pointer->repository
     (condition-case
      (git-repository-open (make-pathname path ".git"))
      ((git) (git-repository-open path))))))

(define (repository-ref repo ref #!optional (type 'any))
  (condition-case
    (pointer->object
     (git-object-lookup
      (repository->pointer repo)
      (oid->pointer (->oid 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))

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

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

(define repository-head   (compose pointer->reference repository-head))
(define reference-resolve (compose pointer->reference git-reference-resolve 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)))
         (target (git-reference-target ref*)))
    (git-reference-free ref*)
    (pointer->oid target)))

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

(define (references repo #!optional (type 'listall))
  (let ((repo* (repository->pointer repo)))
    (map (lambda (name) (pointer->reference (git-reference-lookup repo* name)))
         (git-reference-list 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 (->oid 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 (->oid 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 (->oid 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 (->oid 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*)
       (void tree) ; Prevent GC.
       (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 (->oid 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

;; 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 repo old new #!optional force)
  (git-branch-move (repository->pointer repo) old new force))

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

(define (branch-delete repo name #!optional (type 'local))
  (git-branch-delete (repository->pointer repo) name type))

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

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

(define commit-tree      (compose pointer->tree git-commit-tree commit->pointer))
(define commit-tree-id   (compose pointer->oid 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 cmt #!optional (n 0))
  (condition-case
    (pointer->commit (git-commit-parent (commit->pointer cmt) n))
    ((git) #f)))

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

(define (commits-fold kons knil repo #!key initial (hide '()) (sort 'none))
  (let ((walker #f))
    (dynamic-wind
     (lambda ()
       (set! walker (git-revwalk-new (repository->pointer repo))))
     (lambda ()
       ;; 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 (compose (partial git-revwalk-hide walker) oid->pointer ->oid) hide)
       ;; Set initial revision.
       (condition-case
         (begin
           (if initial
               (git-revwalk-push walker (oid->pointer (->oid initial)))
               (git-revwalk-push-head walker))
           (let lp ((state knil))
             (condition-case
               (lp (kons (pointer->commit
                          (git-commit-lookup
                           (repository->pointer repo)
                           (git-revwalk-next walker)))
                         state))
               ((git) state))))
         ((git) '())))
     (lambda ()
       (git-revwalk-free walker)))))

(define (commits repo . 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* rawsize rawcontent is-binary)
  (format "#<blob* ~S>" (oid->string (->oid blob*) 7))
  (git-blob*-free))

(define blob*-size    blob*-rawsize)
(define blob*-content blob*-rawcontent)
(define blob*-binary? blob*-is-binary)

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

(define (blob* repo ref)
  (pointer->blob*
   (git-blob*-lookup
    (repository->pointer repo)
    (oid->pointer (->oid 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)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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-id    (compose pointer->oid index-entry-oid))
(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))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 (->oid 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 (->oid 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-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 (->oid 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-file-id    (compose pointer->oid diff-file-oid))

(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 pushspec fetchspec 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)
  (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-pushspec  (compose pointer->refspec remote-pushspec))
(define remote-fetchspec (compose pointer->refspec remote-fetchspec))

(define ((remote-attribute-setter fn) rem arg) (fn (refspec->pointer rem) arg))
(define remote-pushspec-set!         (remote-attribute-setter git-remote-set-pushspec))
(define remote-fetchspec-set!        (remote-attribute-setter git-remote-set-fetchspec))
(define remote-url-set!              (remote-attribute-setter git-remote-set-url))
(define remote-pushurl-set!          (remote-attribute-setter git-remote-set-pushurl))
(define remote-update-fetchhead-set! (remote-attribute-setter git-remote-update-fetchhead))

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

(define (remotes repo)
  (map (cut remote repo <>) (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-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))
       (lambda () (remote-disconnect rem)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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-open "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)))