scripts/summarize-guile-TODO

   1 #!/bin/sh
   2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
   3 main='(module-ref (resolve-module '\''(scripts summarize-guile-TODO)) '\'main')'
   4 exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
   5 !#
   6 ;;; summarize-guile-TODO --- Display Guile TODO list in various ways
   7
   8 ;;      Copyright (C) 2002 Free Software Foundation, Inc.
   9 ;;
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or
  13 ;; (at your option) any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this software; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  23 ;; Boston, MA 02111-1307 USA
  24
  25 ;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
  26
  27 ;;; Commentary:
  28
  29 ;; Usage: summarize-guile-TODO TODOFILE
  30 ;;
  31 ;; The TODOFILE is typically Guile's (see workbook/tasks/README)
  32 ;; presumed to serve as our signal to ourselves (lest we want real
  33 ;; bosses hassling us) wrt to the overt message "items to do" as well as
  34 ;; the messages that can be inferred from its structure.
  35 ;;
  36 ;; This program reads TODOFILE and displays interpretations on its
  37 ;; structure, including registered markers and ownership, in various
  38 ;; ways.
  39 ;;
  40 ;; A primary interest in any task is its parent task.  The output
  41 ;; summarization by default lists every item and its parent chain.
  42 ;; Top-level parents are not items.  You can use these command-line
  43 ;; options to modify the selection and display (selection criteria
  44 ;; are ANDed together):
  45 ;;
  46 ;; -i, --involved USER  -- select USER-involved items
  47 ;; -p, --personal USER  -- select USER-responsible items
  48 ;; -t, --todo           -- select unfinished items (status "-")
  49 ;; -d, --done           -- select finished items (status "+")
  50 ;; -r, --review         -- select review items (marker "R")
  51 ;;
  52 ;; -w, --who            -- also show who is associated w/ the item
  53 ;; -n, --no-parent      -- do not show parent chain
  54 ;;
  55 ;;
  56 ;; Usage from a Scheme program:
  57 ;;   (summrize-guile-TODO . args)       ; uses first arg only
  58 ;;
  59 ;;
  60 ;; Bugs: (1) Markers are scanned in sequence: D R X N%.  This means "XD"
  61 ;;           and the like are completely dropped.  However, such strings
  62 ;;           are unlikely to be used if the markers are chosen to be
  63 ;;           somewhat exclusive, which is currently the case for D R X.
  64 ;;           N% used w/ these needs to be something like: "D25%" (this
  65 ;;           means discussion accounts for 1/4 of the task).
  66 ;;
  67 ;; TODO: Implement more various ways. (Patches welcome.)
  68 ;;       Add support for ORing criteria.
  69
  70 ;;; Code:
  71 (debug-enable 'debug 'backtrace)
  72
  73 (define-module (scripts summarize-guile-TODO)
  74   :use-module (scripts read-text-outline)
  75   :use-module (ice-9 getopt-long)
  76   :autoload (srfi srfi-13) (string-tokenize) ; string library
  77   :autoload (ice-9 common-list) (remove-if-not)
  78   :export (summarize-guile-TODO))
  79
  80 (define put set-object-property!)
  81 (define get object-property)
  82
  83 (define (as-leaf x)
  84   (cond ((get x 'who)
  85          => (lambda (who)
  86               (put x 'who
  87                    (map string->symbol
  88                         (string-tokenize who #\:))))))
  89   (cond ((get x 'pct-done)
  90          => (lambda (pct-done)
  91               (put x 'pct-done (string->number pct-done)))))
  92   x)
  93
  94 (define (hang-by-the-leaves trees)
  95   (let ((leaves '()))
  96     (letrec ((hang (lambda (tree parent)
  97                      (if (list? tree)
  98                          (begin
  99                            (put (car tree) 'parent parent)
 100                            (for-each (lambda (child)
 101                                        (hang child (car tree)))
 102                                      (cdr tree)))
 103                          (begin
 104                            (put tree 'parent parent)
 105                            (set! leaves (cons (as-leaf tree) leaves)))))))
 106       (for-each (lambda (tree)
 107                   (hang tree #f))
 108                 trees))
 109     leaves))
 110
 111 (define (read-TODO file)
 112   (hang-by-the-leaves
 113    ((make-text-outline-reader
 114      "(([ ][ ])*)([-+])(D*)(R*)(X*)(([0-9]+)%)* *([^[]*)(\\[(.*)\\])*"
 115      '((level-substring-divisor . 2)
 116        (body-submatch-number . 9)
 117        (extra-fields . ((status . 3)
 118                         (design? . 4)
 119                         (review? . 5)
 120                         (extblock? . 6)
 121                         (pct-done . 8)
 122                         (who . 11)))))
 123     (open-file file "r"))))
 124
 125 (define (select-items p items)
 126   (let ((sub '()))
 127     (cond ((option-ref p 'involved #f)
 128            => (lambda (u)
 129                 (let ((u (string->symbol u)))
 130                   (set! sub (cons
 131                              (lambda (x)
 132                                (and (get x 'who)
 133                                     (memq u (get x 'who))))
 134                              sub))))))
 135     (cond ((option-ref p 'personal #f)
 136            => (lambda (u)
 137                 (let ((u (string->symbol u)))
 138                   (set! sub (cons
 139                              (lambda (x)
 140                                (cond ((get x 'who)
 141                                       => (lambda (ls)
 142                                            (eq? (car (reverse ls))
 143                                                 u)))
 144                                      (else #f)))
 145                              sub))))))
 146     (for-each (lambda (pair)
 147                 (cond ((option-ref p (car pair) #f)
 148                        (set! sub (cons (cdr pair) sub)))))
 149               `((todo . ,(lambda (x) (string=? (get x 'status) "-")))
 150                 (done . ,(lambda (x) (string=? (get x 'status) "+")))
 151                 (review . ,(lambda (x) (get x 'review?)))))
 152     (let loop ((sub (reverse sub)) (items items))
 153       (if (null? sub)
 154           (reverse items)
 155           (loop (cdr sub) (remove-if-not (car sub) items))))))
 156
 157 (define (make-display-item show-who? show-parent?)
 158   (lambda (item)
 159     (format #t "status: ~A~A~A~A~A~A\nitem  : ~A\n"
 160             (get item 'status)
 161             (if (get item 'design?) "D" "")
 162             (if (get item 'review?) "R" "")
 163             (if (get item 'extblock?) "X" "")
 164             (cond ((get item 'pct-done)
 165                    => (lambda (pct-done)
 166                         (format #f " ~A%" pct-done)))
 167                   (else ""))
 168             (cond ((get item 'who)
 169                    => (lambda (who)
 170                         (if show-who?
 171                             (format #f " ~A" who)
 172                             "")))
 173                   (else ""))
 174             item)
 175     (and show-parent?
 176          (let loop ((parent (get item 'parent)) (indent 2))
 177            (and parent
 178                 (begin
 179                   (format #t "under : ~A~A\n"
 180                           (make-string indent #\space)
 181                           parent)
 182                   (loop (get parent 'parent) (+ 2 indent))))))))
 183
 184 (define (display-items p items)
 185   (let ((display-item (make-display-item (option-ref p 'who #f)
 186                                          (not (option-ref p 'no-parent #f))
 187                                          )))
 188     (for-each display-item items)))
 189
 190 (define (summarize-guile-TODO . args)
 191   (let ((p (getopt-long (cons "summarize-guile-TODO" args)
 192                         '((who (single-char #\w))
 193                           (no-parent (single-char #\n))
 194                           (involved (single-char #\i)
 195                                     (value #t))
 196                           (personal (single-char #\p)
 197                                     (value #t))
 198                           (todo (single-char #\t))
 199                           (done (single-char #\d))
 200                           (review (single-char #\r))
 201                           ;; Add options here.
 202                           ))))
 203     (display-items p (select-items p (read-TODO (car (option-ref p '() #f))))))
 204   #t)                                   ; exit val
 205
 206 (define main summarize-guile-TODO)
 207
 208 ;;; summarize-guile-TODO ends here