path: root/gnbug

#! /usr/bin/env guile
!#

(import (rnrs hashtables)
        (rnrs io ports)
        (srfi srfi-9)
        (srfi srfi-26)
        (srfi srfi-37)
        (srfi srfi-171)
        (ice-9 ftw)
        (ice-9 match)
        (ice-9 popen)
        (ice-9 rdelim))

(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* (find-files directory #:optional (pred (const #t)))
  "Recursively find all files under DIRECTORY that satisfy PRED."
  (define (do-nothing name stat result)
    result)

  (file-system-fold (const #t)
                    (lambda (name stat result)
                      (if (pred name stat)
                          (cons name result)
                          result))
                    do-nothing
                    do-nothing
                    do-nothing
                    (lambda (name stat errno result)
                      (error (strerror errno) name))
                    '()
                    directory))

(define-record-type <issue>
  (issue file title creator created-date created-relative-date assigned)
  issue?
  (file issue-file)
  (title issue-title)
  (creator issue-creator)
  (created-date issue-created-date)
  (created-relative-date issue-created-relative-date)
  (assigned issue-assigned))

(define (issues)
  "Return a list of all issues, sorted newest 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 (map (lambda (file)
               (let ((file-details (file-details file))
                     (creation-details (creation-details file)))
                 (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))
                        (assq-ref creation-details 'creator)
                        (assq-ref creation-details 'created-date)
                        (assq-ref creation-details 'created-relative-date)
                        (hashtable-ref file-details 'assigned '()))))
             (find-files "."
                         (lambda (name _)
                           (and (string-suffix? ".gmi" name)
                                (not (string=? (basename name) "README.gmi"))
                                (not (string-prefix? "." (basename name)))))))
        (lambda (issue1 issue2)
          (> (issue-created-date issue1)
             (issue-created-date issue2)))))

(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-update! result 'assigned
                                                     (lambda (previous)
                                                       (append (map (cut string-trim-both <>)
                                                                    (string-split
                                                                     (substring line (string-length "* assigned:"))
                                                                     #\,))
                                                               previous))
                                                     '()))
                                 ;; The first level one heading is the
                                 ;; title.
                                 ((string-prefix? "# " line)
                                  (unless (hashtable-contains? result 'title)
                                    (hashtable-set! result 'title
                                                    (substring line (string-length "# "))))))))
                        (const #t)
                        read-line
                        port)))
    result))

(define (creation-details file)
  "Return an association list of creation details about FILE extracted
from the git repository."
  (call-with-input-pipe
   read
   "git" "log" "--diff-filter=A"
   (string-append "--format=format:("
                  "(creator . \"%an\")"
                  "(created-date . %at)"
                  "(created-relative-date . \"%ar\")"
                  ")")
   "--" file))

(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) read-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
                     read-line
                     port))
   "git" "log" "--format=format:%H" "--since" since))

(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 red (cut color 31 <>))
(define green (cut color 32 <>))
(define magenta (cut color 35 <>))
(define blue (cut color 34 <>))
(define cyan (cut color 36 <>))

(define (invalid-option name arg loads)
  (error "Invalid option" name))

(define (invalid-operand arg loads)
  (error "Invalid argument" arg))

(define (gnbug-news . 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 (gnbug-list . args)
  (let ((args (args-fold args
                         (list (option (list "assigned") #t #f
                                       (lambda (opt name arg loads)
                                         (acons 'assigned arg loads))))
                         invalid-option
                         invalid-operand
                         '())))
    (format #t "~%total ~a~%"
            (list-transduce (compose (tenumerate 1)
                                     (tfilter (match-lambda
                                                ((_ . issue)
                                                 (or (not (assq 'assigned args))
                                                     (member (assq-ref args 'assigned)
                                                             (issue-assigned issue))))))
                                     (tlog (match-lambda*
                                             ((_ (index . issue))
                                              (format #t "~a ~a ~a ~a~a~%"
                                                      (magenta (string-append "#" (number->string index)))
                                                      (issue-created-relative-date issue)
                                                      (cyan (issue-creator issue))
                                                      (issue-title issue)
                                                      (match (issue-assigned issue)
                                                        (() "")
                                                        (assignees
                                                         (magenta (string-append " (assigned: "
                                                                                 (string-join assignees ", ")
                                                                                 ")")))))))))
                            rcount
                            (issues)))))

(define (gnbug-edit 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 issue-number)
  (put-string (current-output-port)
              (call-with-input-file (issue-file (list-ref (issues)
                                                          (1- (string->number issue-number))))
                get-string-all)))

(define main
  (match-lambda*
    ((_ command args ...)
     (apply (match command
              ("news" gnbug-news)
              ("list" gnbug-list)
              ("edit" gnbug-edit)
              ("show" gnbug-show))
            args))
    ;; gnbug is an alias for `gnbug list'
    ((_)
     (gnbug-list))))

(apply main (command-line))