diff options
Diffstat (limited to 'bin/tissue')
| -rwxr-xr-x | bin/tissue | 197 |
1 files changed, 4 insertions, 193 deletions
@@ -19,10 +19,8 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with tissue. If not, see <https://www.gnu.org/licenses/>. -(import (rnrs hashtables) - (rnrs io ports) +(import (rnrs io ports) (srfi srfi-1) - (srfi srfi-9) (srfi srfi-26) (srfi srfi-37) (srfi srfi-171) @@ -30,201 +28,14 @@ (ice-9 ftw) (ice-9 match) (ice-9 popen) - (ice-9 regex)) + (ice-9 regex) + (tissue issue) + (tissue utils)) (define (invoke program . args) (unless (zero? (apply system* program args)) (error "Invocation of program failed" (cons program args)))) -(define (call-with-input-pipe proc program . args) - "Execute PROGRAM ARGS ... in a subprocess with a pipe to it. Call -PROC with an input port to that pipe. Close the pipe once PROC exits, -even if it exits non-locally. Return the value returned by PROC." - (let ((port #f)) - (dynamic-wind (lambda () (set! port (apply open-pipe* OPEN_READ program args))) - (cut proc port) - (lambda () - (let ((return-value (status:exit-val (close-pipe port)))) - (unless (and return-value - (zero? return-value)) - (error "Invocation of program failed" (cons program args)))))))) - -(define-record-type <issue> - (issue file title creator created-date created-relative-date - last-updater last-updated-date last-updated-relative-date - assigned keywords open tasks completed-tasks posts) - issue? - (file issue-file) - (title issue-title) - (creator issue-creator) - (created-date issue-created-date) - (created-relative-date issue-created-relative-date) - (last-updater issue-last-updater) - (last-updated-date issue-last-updated-date) - (last-updated-relative-date issue-last-updated-relative-date) - (assigned issue-assigned) - (keywords issue-keywords) - (open issue-open) - (tasks issue-tasks) - (completed-tasks issue-completed-tasks) - (posts issue-posts)) - -(define (issues) - "Return a list of all issues, sorted oldest first." - ;; 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 (call-with-input-pipe - (lambda (port) - (port-transduce - (tfilter-map (lambda (file) - (and (string-suffix? ".gmi" file) - (not (string=? (basename file) "README.gmi")) - (not (string-prefix? "." (basename file))) - (let* ((file-details (file-details file)) - (all-keywords (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 'created-relative-date #f) - (hashtable-ref file-details 'last-updater #f) - (hashtable-ref file-details 'last-updated-date #f) - (hashtable-ref file-details 'last-updated-relative-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)))))) - rcons get-line port)) - "git" "ls-files") - (lambda (issue1 issue2) - (< (issue-created-date issue1) - (issue-created-date issue2))))) - -(define (hashtable-append! hashtable key new-values) - "Append NEW-VALUES to the list of values KEY is associated to in -HASHTABLE. If KEY is not associated to any value in HASHTABLE, assume -it is associated to the empty list." - (hashtable-update! - hashtable key (cut append <> new-values) '())) - -(define (comma-split str) - "Split string at commas, trim whitespace from both ends of the split -strings, and return them as a list." - (map (cut string-trim-both <>) - (string-split str #\,))) - -(define (remove-prefix prefix str) - "Remove PREFIX from STR." - (substring str (string-length prefix))) - -(define (get-line-dos-or-unix port) - "Read line from PORT. This differs from `get-line' in (rnrs io -ports) in that it also supports DOS line endings." - (let ((line (get-line port))) - (if (eof-object? line) - line - (string-trim-right line #\return)))) - -(define (file-details file) - "Return a hashtable of details extracted from gemini FILE." - (let ((result (make-eq-hashtable))) - (call-with-input-file file - (lambda (port) - (port-transduce (tmap (lambda (line) - (cond - ;; Lists with the assigned: prefix - ;; specify assignees. - ((string-prefix? "* assigned:" line) - (hashtable-append! result 'assigned - (comma-split - (remove-prefix "* assigned:" line)))) - ;; Lists with the keywords: prefix - ;; specify keywords. - ((string-prefix? "* keywords:" line) - (hashtable-append! result 'keywords - (comma-split - (remove-prefix "* keywords:" line)))) - ;; A more fuzzy heuristic to find keywords - ((and (string-prefix? "* " line) - ;; Is every comma-separated - ;; element two words utmost? - (every (lambda (element) - (<= (length - (string-split element #\space)) - 2)) - (comma-split (remove-prefix "* " line))) - ;; Does any comma-separated - ;; element contain a potential - ;; keyword? - (any (lambda (element) - (any (lambda (keyword) - (string-contains element keyword)) - (list "request" "bug" "critical" - "enhancement" "progress" - "testing" "later" "documentation" - "help" "closed"))) - (comma-split (remove-prefix "* " line)))) - (hashtable-append! result 'keywords - (comma-split - (remove-prefix "* " line)))) - ;; Checkbox lists are tasks. If the - ;; checkbox has any character other - ;; than space in it, the task is - ;; completed. - ((string-match "\\* \\[(.)\\]" line) - => (lambda (m) - (hashtable-update! result 'tasks 1+ 0) - (unless (string=? (match:substring m 1) " ") - (hashtable-update! result 'completed-tasks 1+ 0)))) - ;; The first level one heading is the - ;; title. - ((string-prefix? "# " line) - (unless (hashtable-contains? result 'title) - (hashtable-set! result 'title - (remove-prefix "# " line))))))) - (const #t) - get-line-dos-or-unix - port))) - (call-with-input-pipe - (lambda (port) - (hashtable-set! - result 'posts - (port-transduce - (compose (tenumerate) - (tmap (match-lambda - ((index . line) - (let ((alist (call-with-input-string line read))) - (when (zero? index) - (hashtable-set! result 'last-updater - (assq-ref alist 'author)) - (hashtable-set! result 'last-updated-date - (assq-ref alist 'author-date)) - (hashtable-set! result 'last-updated-relative-date - (assq-ref alist 'author-relative-date))) - (hashtable-set! result 'creator - (assq-ref alist 'author)) - (hashtable-set! result 'created-date - (assq-ref alist 'author-date)) - (hashtable-set! result 'created-relative-date - (assq-ref alist 'author-relative-date))))))) - rcount get-line port))) - "git" "log" - (string-append "--format=format:(" - "(author . \"%an\")" - "(author-date . %at)" - "(author-relative-date . \"%ar\")" - ")") - "--" file) - result)) - (define (git-updated-files transducer start-commit end-commit) "Use TRANSDUCER to transduce over the list of files updated between START-COMMIT and END-COMMIT." |