#!/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-19)
        (srfi srfi-26)
        (srfi srfi-37)
        (srfi srfi-171)
        (srfi srfi-171 gnu)
        (ice-9 match)
        (ice-9 popen)
        (ice-9 regex)
        (term ansi-color)
        (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)))

(define (human-date-string date)
  "Return a human readable rendering of DATE."
  (let ((elapsed-time
         (time-second
          (time-difference (date->time-monotonic (current-date))
                           (date->time-monotonic date)))))
    (cond
     ((< elapsed-time (* 2 60))
      (format #f "~a seconds ago" elapsed-time))
     ((< elapsed-time (* 2 60 60))
      (format #f "~a minutes ago" (round (/ elapsed-time 60))))
     ((< elapsed-time (* 2 24 60 60))
      (format #f "~a hours ago" (round (/ elapsed-time 60 60))))
     ((< elapsed-time (* 2 7 24 60 60))
      (format #f "~a days ago" (round (/ elapsed-time 60 60 24))))
     ((< elapsed-time (* 2 30 24 60 60))
      (format #f "~a weeks ago" (round (/ elapsed-time 60 60 24 7))))
     (else
      (format #f "on ~a" (date->string date "~b ~d ~Y"))))))

(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 (colorize-string (issue-title issue) 'MAGENTA))
    ;; 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)
                       ((cut colorize-string
                             <>
                             (cond
                              ((not (null? (lset-intersection
                                            string=?
                                            (string-split keyword #\space)
                                            (list "bug" "critical"))))
                               'ON-RED)
                              (else 'ON-BLUE)))
                        (string-append " " keyword " ")))
                     (issue-keywords issue))
                " ")))
    (unless (null? (issue-assigned issue))
      (display (colorize-string (string-append " (assigned: "
                                               (string-join (issue-assigned issue)
                                                            ", ")
                                               ")")
                                'GREEN)))
    (when (> number-of-posts 1)
      (display (string-append " ["
                              (number->string number-of-posts)
                              " posts]")))
    (newline)
    (display (string-append
              (colorize-string (string-append "#" (number->string issue-number)) 'CYAN)
              " opened "
              (colorize-string (human-date-string (issue-created-date issue)) 'CYAN)
              " by "
              (colorize-string (issue-creator issue) 'CYAN)))
    (when (> number-of-posts 1)
      (display (string-append (colorize-string "," 'CYAN)
                              " last updated "
                              (colorize-string (human-date-string (issue-last-updated-date issue))
                                               'CYAN)
                              " by "
                              (colorize-string (issue-last-updater issue)
                                               'CYAN))))
    (unless (zero? (issue-tasks issue))
      (display (string-append (colorize-string "; " '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
            (human-date-string (issue-created-date issue))
            (issue-creator issue))
    (when (> number-of-posts 1)
      (format #t ", last updated ~a by ~a"
              (human-date-string (issue-last-updated-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 FILE
Show the text of FILE.

"
             (command-line-program)))
    ((file)
     ;; Files may be renamed or deleted, but not committed. Therefore,
     ;; only read the file if it exists.
     (if (file-exists? file)
         (call-with-input-file file
           (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 (colorize-string line 'BOLD)))
                           ;; Print lists in cyan.
                           ((string-prefix? "*" line)
                            (display (colorize-string line 'CYAN)))
                           ;; 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 (colorize-string (match:substring m 2) 'CYAN))
                                 (display (match:substring m 3))))
                           ;; Print preformatted text backticks in
                           ;; magenta.
                           ((string-prefix? "```" line)
                            (display (colorize-string line 'MAGENTA)))
                           (else
                            ;; If part of preformatted block, print in
                            ;; magenta. Else, print in default color.
                            (display (if pre? (colorize-string line 'MAGENTA) line))))))
                       (newline))))
              (const #t)
              get-line-dos-or-unix
              port)))
         (raise (issue-file-not-found-error 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))