path: root/bin/tissue

#! /usr/bin/env guile
!#

;;; 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/>.

(import (rnrs io ports)
        (srfi srfi-1)
        (srfi srfi-26)
        (srfi srfi-37)
        (srfi srfi-171)
        (srfi srfi-171 gnu)
        (ice-9 match)
        (ice-9 popen)
        (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 (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 tissue."
  (match (command-line)
    ((program _ ...) program)))

(define tissue-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" (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 tissue-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 tissue-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 tissue-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" tissue-news)
              ("list" tissue-list)
              ("edit" tissue-edit)
              ("show" tissue-show)
              (invalid-command
               (format (current-error-port) "Invalid command `~a'~%~%"
                       invalid-command)
               (print-usage)
               (exit #f)))
            args))
    ;; tissue is an alias for `tissue list'
    ((_)
     (tissue-list))))

(apply main (command-line))