gnbug: Move to own repo.

gnbug is now tissue---the text based issue tracker. See
https://tissue.systemreboot.net/

* README.gmi: Replace gnbug with tissue.
* gnbug: Delete file.

1 files changed, 0 insertions, 546 deletions

diff --git a/gnbug b/gnbug
deleted file mode 100755
index 5e58db0..0000000
--- a/gnbug
+++ /dev/null
@@ -1,546 +0,0 @@
-#! /usr/bin/env guile
-!#
-
-(import (rnrs hashtables)
-        (rnrs io ports)
-        (srfi srfi-1)
-        (srfi srfi-9)
-        (srfi srfi-26)
-        (srfi srfi-37)
-        (srfi srfi-171)
-        (srfi srfi-171 gnu)
-        (ice-9 ftw)
-        (ice-9 match)
-        (ice-9 popen)
-        (ice-9 regex))
-
-(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."
-  (call-with-input-pipe
-   (lambda (port)
-     (port-transduce (compose (tmap (lambda (line)
-                                      (match (string-split line #\tab)
-                                        ((status file)
-                                         (list (match status
-                                                 ("A" 'added)
-                                                 ("D" 'deleted)
-                                                 ("M" 'modified))
-                                               file)))))
-                              transducer)
-                     (const #t) get-line port))
-   "git" "diff" "--stat" "--name-status"
-   (string-append start-commit ".." end-commit)))
-
-(define rlast
-  (case-lambda
-    (() #f)
-    ((result) result)
-    ((result input) input)))
-
-(define (git-first-commit-since since)
-  "Return the hash of the first git commit since SINCE, where SINCE is
-passed verbatim to the --since argument of `git log'. Return #f if
-there is no such commit."
-  (call-with-input-pipe
-   (lambda (port)
-     (port-transduce (tmap identity)
-                     rlast
-                     get-line
-                     port))
-   "git" "log" "--format=format:%H" "--since" since))
-
-;;;
-;;; 3 bit colors using ANSI escape codes
-;;;
-
-(define (color code str)
-  "Return STR within ANSI escape CODE, thus rendering it in color in a
-terminal."
-  (format #f "~a[~am~a~a[0m" #\esc code str #\esc))
-
-(define bold (cut color 1 <>))
-
-(define red (cut color 31 <>))
-(define green (cut color 32 <>))
-(define yellow (cut color 33 <>))
-(define blue (cut color 34 <>))
-(define magenta (cut color 35 <>))
-(define cyan (cut color 36 <>))
-
-(define red-background (cut color 41 <>))
-(define green-background (cut color 42 <>))
-(define yellow-background (cut color 43 <>))
-(define blue-background (cut color 44 <>))
-(define magenta-background (cut color 45 <>))
-(define cyan-background (cut color 46 <>))
-
-(define (invalid-option opt name arg loads)
-  (error "Invalid option" name))
-
-(define (invalid-operand arg loads)
-  (error "Invalid argument" arg))
-
-(define (command-line-program)
-  "Return the name, that is arg0, of the command-line program invoked
-to run gnbug."
-  (match (command-line)
-    ((program _ ...) program)))
-
-(define gnbug-news
-  (match-lambda*
-    (("--help")
-     (format #t "Usage: ~a news
-List recent updates.
-
-  --since=DATE  show updates more recent than DATE
-
-"
-             (command-line-program)))
-    (args
-     (let ((args (args-fold args
-                            (list (option (list "since") #t #f
-                                          (lambda (opt name arg loads)
-                                            (acons 'since arg loads))))
-                            invalid-option
-                            invalid-operand
-                            '())))
-       (unless (assq 'since args)
-         (error "--since argument required"))
-       (git-updated-files (tlog (match-lambda*
-                                  ((_ (status file))
-                                   (format #t ((case status
-                                                 ((added) green)
-                                                 ((deleted) red)
-                                                 ((modified) magenta))
-                                               "~a (~a)~%")
-                                           file
-                                           (case status
-                                             ((added) "new")
-                                             ((deleted) "deleted")
-                                             ((modified) "updated"))))))
-                          (or (git-first-commit-since (assq-ref args 'since))
-                              "HEAD")
-                          "HEAD")))))
-
-(define (print-issue issue-number issue)
-  "Print ISSUE with number ISSUE-NUMBER."
-  (display (magenta (issue-title issue)))
-  ;; Highlight keywords containing "bug" or "critical" as whole words
-  ;; in red. Else, highlight in blue.
-  (unless (null? (issue-keywords issue))
-    (display " ")
-    (display (string-join
-              (map (lambda (keyword)
-                     ((cond
-                       ((not (null? (lset-intersection
-                                     string=?
-                                     (string-split keyword #\space)
-                                     (list "bug" "critical"))))
-                        red-background)
-                       (else blue-background))
-                      (string-append " " keyword " ")))
-                   (issue-keywords issue))
-              " ")))
-  (unless (null? (issue-assigned issue))
-    (display (green (string-append " (assigned: "
-                                   (string-join (issue-assigned issue)
-                                                ", ")
-                                   ")"))))
-  (when (> (issue-posts issue) 1)
-    (display (string-append " ["
-                            (number->string (issue-posts issue))
-                            " posts]")))
-  (newline)
-  (display (string-append
-            (cyan (string-append "#" (number->string issue-number)))
-            " opened "
-            (cyan (issue-created-relative-date issue))
-            " by "
-            (cyan (issue-creator issue))))
-  (when (> (issue-posts issue) 1)
-    (display (string-append (cyan ",")
-                            " last updated "
-                            (cyan (issue-last-updated-relative-date issue))
-                            " by "
-                            (cyan (issue-last-updater issue)))))
-  (unless (zero? (issue-tasks issue))
-    (display (string-append (cyan "; ")
-                            (number->string (issue-completed-tasks issue))
-                            "/"
-                            (number->string (issue-tasks issue))
-                            " tasks done")))
-  (newline))
-
-(define (print-issue-to-gemtext issue-number issue)
-  "Print ISSUE with number ISSUE-NUMBER to gemtext."
-  (format #t "=> ~a ~a" (issue-file issue) (issue-title issue))
-  (unless (null? (issue-keywords issue))
-    (format #t " [~a]"
-            (string-join (issue-keywords issue)
-                         ", ")))
-  (unless (null? (issue-assigned issue))
-    (format #t " (assigned: ~a)"
-            (string-join (issue-assigned issue)
-                         ", ")))
-  (when (> (issue-posts issue) 1)
-    (format #t " [~a posts]" (issue-posts issue)))
-  (newline)
-  (format #t "~a opened ~a by ~a"
-          issue-number
-          (issue-created-relative-date issue)
-          (issue-creator issue))
-  (when (> (issue-posts issue) 1)
-    (format #t ", last updated ~a by ~a"
-            (issue-last-updated-relative-date issue)
-            (issue-last-updater issue)))
-  (unless (zero? (issue-tasks issue))
-    (format #t "; ~a/~a tasks done"
-            (issue-completed-tasks issue)
-            (issue-tasks issue)))
-  (newline)
-  (newline))
-
-(define gnbug-list
-  (match-lambda*
-    (("--help")
-     (format #t "Usage: ~a list [OPTIONS]
-List issues.
-
-  --assigned=ASSIGNED    only list issues assigned to ASSIGNED
-  --format=FORMAT        output in FORMAT (either text or gemtext, and text by default)
-
-"
-             (command-line-program)))
-    (args
-     (let ((args (args-fold args
-                            (list (option (list "assigned") #t #f
-                                          (lambda (opt name arg loads)
-                                            (acons 'assigned arg loads)))
-                                  (option (list "format") #t #f
-                                          (lambda (opt name arg loads)
-                                            (acons 'format
-                                                   (cond
-                                                    ((string=? arg "text") 'text)
-                                                    ((string=? arg "gemtext") 'gemtext)
-                                                    (else (error "Unknown format" arg)))
-                                                   loads))))
-                            invalid-option
-                            invalid-operand
-                            '((format . text)))))
-       (format #t "~%total ~a~%"
-               (list-transduce (compose (tenumerate 1)
-                                        (tfilter (match-lambda
-                                                   ((_ . issue)
-                                                    (and (issue-open issue)
-                                                         (or (not (assq 'assigned args))
-                                                             (member (assq-ref args 'assigned)
-                                                                     (issue-assigned issue)))))))
-                                        (tlog (match-lambda*
-                                                ((_ (index . issue))
-                                                 ((case (assq-ref args 'format)
-                                                    ((text) print-issue)
-                                                    ((gemtext) print-issue-to-gemtext))
-                                                  index issue)))))
-                               rcount
-                               (issues)))))))
-
-(define gnbug-edit
-  (match-lambda*
-    (("--help")
-     (format #t "Usage: ~a edit ISSUE-NUMBER
-Start $EDITOR to edit issue #ISSUE-NUMBER.
-
-"
-             (command-line-program)))
-    ((issue-number)
-     (unless (getenv "EDITOR")
-       (error "Please set the EDITOR environment variable to your favorite editor. For example,
-export EDITOR=emacsclient"))
-     (invoke (getenv "EDITOR")
-             (issue-file (list-ref (issues)
-                                   (1- (string->number issue-number))))))))
-
-(define gnbug-show
-  (match-lambda*
-    (("--help")
-     (format #t "Usage: ~a show ISSUE-NUMBER
-Show the text of issue #ISSUE-NUMBER.
-
-"
-             (command-line-program)))
-    ((issue-number)
-     (call-with-input-file (issue-file (list-ref (issues)
-                                                 (1- (string->number issue-number))))
-       (lambda (port)
-         (port-transduce
-          (compose
-           ;; Detect preformatted text blocks.
-           (tfold (match-lambda*
-                    (((pre? . _) line)
-                     (cons (if (string-prefix? "```" line)
-                               (not pre?)
-                               pre?)
-                           line)))
-                  (cons #f #f))
-           (tmap (lambda (pre?+line)
-                   (match pre?+line
-                     ((pre? . line)
-                      (cond
-                       ;; Print headlines in bold.
-                       ((string-prefix? "#" line)
-                        (display (bold line)))
-                       ;; Print lists in cyan.
-                       ((string-prefix? "*" line)
-                        (display (cyan line)))
-                       ;; Print links in cyan, but only the actual
-                       ;; link, and not the => prefix or the label.
-                       ((string-match "^(=>[ \t]*)([^ ]*)([^\n]*)" line)
-                        => (lambda (m)
-                             (display (match:substring m 1))
-                             (display (cyan (match:substring m 2)))
-                             (display (match:substring m 3))))
-                       ;; Print preformatted text backticks in
-                       ;; magenta.
-                       ((string-prefix? "```" line)
-                        (display (magenta line)))
-                       (else
-                        ;; If part of preformatted block, print in
-                        ;; magenta. Else, print in default color.
-                        (display (if pre? (magenta line) line))))))
-                   (newline))))
-          (const #t)
-          get-line-dos-or-unix
-          port))))))
-
-(define (print-usage)
-  (format #t "Usage: ~a COMMAND [OPTIONS] [ARGS]
-
-COMMAND must be one of the sub-commands listed below:
-
-  list      list issues
-  edit      edit an issue
-  show      show the text of an issue
-  news      list recent updates
-
-To get usage information for one of these sub-commands, run
-  ~a COMMAND --help
-
-"
-          (command-line-program)
-          (command-line-program)))
-
-(define main
-  (match-lambda*
-    ((_ (or "-h" "--help"))
-     (print-usage))
-    ((_ command args ...)
-     (apply (match command
-              ("news" gnbug-news)
-              ("list" gnbug-list)
-              ("edit" gnbug-edit)
-              ("show" gnbug-show)
-              (invalid-command
-               (format (current-error-port) "Invalid command `~a'~%~%"
-                       invalid-command)
-               (print-usage)
-               (exit #f)))
-            args))
-    ;; gnbug is an alias for `gnbug list'
-    ((_)
-     (gnbug-list))))
-
-(apply main (command-line))