path: root/bin/tissue

#!/usr/bin/env sh
exec guile --no-auto-compile -s "$0" "$@"
!#

;;; 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 exceptions)
        (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 conditions)
        (tissue git)
        (tissue issue)
        (tissue tissue)
        (tissue utils)
        (tissue web))

(define (invoke program . args)
  (unless (zero? (apply system* program args))
    (error "Invocation of program failed" (cons program args))))

(define rlast
  (case-lambda
    (() #f)
    ((result) result)
    ((result input) input)))

;;;
;;; 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 (print-issue issue-number issue)
  "Print ISSUE with number ISSUE-NUMBER."
  (let ((number-of-posts (length (issue-posts issue))))
    (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 (> number-of-posts 1)
      (display (string-append " ["
                              (number->string number-of-posts)
                              " 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 (> number-of-posts 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."
  (let ((number-of-posts (length (issue-posts issue))))
    (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 (> number-of-posts 1)
      (format #t " [~a posts]" number-of-posts))
    (newline)
    (format #t "~a opened ~a by ~a"
            issue-number
            (issue-created-relative-date issue)
            (issue-creator issue))
    (when (> number-of-posts 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"))
     (let ((issue-file (issue-file (list-ref (issues)
                                             (1- (string->number issue-number))))))
       ;; Files may be renamed or deleted, but not
       ;; committed. Therefore, only read the file if it exists.
       (if (file-exists? issue-file)
           (invoke (getenv "EDITOR") issue-file)
           (raise (issue-file-not-found-error issue-file)))))))

(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)
     (let ((issue-file (issue-file (list-ref (issues)
                                             (1- (string->number issue-number))))))
       ;; Files may be renamed or deleted, but not
       ;; committed. Therefore, only read the file if it exists.
       (if (file-exists? issue-file)
           (call-with-input-file (issue-file issue)
             (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)))
           (raise (issue-file-not-found-error issue-file)))))))

(define load-config
  (memoize-thunk
   (lambda ()
     "Load configuration and return <tissue-configuration> object."
     (load (canonicalize-path "tissue.scm")))))

(define tissue-repl
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a repl [-- FILE ARGS...]
In a tissue execution environment, run FILE as a Guile script with
command-line arguments ARGS.

"
             (command-line-program)))
    (args
     (let ((args (args-fold args
                            '()
                            invalid-option
                            (lambda (arg result)
                              (acons 'script arg result))
                            '())))
       (match (reverse (filter-map (match-lambda
                                     (('script . arg) arg)
                                     (_ #f))
                                   args))
         ((script args ...)
          (set-program-arguments (cons script args))
          (load (canonicalize-path script))))))))

(define tissue-web
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a web OUTPUT-DIRECTORY
Export the repository as a website to OUTPUT-DIRECTORY.

"
             (command-line-program)))
    ((output-directory)
     (parameterize ((%project-name (tissue-configuration-project (load-config)))
                    (%tags-path (tissue-configuration-web-tags-path
                                 (load-config))))
       (build-website (getcwd)
                      output-directory
                      (tissue-configuration-web-css (load-config))
                      (tissue-configuration-web-files (load-config)))))))

(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
  repl      run a Guile script in a tissue environment
  web       export repository as website

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 ...)
     (guard (c ((issue-file-not-found-error? c)
                (display (string-append "No such file or directory: "
                                        (issue-file-not-found-error-issue-file c))
                         (current-error-port))
                (newline (current-error-port))
                (exit #f)))
       (call-with-current-directory (git-top-level)
         (lambda ()
           (parameterize ((%issue-files (tissue-configuration-issue-files (load-config)))
                          (%aliases (tissue-configuration-aliases (load-config))))
             (apply (match command
                      ("list" tissue-list)
                      ("edit" tissue-edit)
                      ("show" tissue-show)
                      ("repl" tissue-repl)
                      ("web" tissue-web)
                      (invalid-command
                       (format (current-error-port) "Invalid command `~a'~%~%"
                               invalid-command)
                       (print-usage)
                       (exit #f)))
                    args))))))
    ;; tissue is an alias for `tissue list'
    ((_)
     (main "tissue" "list"))))

(apply main (command-line))