From d3fbf85c7c93d18f976661d106976d5e42b7264c Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Sun, 13 Mar 2022 22:57:32 +0530
Subject: tissue: Reorganize code into scheme modules.
* bin/tissue: Do not import (rnrs hashtables) and (srfi
srfi-9). Import (tissue issue) and (tissue utils).
(<issue>, issues, hashtable-append!, comma-split, remove-prefix,
file-details): Move to tissue/issue.scm.
(call-with-input-pipe, get-line-dos-or-unix): Move to
tissue/utils.scm.
* tissue/issue.scm, tissue/utils.scm: New files.
---
bin/tissue | 197 ++-------------------------------------------------
tissue/issue.scm | 212 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
tissue/utils.scm | 45 ++++++++++++
3 files changed, 261 insertions(+), 193 deletions(-)
create mode 100644 tissue/issue.scm
create mode 100644 tissue/utils.scm
diff --git a/bin/tissue b/bin/tissue
index f2e87e1..4e3c747 100755
--- a/bin/tissue
+++ b/bin/tissue
@@ -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."
diff --git a/tissue/issue.scm b/tissue/issue.scm
new file mode 100644
index 0000000..b5813cd
--- /dev/null
+++ b/tissue/issue.scm
@@ -0,0 +1,212 @@
+;;; tissue --- Text based issue tracker
+;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of tissue.
+;;;
+;;; tissue is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; tissue is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with tissue. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (tissue issue)
+ #:use-module (rnrs hashtables)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-171)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (tissue utils)
+ #:export (issue
+ issue-file
+ issue-title
+ issue-creator
+ issue-created-date
+ issue-created-relative-date
+ issue-last-updater
+ issue-last-updated-date
+ issue-last-updated-relative-date
+ issue-assigned
+ issue-keywords
+ issue-open
+ issue-tasks
+ issue-completed-tasks
+ issue-posts
+ issues))
+
+(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 (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 (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 (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)))))
diff --git a/tissue/utils.scm b/tissue/utils.scm
new file mode 100644
index 0000000..5fce26d
--- /dev/null
+++ b/tissue/utils.scm
@@ -0,0 +1,45 @@
+;;; tissue --- Text based issue tracker
+;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of tissue.
+;;;
+;;; tissue is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; tissue is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with tissue. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (tissue utils)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 popen)
+ #:export (call-with-input-pipe
+ get-line-dos-or-unix))
+
+(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 (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))))
--
cgit v1.2.3