diff options
| -rw-r--r-- | tissue/git.scm | 56 | ||||
| -rw-r--r-- | tissue/issue.scm | 90 |
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))))))))) |