#! /usr/bin/env guile !# (import (rnrs hashtables) (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 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 ((string-prefix? "* assigned:" line) (hashtable-update! result 'assigned (lambda (previous) (append (map (cut string-trim-both <>) (string-split (substring line (string-length "* assigned:")) #\,)) previous)) '())) ((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 main (match-lambda* ((_ "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"))) ((_ "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 (tfilter (lambda (issue) (or (not (assq 'assigned args)) (member (assq-ref args 'assigned) (issue-assigned issue))))) (tlog (lambda (_ issue) (format #t "~a ~a ~a~a~%" (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))))))) (apply main (command-line))