#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do todo)' -s $0 "$@" # -*-scheme-*-
!#
;;; todo --- display TODO files in various ways

;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2009, 2010,
;;   2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: todo [OPTIONS] [PROJECT]
;;
;; Summarize of PROJECT's todo file.  PROJECT is a regular expression
;; that may match one or more todo file names registered in the meta
;; data file (see ‘--meta’ below).  If PROJECT is omitted, all projects
;; are selected.
;;
;; Options are:
;;  -L, --list            -- display mtime and name of each todo file
;;                           regsitered and exit successfully
;;  -M, --meta FILE       -- use FILE for meta data [$HOME/.todo.list]
;;  -i, --involved [USER] -- select USER-involved items
;;  -p, --personal [USER] -- select USER-responsible items
;;  -t, --todo            -- select unfinished items (status "-")
;;  -d, --done            -- select finished items (status "+")
;;  -r, --review          -- select review items (marker "R")
;;  -w, --who             -- also show who is associated w/ the item
;;  -n, --no-parent       -- do not show parent chain
;;
;; The todo file format is a line-based outline where each heading
;; is zero or more pairs of leading spaces followed by ‘-’ (hyphen).
;; Something like:
;;
;; - a                  0
;;   - b                1
;;     - c              2
;;   - d                1
;; - e                  0
;;   - f                1
;;     - g              2
;;   - h                1
;;
;; NOTE: Outlines that "skip" levels signal an error.
;; In other words, this will fail:
;;
;; - a               0
;;   - b             1
;;       - c         3       <-- skipped 2 -- error!
;;   - d             1

;;; Code:

(define-module (ttn-do todo)
  #:export (main make-text-outline-reader)
  #:use-module ((srfi srfi-1) #:select (filter))
  #:use-module ((srfi srfi-13) #:select (string-tokenize))
  #:use-module ((srfi srfi-14) #:select (char-set-complement
                                         char-set))
  #:use-module ((ttn-do zzz 0gx forms-from) #:select (forms<-file))
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz personally) #:select (FE
                                                  fs fso
                                                  accumulator))
  #:use-module ((ttn-do zzz txtoutline) #:select (txtoutline-reader))
  #:use-module ((ttn-do zzz filesystem) #:select (expand-file-name)))

(define put set-object-property!)
(define get object-property)

;; Use @code{txtoutline-reader} (@pxref{zzz txtoutline}) on
;; @var{re} and @var{specs} and return a procedure that scans
;; a file given its @var{filename}.
;;
(define (make-text-outline-reader re . specs)
  (let ((r (apply txtoutline-reader re specs)))
    (lambda (filename)
      (call-with-input-file filename r))))

(define read-TODO
  (let ((not-colon (char-set-complement (char-set #\:)))
        (eke (make-text-outline-reader
              "(([ ][ ])*)([-+])(D*)(R*)(X*)(([0-9]+)%)* *([^[]*)(\\[(.*)\\])*"
              '((level-substring-divisor . 2)
                (body-submatch-number . 9)
                (extra-fields (status . 3)
                              (design? . 4)
                              (review? . 5)
                              (extblock? . 6)
                              (pct-done . 8)
                              (who . 11))))))

    (define (hang-by-the-leaves trees)
      (let ((leaves (accumulator)))
        (define (hang tree parent)
          (define (tweak key compute-new-value)
            (and=> (get tree key)
                   (lambda (old)
                     (put tree key (compute-new-value old)))))
          (cond ((list? tree)
                 (put (car tree) 'parent parent)
                 (FE (cdr tree)
                     (lambda (child)
                       (hang child (car tree)))))
                (else
                 (put tree 'parent parent)
                 (tweak 'who (lambda (who)
                               (map string->symbol
                                    (string-tokenize
                                     who not-colon))))
                 (tweak 'pct-done string->number)
                 (leaves tree))))
        (FE trees
            (lambda (tree)
              (hang tree #f)))
        (leaves)))

    (lambda (filename)
      (hang-by-the-leaves (eke filename)))))

(define ME (passwd:name (getpwuid (getuid))))

(define (summarize-TODO qop todo-file)

  (define (select-items items)
    (let ((sub (accumulator)))
      (define (check tag match?)
        (qop tag (lambda (u)
                   (set! u (string->symbol (if (eq? #t u) ME u)))
                   (sub (lambda (x)
                          (and=> (get x 'who)
                                 (lambda (ls)
                                   (match? u ls))))))))
      (check 'involved memq)
      (check 'personal (lambda (u ls)
                         (eq? u (car (last-pair ls)))))
      (FE '(todo done review)
          `(,(lambda (x)
               (string=? (get x 'status) "-"))
            ,(lambda (x)
               (string=? (get x 'status) "+"))
            ,(lambda (x)
               (get x 'review?)))
          (lambda (opt proc)
            (and (qop opt) (sub proc))))
      (let loop ((sub (reverse! (sub))) (items items))
        (if (null? sub)
            (reverse items)
            (loop (cdr sub) (filter (car sub) items))))))

  (FE (select-items (read-TODO todo-file))
      (let ((show-who? (qop 'who))
            (show-parents? (not (qop 'no-parent))))
        ;; rv
        (lambda (item)
          (fso "status: ~A~A~A~A~A~A~%item  : ~A~%"
               (get item 'status)
               (if (get item 'design?) "D" "")
               (if (get item 'review?) "R" "")
               (if (get item 'extblock?) "X" "")
               (cond ((get item 'pct-done)
                      => (lambda (pct-done)
                           (fs " ~A%" pct-done)))
                     (else ""))
               (cond ((and show-who? (get item 'who))
                      => (lambda (who)
                           (fs " ~A" who)))
                     (else ""))
               item)
          (and show-parents?
               (let loop ((parent (get item 'parent)) (indent 2))
                 (cond (parent
                        (fso "under : ~A~A~%"
                             (make-string indent #\space)
                             parent)
                        (loop (get parent 'parent) (+ 2 indent))))))))))

(define (main/qop qop)

  (define (display-mtime-and-name name)
    (fso "~A  ~A~%"
         (let ((full (expand-file-name name)))
           (if (file-exists? full)
               (strftime "%F  %T"
                         (localtime (stat:mtime (stat full))))
               "  (does not exist)  "))
         name))

  (define (display-todo-file name)
    (fso "todofile: ~A~%" name)
    (summarize-TODO qop (expand-file-name name))
    (newline))

  (FE (map symbol->string
           (forms<-file (or (qop 'meta)
                            (in-vicinity (getenv "HOME") ".todo.list"))))
      (cond ((qop 'list)
             display-mtime-and-name)
            ((null? (qop '()))
             display-todo-file)
            (else
             (let ((rx (make-regexp (car (qop '())))))
               (lambda (name)
                 (and (regexp-exec rx name)
                      (display-todo-file name))))))))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.1")
                   (help . commentary)))
  (main/qop
   (qop<-args
    args '((meta (single-char #\M) (value #t))
           (list (single-char #\L))
           (who       (single-char #\w))
           (no-parent (single-char #\n))
           (involved  (single-char #\i) (value optional))
           (personal  (single-char #\p) (value optional))
           (todo      (single-char #\t))
           (done      (single-char #\d))
           (review    (single-char #\r))))))

;;; todo ends here