summaryrefslogtreecommitdiff
path: root/bin
diff options
context:
space:
mode:
authorArun Isaac2022-03-13 22:57:32 +0530
committerArun Isaac2022-03-13 23:02:10 +0530
commitd3fbf85c7c93d18f976661d106976d5e42b7264c (patch)
treea526d42460c330da1bd2797ab941a0c46b7a2791 /bin
parent20af13095723a44f58720670f3e98f04f7bf50b6 (diff)
downloadtissue-d3fbf85c7c93d18f976661d106976d5e42b7264c.tar.gz
tissue-d3fbf85c7c93d18f976661d106976d5e42b7264c.tar.lz
tissue-d3fbf85c7c93d18f976661d106976d5e42b7264c.zip
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.
Diffstat (limited to 'bin')
-rwxr-xr-xbin/tissue197
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."