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.

1 files changed, 4 insertions, 193 deletions

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."