issue: Lookup commits affecting file using guile-git.

* tissue/git.scm: Import (rnrs hashtables) and (ice-9 match).
(commit-deltas): New function.
(file-modification-table): New public function.
* tissue/issue.scm: Import (git).
(file-details): Do not lookup git history for file using `git log'.
(issues): Use file-modification-table to lookup git history.

2 files changed, 92 insertions, 54 deletions

diff --git a/tissue/git.scm b/tissue/git.scm
index 4b7f7c7..fcfc6c7 100644
--- a/tissue/git.scm
+++ b/tissue/git.scm
@@ -18,11 +18,13 @@
 
 (define-module (tissue git)
   #:use-module (rnrs arithmetic bitwise)
+  #:use-module (rnrs hashtables)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-171)
+  #:use-module (ice-9 match)
   #:use-module (git)
   #:use-module (git types)
   ;; There are many name conflicts between (system foreign). So, we
@@ -42,7 +44,8 @@
   #:export (git-top-level
             current-git-repository
             commit-date
-            git-tracked-files))
+            git-tracked-files
+            file-modification-table))
 
 ;; We bind additional functions from libgit2 that are not already
 ;; bound in guile-git. TODO: Contribute them to guile-git.
@@ -197,3 +200,54 @@ filenames are relative to the top-level directory of REPOSITORY and do
 not have a leading slash."
   (map index-entry-path
        (index-entries (repository-index repository))))
+
+(define (commit-deltas repository commit)
+  "Return the list of <diff-delta> objects created by COMMIT with
+respect to its first parent in REPOSITORY."
+  (match (commit-parents commit)
+    ((parent _ ...)
+     (let ((diff (diff-tree-to-tree repository
+                                    (commit-tree parent)
+                                    (commit-tree commit))))
+       (diff-find-similar! diff)
+       (diff-fold (lambda (delta progress result)
+                    (cons delta result))
+                  (lambda (delta binary result)
+                    result)
+                  (lambda (delta hunk result)
+                    result)
+                  (lambda (delta hunk line result)
+                    result)
+                  (list)
+                  diff)))
+    (() (list))))
+
+(define (file-modification-table repository)
+  "Return a hashtable mapping files to the list of commits in REPOSITORY
+that modified them."
+  (let ((result (make-hashtable string-hash string=?))
+        (renames (make-hashtable string-hash string=?)))
+    (fold-commits
+     (lambda (commit _)
+       (map (lambda (delta)
+              ;; Map old filename to current filename if they are
+              ;; different. Note that this manner of following renames
+              ;; requires a linear git history and will not work with
+              ;; branch merges.
+              (unless (string=? (diff-file-path (diff-delta-old-file delta))
+                                (diff-file-path (diff-delta-new-file delta)))
+                (hashtable-set! renames
+                                (diff-file-path (diff-delta-old-file delta))
+                                (diff-file-path (diff-delta-new-file delta))))
+              (hashtable-update! result
+                                 ;; If necessary, translate old
+                                 ;; filename to current filename.
+                                 (hashtable-ref renames
+                                                (diff-file-path (diff-delta-old-file delta))
+                                                (diff-file-path (diff-delta-old-file delta)))
+                                 (cut cons commit <>)
+                                 (list)))
+            (commit-deltas repository commit)))
+     #f
+     repository)
+    result))
diff --git a/tissue/issue.scm b/tissue/issue.scm
index f41576d..8f36d94 100644
--- a/tissue/issue.scm
+++ b/tissue/issue.scm
@@ -27,6 +27,7 @@
   #:use-module (srfi srfi-171)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (git)
   #:use-module (tissue git)
   #:use-module (tissue utils)
   #:export (%issue-files
@@ -225,32 +226,6 @@ in (tissue tissue). If no alias is found, NAME is returned as such."
                           (const #t)
                           get-line-dos-or-unix
                           port))))
-    (call-with-input-pipe
-     (lambda (port)
-       (hashtable-set!
-        result 'posts
-        (reverse
-         (port-transduce
-          (compose (tenumerate)
-                   (tmap (match-lambda
-                           ((index . line)
-                            (let* ((alist (call-with-input-string line read))
-                                   (author (resolve-alias (assq-ref alist 'author)
-                                                          (%aliases)))
-                                   (date (assq-ref alist 'author-date)))
-                              (when (zero? index)
-                                (hashtable-set! result 'last-updater author)
-                                (hashtable-set! result 'last-updated-date (unix-time->date date)))
-                              (hashtable-set! result 'creator author)
-                              (hashtable-set! result 'created-date (unix-time->date date))
-                              (post author date))))))
-          rcons get-line port))))
-     "git" "log" "--follow"
-     (string-append "--format=format:("
-                    "(author . \"%an\")"
-                    "(author-date . %at)"
-                    ")")
-     "--" file)
     result))
 
 (define issues
@@ -260,30 +235,39 @@ in (tissue tissue). If no alias is found, NAME is returned as such."
      ;; Get all gemini files except README.gmi and hidden files. Text
      ;; editors tend to create hidden files while editing, and we want to
      ;; avoid them.
-     (sort (filter-map (lambda (file)
-                         (let* ((file-details (file-details file))
-                                ;; Downcase keywords to make them
-                                ;; case-insensitive.
-                                (all-keywords (map string-downcase
-                                                   (hashtable-ref file-details 'keywords '()))))
-                           (issue file
-                                  ;; Fallback to filename if title has no alphabetic
-                                  ;; characters.
-                                  (let ((title (hashtable-ref file-details 'title "")))
-                                    (if (string-any char-set:letter title) title file))
-                                  (hashtable-ref file-details 'creator #f)
-                                  (hashtable-ref file-details 'created-date #f)
-                                  (hashtable-ref file-details 'last-updater #f)
-                                  (hashtable-ref file-details 'last-updated-date #f)
-                                  (hashtable-ref file-details 'assigned '())
-                                  ;; "closed" is a special keyword to indicate
-                                  ;; the open/closed status of an issue.
-                                  (delete "closed" all-keywords)
-                                  (not (member "closed" all-keywords))
-                                  (hashtable-ref file-details 'tasks 0)
-                                  (hashtable-ref file-details 'completed-tasks 0)
-                                  (hashtable-ref file-details 'posts #f))))
-                       (%issue-files))
-           (lambda (issue1 issue2)
-             (time<? (date->time-monotonic (issue-created-date issue1))
-                     (date->time-monotonic (issue-created-date issue2))))))))
+     (let ((file-modification-table (file-modification-table (current-git-repository))))
+       (sort (filter-map (lambda (file)
+                           (let* ((file-details (file-details file))
+                                  ;; Downcase keywords to make them
+                                  ;; case-insensitive.
+                                  (all-keywords (map string-downcase
+                                                     (hashtable-ref file-details 'keywords '())))
+                                  (commits (hashtable-ref file-modification-table file #f))
+                                  (commit-authors (map (lambda (commit)
+                                                         (resolve-alias (signature-name (commit-author commit))
+                                                                        (%aliases)))
+                                                       commits)))
+                             (issue file
+                                    ;; Fallback to filename if title has no alphabetic
+                                    ;; characters.
+                                    (let ((title (hashtable-ref file-details 'title "")))
+                                      (if (string-any char-set:letter title) title file))
+                                    (first commit-authors)
+                                    (commit-date (first commits))
+                                    (last commit-authors)
+                                    (commit-date (last commits))
+                                    (hashtable-ref file-details 'assigned '())
+                                    ;; "closed" is a special keyword to indicate
+                                    ;; the open/closed status of an issue.
+                                    (delete "closed" all-keywords)
+                                    (not (member "closed" all-keywords))
+                                    (hashtable-ref file-details 'tasks 0)
+                                    (hashtable-ref file-details 'completed-tasks 0)
+                                    (map (lambda (commit author)
+                                           (post author (commit-date commit)))
+                                         commits
+                                         commit-authors))))
+                         (%issue-files))
+             (lambda (issue1 issue2)
+               (time<? (date->time-monotonic (issue-created-date issue1))
+                       (date->time-monotonic (issue-created-date issue2)))))))))