#!/usr/bin/guile \
-e "(scripts summarize-guile-TODO)" -s
!#
;;; summarize-guile-TODO --- Display Guile TODO list in various ways

;;	Copyright (C) 2002,2003,2004 Free Software Foundation, Inc.
;;
;; This program 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 2, or
;; (at your option) any later version.
;;
;; This program 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 this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: summarize-guile-TODO TODOFILE
;;
;; The TODOFILE is typically Guile's (see workbook/tasks/README)
;; presumed to serve as our signal to ourselves (lest we want real
;; bosses hassling us) wrt to the overt message "items to do" as well as
;; the messages that can be inferred from its structure.
;;
;; This program reads TODOFILE and displays interpretations on its
;; structure, including registered markers and ownership, in various
;; ways.
;;
;; A primary interest in any task is its parent task.  The output
;; summarization by default lists every item and its parent chain.
;; Top-level parents are not items.  You can use these command-line
;; options to modify the selection and display (selection criteria
;; are ANDed together):
;;
;; -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
;;
;; If USER is not specified, it defaults to you (your login name).
;;
;;
;; Usage from a Scheme program:
;;   (summarize-guile-TODO options todo-file)
;;
;; Send output to the current output port.  Return value is unspecified.
;; TODO-FILE is a filename.  OPTIONS is either #f or an alist the keys of
;; which correspond to the shell command options.
;;
;;
;; Bugs: (1) Markers are scanned in sequence: D R X N%.  This means "XD"
;;           and the like are completely dropped.  However, such strings
;;           are unlikely to be used if the markers are chosen to be
;;           somewhat exclusive, which is currently the case for D R X.
;;           N% used w/ these needs to be something like: "D25%" (this
;;           means discussion accounts for 1/4 of the task).

;;; Code:

(define-module (scripts summarize-guile-TODO)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:autoload (scripts read-text-outline) (make-text-outline-reader)
  #:autoload (scripts split-string-no-nulls) (split-string-no-nulls)
  #:autoload (ice-9 common-list) (remove-if-not)
  #:export (summarize-guile-TODO
            *summarize-guile-TODO-option-spec*))

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

(define (as-leaf x)
  (cond ((get x 'who)
         => (lambda (who)
              (put x 'who
                   (map string->symbol
                        (split-string-no-nulls who ":"))))))
  (cond ((get x 'pct-done)
         => (lambda (pct-done)
              (put x 'pct-done (string->number pct-done)))))
  x)

(define (hang-by-the-leaves trees)
  (let ((leaves '()))
    (letrec ((hang (lambda (tree parent)
                     (if (list? tree)
                         (begin
                           (put (car tree) 'parent parent)
                           (for-each (lambda (child)
                                       (hang child (car tree)))
                                     (cdr tree)))
                         (begin
                           (put tree 'parent parent)
                           (set! leaves (cons (as-leaf tree) leaves)))))))
      (for-each (lambda (tree)
                  (hang tree #f))
                trees))
    leaves))

(define (read-TODO file)
  (hang-by-the-leaves
   ((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)))))
    (open-file file "r"))))

(define (select-items qop items)
  (define (u<-u u)
    (string->symbol (if (eq? #t u)
                        (passwd:name (getpwuid (getuid)))
                        u)))
  (let ((sub '()))
    (qop 'involved (lambda (u)
                     (set! u (u<-u u))
                     (set! sub (cons
                                (lambda (x)
                                  (and (get x 'who)
                                       (memq u (get x 'who))))
                                sub))))
    (qop 'personal (lambda (u)
                     (set! u (u<-u u))
                     (set! sub (cons
                                (lambda (x)
                                  (cond ((get x 'who)
                                         => (lambda (ls)
                                              (eq? (car (reverse ls))
                                                   u)))
                                        (else #f)))
                                sub))))
    (for-each (lambda (pair)
                (cond ((qop (car pair))
                       (set! sub (cons (cdr pair) sub)))))
              `((todo . ,(lambda (x) (string=? (get x 'status) "-")))
                (done . ,(lambda (x) (string=? (get x 'status) "+")))
                (review . ,(lambda (x) (get x 'review?)))))
    (let loop ((sub (reverse sub)) (items items))
      (if (null? sub)
          (reverse items)
          (loop (cdr sub) (remove-if-not (car sub) items))))))

(define (make-display-item show-who? show-parent?)
  (let ((show-who
         (if show-who?
             (lambda (item)
               (cond ((get item 'who)
                      => (lambda (who) (simple-format #f " ~A" who)))
                     (else "")))
             (lambda (item) "")))
        (show-parents
         (if show-parent?
             (lambda (item)
               (let loop ((parent (get item 'parent)) (indent 2))
                 (and parent
                      (begin
                        (simple-format #t "under : ~A~A\n"
                                       (make-string indent #\space)
                                       parent)
                        (loop (get parent 'parent) (+ 2 indent))))))
             (lambda (item) #t))))
    (lambda (item)
      (simple-format #t "status: ~A~A~A~A~A~A\nitem  : ~A\n"
                     (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)
                                 (simple-format #f " ~A%" pct-done)))
                           (else ""))
                     (show-who item)
                     item)
      (show-parents item))))

(define (display-items qop items)
  (let ((display-item (make-display-item (qop 'who)
                                         (not (qop 'no-parent)))))
    (for-each display-item items)))

(define (summarize-guile-TODO/qop qop)
  (and (null? (qop '()))
       (error "missing TODOFILE, try --help"))
  (display-items qop (select-items qop (read-TODO (car (qop '())))))
  #t)

(define (summarize-guile-TODO options todo-file)
  (summarize-guile-TODO/qop
   ;; "manual" qop -- fixme: restructure so /qop calls this proc
   (let ((options (or options '())))
     (lambda (key . handler)
       (if (equal? '() key)
           (list todo-file)
           (cond ((assq-ref options key)
                  => (lambda (answer)
                       (if (null? handler)
                           answer
                           ((car handler) answer))))
                 (else #f)))))))

(define *summarize-guile-TODO-option-spec*
  '((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))))

(define (main args)
  (HVQC-MAIN args summarize-guile-TODO/qop
             '(usage . commentary)
             '(package . "Guile")
             `(option-spec ,@*summarize-guile-TODO-option-spec*)))

;;; summarize-guile-TODO ends here
