guile18/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, 2006 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., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301 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 ;;   (summarize-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 (srfi srfi-14) (char-set) ; string library
  78   :autoload (ice-9 common-list) (remove-if-not)
  79   :export (summarize-guile-TODO))
  80
  81 (define put set-object-property!)
  82 (define get object-property)
  83
  84 (define (as-leaf x)
  85   (cond ((get x 'who)
  86          => (lambda (who)
  87               (put x 'who
  88                    (map string->symbol
  89                         (string-tokenize who (char-set #\:)))))))
  90   (cond ((get x 'pct-done)
  91          => (lambda (pct-done)
  92               (put x 'pct-done (string->number pct-done)))))
  93   x)
  94
  95 (define (hang-by-the-leaves trees)
  96   (let ((leaves '()))
  97     (letrec ((hang (lambda (tree parent)
  98                      (if (list? tree)
  99                          (begin
 100                            (put (car tree) 'parent parent)
 101                            (for-each (lambda (child)
 102                                        (hang child (car tree)))
 103                                      (cdr tree)))
 104                          (begin
 105                            (put tree 'parent parent)
 106                            (set! leaves (cons (as-leaf tree) leaves)))))))
 107       (for-each (lambda (tree)
 108                   (hang tree #f))
 109                 trees))
 110     leaves))
 111
 112 (define (read-TODO file)
 113   (hang-by-the-leaves
 114    ((make-text-outline-reader
 115      "(([ ][ ])*)([-+])(D*)(R*)(X*)(([0-9]+)%)* *([^[]*)(\\[(.*)\\])*"
 116      '((level-substring-divisor . 2)
 117        (body-submatch-number . 9)
 118        (extra-fields . ((status . 3)
 119                         (design? . 4)
 120                         (review? . 5)
 121                         (extblock? . 6)
 122                         (pct-done . 8)
 123                         (who . 11)))))
 124     (open-file file "r"))))
 125
 126 (define (select-items p items)
 127   (let ((sub '()))
 128     (cond ((option-ref p 'involved #f)
 129            => (lambda (u)
 130                 (let ((u (string->symbol u)))
 131                   (set! sub (cons
 132                              (lambda (x)
 133                                (and (get x 'who)
 134                                     (memq u (get x 'who))))
 135                              sub))))))
 136     (cond ((option-ref p 'personal #f)
 137            => (lambda (u)
 138                 (let ((u (string->symbol u)))
 139                   (set! sub (cons
 140                              (lambda (x)
 141                                (cond ((get x 'who)
 142                                       => (lambda (ls)
 143                                            (eq? (car (reverse ls))
 144                                                 u)))
 145                                      (else #f)))
 146                              sub))))))
 147     (for-each (lambda (pair)
 148                 (cond ((option-ref p (car pair) #f)
 149                        (set! sub (cons (cdr pair) sub)))))
 150               `((todo . ,(lambda (x) (string=? (get x 'status) "-")))
 151                 (done . ,(lambda (x) (string=? (get x 'status) "+")))
 152                 (review . ,(lambda (x) (get x 'review?)))))
 153     (let loop ((sub (reverse sub)) (items items))
 154       (if (null? sub)
 155           (reverse items)
 156           (loop (cdr sub) (remove-if-not (car sub) items))))))
 157
 158 (define (make-display-item show-who? show-parent?)
 159   (let ((show-who
 160          (if show-who?
 161              (lambda (item)
 162                (cond ((get item 'who)
 163                       => (lambda (who) (format #f " ~A" who)))
 164                      (else "")))
 165              (lambda (item) "")))
 166         (show-parents
 167          (if show-parent?
 168              (lambda (item)
 169                (let loop ((parent (get item 'parent)) (indent 2))
 170                  (and parent
 171                       (begin
 172                         (format #t "under : ~A~A\n"
 173                                 (make-string indent #\space)
 174                                 parent)
 175                         (loop (get parent 'parent) (+ 2 indent))))))
 176              (lambda (item) #t))))
 177     (lambda (item)
 178       (format #t "status: ~A~A~A~A~A~A\nitem  : ~A\n"
 179               (get item 'status)
 180               (if (get item 'design?) "D" "")
 181               (if (get item 'review?) "R" "")
 182               (if (get item 'extblock?) "X" "")
 183               (cond ((get item 'pct-done)
 184                      => (lambda (pct-done)
 185                           (format #f " ~A%" pct-done)))
 186                     (else ""))
 187               (show-who item)
 188               item)
 189       (show-parents item))))
 190
 191 (define (display-items p items)
 192   (let ((display-item (make-display-item (option-ref p 'who #f)
 193                                          (not (option-ref p 'no-parent #f))
 194                                          )))
 195     (for-each display-item items)))
 196
 197 (define (summarize-guile-TODO . args)
 198   (let ((p (getopt-long (cons "summarize-guile-TODO" args)
 199                         '((who (single-char #\w))
 200                           (no-parent (single-char #\n))
 201                           (involved (single-char #\i)
 202                                     (value #t))
 203                           (personal (single-char #\p)
 204                                     (value #t))
 205                           (todo (single-char #\t))
 206                           (done (single-char #\d))
 207                           (review (single-char #\r))
 208                           ;; Add options here.
 209                           ))))
 210     (display-items p (select-items p (read-TODO (car (option-ref p '() #f))))))
 211   #t)                                   ; exit val
 212
 213 (define main summarize-guile-TODO)
 214
 215 ;;; summarize-guile-TODO ends here