[PATCH] Simplifying guile-tools

[PATCH] Simplifying guile-tools

[Neil Jerram]

Hi there!  While we were discussing the name of guile-tools, back in
March, I wrote:

> I think I might find guile-tools (as is) less bothering if its
> built-in commands (help, version and list) were rewritten as scripts
> themselves.  Then it would be clearer that the remaining code in
> guile-tools was just implementing the main-invocation convention for
> scripts/*.

Following this email is a series of patches in this direction.  It
didn't work to try to move `help' and `version' into separate scripts
because those are given as options and not script names.  But it did
work out nicely for `list', and also I managed to simplify and enhance
(ice-9 getopt-long) such that guile-tools doesn't need to have its own
getopt variant.

The end result is that guile-tools is a lot shorter and (IMO) sweeter.

Here are the titles of the following patches.

 [PATCH 1/5] Fix "occurrances" typos in getopt-long code and test
 [PATCH 2/5] Simplify getopt-long handling of option values, esp with multiple occurrences
 [PATCH 3/5] Handle short option unclumping progressively, instead of all upfront
 [PATCH 4/5] Implement #:stop-at-first-non-option option for getopt-long
 [PATCH 5/5] Reveal guile-tools's inner simplicity...

What do you think?

Thanks,
      Neil

[PATCH 1/5] Fix "occurrances" typos in getopt-long code and test

[Neil Jerram]

* module/ice-9/getopt-long.scm (process-options, getopt-long): Change
  to "occurrences".

* test-suite/tests/getopt-long.test ("multiple occurrences"): Same
  again.
---
 module/ice-9/getopt-long.scm      |    4 ++--
 test-suite/tests/getopt-long.test |    2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm
index 1b170b4..c3939dc 100644
--- a/module/ice-9/getopt-long.scm
+++ b/module/ice-9/getopt-long.scm
@@ -271,7 +271,7 @@
         (define (val!loop val n-ls n-found n-etc)
           (set-option-spec-value!
            spec
-           ;; handle multiple occurrances
+           ;; handle multiple occurrences
            (cond ((option-spec->value spec)
                   => (lambda (cur)
                        ((if (list? cur) cons list)
@@ -384,7 +384,7 @@ to add a `single-char' clause to the option description."
               (map (lambda (spec)
                      (let ((name (string->symbol (option-spec->name spec))))
                        (cons name
-                             ;; handle multiple occurrances
+                             ;; handle multiple occurrences
                              (let ((maybe-ls (option-spec->value spec)))
                                (if (list? maybe-ls)
                                    (let* ((look (assq name multi-count))
diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test
index d7f5184..682763c 100644
--- a/test-suite/tests/getopt-long.test
+++ b/test-suite/tests/getopt-long.test
@@ -252,7 +252,7 @@
 
   )
 
-(with-test-prefix "multiple occurrances"
+(with-test-prefix "multiple occurrences"
 
   (define (test9 . args)
     (equal? (getopt-long (cons "foo" args)
-- 
1.7.4.1

[PATCH 2/5] Simplify getopt-long handling of option values, esp with multiple occurrences

[Neil Jerram]

Basically, accumulate values in the `process-options' loop variables,
instead of using set-option-spec-value!

* module/ice-9/getopt-long.scm (option-spec): Delete the `value' slot.

  (process-options): Delete `val!loop' and just use `loop' everywhere
  instead.  When adding an option spec to `found', add the
  corresponding value too; hence `found' becomes an alist, where it
  was previously a list of specs.

  (getopt-long): Use assq-ref to get values out of `found'.  Remove
  unhittable error condition for detecting an option that requires an
  explicit value, where a value wasn't supplied.  This condition is
  actually caught and handled in `process-options'.  Rewrite the end
  of the procedure much more simply.
---
 module/ice-9/getopt-long.scm |   52 +++++++++---------------------------------
 1 files changed, 11 insertions(+), 41 deletions(-)

diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm
index c3939dc..5c73f9a 100644
--- a/module/ice-9/getopt-long.scm
+++ b/module/ice-9/getopt-long.scm
@@ -179,8 +179,6 @@
   option-spec?
   (name
    option-spec->name set-option-spec-name!)
-  (value 
-   option-spec->value set-option-spec-value!)
   (required?
    option-spec->required? set-option-spec-required?!)
   (option-spec->single-char
@@ -268,30 +266,20 @@
                      (remove-if-not option-spec->single-char specs))))
     (let loop ((argument-ls argument-ls) (found '()) (etc '()))
       (define (eat! spec ls)
-        (define (val!loop val n-ls n-found n-etc)
-          (set-option-spec-value!
-           spec
-           ;; handle multiple occurrences
-           (cond ((option-spec->value spec)
-                  => (lambda (cur)
-                       ((if (list? cur) cons list)
-                        val cur)))
-                 (else val)))
-          (loop n-ls n-found n-etc))
         (cond
          ((eq? 'optional (option-spec->value-policy spec))
           (if (or (null? ls)
                   (looks-like-an-option (car ls)))
-              (val!loop #t ls (cons spec found) etc)
-              (val!loop (car ls) (cdr ls) (cons spec found) etc)))
+              (loop ls (acons spec #t found) etc)
+              (loop (cdr ls) (acons spec (car ls) found) etc)))
          ((eq? #t (option-spec->value-policy spec))
           (if (or (null? ls)
                   (looks-like-an-option (car ls)))
               (fatal-error "option must be specified with argument: --~a"
                            (option-spec->name spec))
-              (val!loop (car ls) (cdr ls) (cons spec found) etc)))
+              (loop (cdr ls) (acons spec (car ls) found) etc)))
          (else
-          (val!loop #t ls (cons spec found) etc))))
+          (loop ls (acons spec #t found) etc))))
       
       (match argument-ls
         (()
@@ -363,37 +351,19 @@ to add a `single-char' clause to the option description."
            (rest-ls (append (cdr found/etc) non-split-ls)))
       (for-each (lambda (spec)
                   (let ((name (option-spec->name spec))
-                        (val (option-spec->value spec)))
+                        (val (assq-ref found spec)))
                     (and (option-spec->required? spec)
-                         (or (memq spec found)
+                         (or val
                              (fatal-error "option must be specified: --~a"
                                           name)))
-                    (and (memq spec found)
-                         (eq? #t (option-spec->value-policy spec))
-                         (or val
-                             (fatal-error
-                              "option must be specified with argument: --~a"
-                              name)))
                     (let ((pred (option-spec->predicate spec)))
                       (and pred (pred name val)))))
                 specifications)
-      (cons (cons '() rest-ls)
-            (let ((multi-count (map (lambda (desc)
-                                      (cons (car desc) 0))
-                                    option-desc-list)))
-              (map (lambda (spec)
-                     (let ((name (string->symbol (option-spec->name spec))))
-                       (cons name
-                             ;; handle multiple occurrences
-                             (let ((maybe-ls (option-spec->value spec)))
-                               (if (list? maybe-ls)
-                                   (let* ((look (assq name multi-count))
-                                          (idx (cdr look))
-                                          (val (list-ref maybe-ls idx)))
-                                     (set-cdr! look (1+ idx)) ; ugh!
-                                     val)
-                                   maybe-ls)))))
-                   found))))))
+      (for-each (lambda (spec+val)
+                  (set-car! spec+val
+                            (string->symbol (option-spec->name (car spec+val)))))
+                found)
+      (cons (cons '() rest-ls) found))))
 
 (define (option-ref options key default)
   "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
-- 
1.7.4.1

[PATCH 3/5] Handle short option unclumping progressively, instead of all upfront

[Neil Jerram]

This is needed as a prerequisite for the following
don't know how far through the command line we should go with unclumping.

* module/ice-9/getopt-long.scm (expand-clumped-singles): Delete.

  (process-options): Add a loop variable to indicate how many elements
  at the start of `argument-ls' are known not to be clumped.  When we
  see a short option and this variable is <= 0, perform unclumping
  (using code that used to be in expand-clumped-singles) and loop with
  the variable > 0.

  (getopt-long): Don't call expand-clumped-singles upfront here.
---
 module/ice-9/getopt-long.scm |   57 ++++++++++++++++++-----------------------
 1 files changed, 25 insertions(+), 32 deletions(-)

diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm
index 5c73f9a..0c2d835 100644
--- a/module/ice-9/getopt-long.scm
+++ b/module/ice-9/getopt-long.scm
@@ -226,27 +226,6 @@
 (define long-opt-no-value-rx   (make-regexp "^--([^=]+)$"))
 (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
 
-(define (expand-clumped-singles opt-ls)
-  ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
-  (let loop ((opt-ls opt-ls) (ret-ls '()))
-    (cond ((null? opt-ls)
-           (reverse ret-ls))                                    ;;; retval
-          ((regexp-exec short-opt-rx (car opt-ls))
-           => (lambda (match)
-                (let ((singles (reverse
-                                (map (lambda (c)
-                                       (string-append "-" (make-string 1 c)))
-                                     (string->list
-                                      (match:substring match 1)))))
-                      (extra (match:substring match 2)))
-                  (loop (cdr opt-ls)
-                        (append (if (string=? "" extra)
-                                    singles
-                                    (cons extra singles))
-                                ret-ls)))))
-          (else (loop (cdr opt-ls)
-                      (cons (car opt-ls) ret-ls))))))
-
 (define (looks-like-an-option string)
   (or (regexp-exec short-opt-rx string)
       (regexp-exec long-opt-with-value-rx string)
@@ -264,22 +243,22 @@
                        (cons (make-string 1 (option-spec->single-char spec))
                              spec))
                      (remove-if-not option-spec->single-char specs))))
-    (let loop ((argument-ls argument-ls) (found '()) (etc '()))
+    (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '()))
       (define (eat! spec ls)
         (cond
          ((eq? 'optional (option-spec->value-policy spec))
           (if (or (null? ls)
                   (looks-like-an-option (car ls)))
-              (loop ls (acons spec #t found) etc)
-              (loop (cdr ls) (acons spec (car ls) found) etc)))
+              (loop (- unclumped 1) ls (acons spec #t found) etc)
+              (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
          ((eq? #t (option-spec->value-policy spec))
           (if (or (null? ls)
                   (looks-like-an-option (car ls)))
               (fatal-error "option must be specified with argument: --~a"
                            (option-spec->name spec))
-              (loop (cdr ls) (acons spec (car ls) found) etc)))
+              (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
          (else
-          (loop ls (acons spec #t found) etc))))
+          (loop (- unclumped 1) ls (acons spec #t found) etc))))
       
       (match argument-ls
         (()
@@ -288,10 +267,24 @@
          (cond
           ((regexp-exec short-opt-rx opt)
            => (lambda (match)
-                (let* ((c (match:substring match 1))
-                       (spec (or (assoc-ref sc-idx c)
-                                 (fatal-error "no such option: -~a" c))))
-                  (eat! spec rest))))
+                (if (> unclumped 0)
+                    ;; Next option is known not to be clumped.
+                    (let* ((c (match:substring match 1))
+                           (spec (or (assoc-ref sc-idx c)
+                                     (fatal-error "no such option: -~a" c))))
+                      (eat! spec rest))
+                    ;; Expand a clumped group of short options.
+                    (let* ((extra (match:substring match 2))
+                           (unclumped-opts
+                            (append (map (lambda (c)
+                                           (string-append "-" (make-string 1 c)))
+                                         (string->list
+                                          (match:substring match 1)))
+                                    (if (string=? "" extra) '() (list extra)))))
+                      (loop (length unclumped-opts)
+                            (append unclumped-opts rest)
+                            found
+                            etc)))))
           ((regexp-exec long-opt-no-value-rx opt)
            => (lambda (match)
                 (let* ((opt (match:substring match 1))
@@ -308,7 +301,7 @@
                       (fatal-error "option does not support argument: --~a"
                                    opt)))))
           (else
-           (loop rest found (cons opt etc)))))))))
+           (loop (- unclumped 1) rest found (cons opt etc)))))))))
 
 (define (getopt-long program-arguments option-desc-list)
   "Process options, handling both long and short options, similar to
@@ -344,7 +337,7 @@ to add a `single-char' clause to the option description."
   (with-fluids ((%program-name (car program-arguments)))
     (let* ((specifications (map parse-option-spec option-desc-list))
            (pair (split-arg-list (cdr program-arguments)))
-           (split-ls (expand-clumped-singles (car pair)))
+           (split-ls (car pair))
            (non-split-ls (cdr pair))
            (found/etc (process-options specifications split-ls))
            (found (car found/etc))
-- 
1.7.4.1

[PATCH 4/5] Implement #:stop-at-first-non-option option for getopt-long

[Neil Jerram]

(For use by guile-tools)

* module/ice-9/getopt-long.scm: Use (ice-9 optargs) so we can use
  define*.

  (process-options): Add stop-at-first-non-option parameter.  When
  this is true, stop processing when we hit a non-option (so long as
  that non-option isn't something that resulted from the unclumping of
  a short option group).

  (getopt-long): Add #:stop-at-first-non-option keyword; pass it on to
  process-options.

* test-suite/tests/getopt-long.test ("stop-at-first-non-option"): New
  test (for the above).
---
 module/ice-9/getopt-long.scm      |   12 +++++++++---
 test-suite/tests/getopt-long.test |   11 +++++++++++
 2 files changed, 20 insertions(+), 3 deletions(-)

diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm
index 0c2d835..12f8c94 100644
--- a/module/ice-9/getopt-long.scm
+++ b/module/ice-9/getopt-long.scm
@@ -161,6 +161,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 optargs)
   #:export (getopt-long option-ref))
 
 (define %program-name (make-fluid))
@@ -231,7 +232,7 @@
       (regexp-exec long-opt-with-value-rx string)
       (regexp-exec long-opt-no-value-rx string)))
 
-(define (process-options specs argument-ls)
+(define (process-options specs argument-ls stop-at-first-non-option)
   ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
   ;; FOUND is an unordered list of option specs for found options, while ETC
   ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
@@ -300,10 +301,14 @@
                       (eat! spec (cons (match:substring match 2) rest))
                       (fatal-error "option does not support argument: --~a"
                                    opt)))))
+          ((and stop-at-first-non-option
+                (<= unclumped 0))
+           (cons found (append (reverse etc) argument-ls)))
           (else
            (loop (- unclumped 1) rest found (cons opt etc)))))))))
 
-(define (getopt-long program-arguments option-desc-list)
+(define* (getopt-long program-arguments option-desc-list
+                      #:key stop-at-first-non-option)
   "Process options, handling both long and short options, similar to
 the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
 similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
@@ -339,7 +344,8 @@ to add a `single-char' clause to the option description."
            (pair (split-arg-list (cdr program-arguments)))
            (split-ls (car pair))
            (non-split-ls (cdr pair))
-           (found/etc (process-options specifications split-ls))
+           (found/etc (process-options specifications split-ls
+                                       stop-at-first-non-option))
            (found (car found/etc))
            (rest-ls (append (cdr found/etc) non-split-ls)))
       (for-each (lambda (spec)
diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test
index 682763c..4ae6048 100644
--- a/test-suite/tests/getopt-long.test
+++ b/test-suite/tests/getopt-long.test
@@ -288,4 +288,15 @@
 
   )
 
+(with-test-prefix "stop-at-first-non-option"
+
+  (pass-if "guile-tools compile example"
+    (equal? (getopt-long '("guile-tools" "compile" "-Wformat" "eval.scm" "-o" "eval.go")
+                         '((help (single-char #\h))
+                           (version (single-char #\v)))
+                         #:stop-at-first-non-option #t)
+            '((() "compile" "-Wformat" "eval.scm" "-o" "eval.go"))))
+
+  )
+
 ;;; getopt-long.test ends here
-- 
1.7.4.1

[PATCH 5/5] Reveal guile-tools's inner simplicity...

[Neil Jerram]

...by not using its own-rolled getopt, and moving the `list' function
to a separate script

* meta/guile-tools.in: Use (ice-9 getopt-long).

  (directory-files, strip-extensions, unique, find-submodules,
  list-scripts): Deleted (and moved to new `list' file).

  (getopt): Deleted.

  (main): Use getopt-long.  Default to calling the `list' script if no
  script is specified.

* module/scripts/list.scm: New script.
---
 meta/guile-tools.in     |  160 +++++++----------------------------------------
 module/scripts/list.scm |   83 ++++++++++++++++++++++++
 2 files changed, 106 insertions(+), 137 deletions(-)
 create mode 100644 module/scripts/list.scm

diff --git a/meta/guile-tools.in b/meta/guile-tools.in
index 7f156ff..67d70f0 100755
--- a/meta/guile-tools.in
+++ b/meta/guile-tools.in
@@ -24,7 +24,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@"
 ;;;; Boston, MA 02110-1301 USA
 
 (define-module (guile-tools)
-  #:use-module ((srfi srfi-1) #:select (fold append-map))
+  #:use-module (ice-9 getopt-long)
   #:autoload (ice-9 format) (format))
 
 ;; Hack to provide scripts with the bug-report address.
@@ -55,146 +55,32 @@ This is free software: you are free to change and redistribute it.
 There is NO WARRANTY, to the extent permitted by law.
 " (version) (effective-version)))
 
-(define (directory-files dir)
-  (if (and (file-exists? dir) (file-is-directory? dir))
-      (let ((dir-stream (opendir dir)))
-        (let loop ((new (readdir dir-stream))
-                   (acc '()))
-          (if (eof-object? new)
-              (begin
-                (closedir dir-stream)
-                acc)
-              (loop (readdir dir-stream)
-                    (if (or (string=? "."  new)             ; ignore
-                            (string=? ".." new))            ; ignore
-                        acc
-                        (cons new acc))))))
-      '()))
-
-(define (strip-extensions path)
-  (or-map (lambda (ext)
-            (and
-             (string-suffix? ext path)
-             (substring path 0
-                        (- (string-length path) (string-length ext)))))
-          (append %load-compiled-extensions %load-extensions)))
-
-(define (unique l)
-  (cond ((null? l) l)
-        ((null? (cdr l)) l)
-        ((equal? (car l) (cadr l)) (unique (cdr l)))
-        (else (cons (car l) (unique (cdr l))))))
-
-(define (find-submodules head)
-  (let ((shead (map symbol->string head)))
-    (unique
-     (sort
-      (append-map (lambda (path)
-                    (fold (lambda (x rest)
-                            (let ((stripped (strip-extensions x)))
-                              (if stripped (cons stripped rest) rest)))
-                          '()
-                          (directory-files
-                           (fold (lambda (x y) (in-vicinity y x)) path shead))))
-                  %load-path)
-      string<?))))
-
-(define (list-scripts)
-  (for-each (lambda (x)
-              ;; would be nice to show a summary.
-              (format #t "~A\n" x))
-            (find-submodules '(scripts))))
-
 (define (find-script s)
   (resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
 
-(define (getopt args grammar)
-  (define (fail)
-    (format (current-error-port)
-            "Try `guile-tools --help' for more information.~%")
-    (exit 1))
-
-  (define (unrecognized-arg arg)
-    (format (current-error-port)
-            "guile-tools: unrecognized option: `~a'~%" arg)
-    (fail))
-
-  (define (unexpected-value sym val)
-    (format (current-error-port)
-            "guile-tools: option `--~a' does not take an argument (given ~s)~%"
-            sym val)
-    (fail))
-
-  (define (single-char-table grammar)
-    (cond
-     ((null? grammar) '())
-     ((assq 'single-char (cdar grammar))
-      => (lambda (form)
-           (acons (cadr form) (car grammar)
-                  (single-char-table (cdr grammar)))))
-     (else
-      (single-char-table (cdr grammar)))))
-  
-  (let ((single (single-char-table grammar)))
-    (let lp ((args (cdr args)) (options '()))
-      (cond
-       ((or (null? args) (equal? (car args) "-"))
-        (values (reverse options) args))
-       ((equal? (car args) "--")
-        (values (reverse options) (cdr args)))
-       ((string-prefix? "--" (car args))
-        (let* ((str (car args))
-               (eq (string-index str #\= 2))
-               (sym (string->symbol
-                     (substring str 2 (or eq (string-length str)))))
-               (val (and eq (substring str (1+ eq))))
-               (spec (assq sym grammar)))
-          (cond
-           ((not spec)
-            (unrecognized-arg (substring str 0 (or eq (string-length str)))))
-           (val
-            ;; no values for now
-            (unexpected-value sym val))
-           ((assq-ref (cdr spec) 'value)
-            (error "options with values not supported right now"))
-           (else
-            (lp (cdr args) (acons sym #f options))))))
-       ((string-prefix? "-" (car args))
-        (let lp* ((chars (cdr (string->list (car args)))) (options options))
-          (if (null? chars)
-              (lp (cdr args) options)
-              (let ((spec (assv-ref single (car chars))))
-                (cond
-                 ((not spec)
-                  (unrecognized-arg (string #\- (car chars))))
-                 ((assq-ref (cdr spec) 'value)
-                  (error "options with values not supported right now"))
-                 (else
-                  (lp* (cdr chars) (acons (car spec) #f options))))))))
-       (else (values (reverse options) args))))))
-
 (define (main args)
   (if (defined? 'setlocale)
       (setlocale LC_ALL ""))
 
-  (call-with-values (lambda () (getopt args *option-grammar*))
-    (lambda (options args)
-      (cond
-       ((assq 'help options)
-        (display-help)
-        (exit 0))
-       ((assq 'version options)
-        (display-version)
-        (exit 0))
-       ((or (equal? args '())
-            (equal? args '("list")))
-        (list-scripts))
-       ((find-script (car args))
-        => (lambda (mod)
-             (exit (apply (module-ref mod 'main) (cdr args)))))
-       (else
-        (format (current-error-port)
-                "guile-tools: unknown script ~s~%" (car args))
-        (format (current-error-port)
-                "Try `guile-tools --help' for more information.~%")
-        (exit 1))))))
+  (let ((options (getopt-long args *option-grammar*
+                              #:stop-at-first-non-option #t)))
+    (cond
+     ((option-ref options 'help #f)
+      (display-help)
+      (exit 0))
+     ((option-ref options 'version #f)
+      (display-version)
+      (exit 0))
+     (else
+      (let ((args (option-ref options '() '())))
+        (cond ((find-script (if (null? args)
+                                "list"
+                                (car args)))
+               => (lambda (mod)
+                    (exit (apply (module-ref mod 'main) (cdr args)))))
+              (else
+               (format (current-error-port)
+                       "guile-tools: unknown script ~s~%" (car args))
+               (format (current-error-port)
+                       "Try `guile-tools --help' for more information.~%")
+               (exit 1))))))))
diff --git a/module/scripts/list.scm b/module/scripts/list.scm
new file mode 100644
index 0000000..046d8f5
--- /dev/null
+++ b/module/scripts/list.scm
@@ -0,0 +1,83 @@
+;;; List --- List scripts that can be invoked by guile-tools  -*- coding: iso-8859-1 -*-
+
+;;;; 	Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Usage: list
+;;
+;; List scripts that can be invoked by guile-tools.
+
+;;; Code:
+
+(define-module (scripts list)
+  #:use-module ((srfi srfi-1) #:select (fold append-map))
+  #:export (list-scripts))
+
+\f
+(define (directory-files dir)
+  (if (and (file-exists? dir) (file-is-directory? dir))
+      (let ((dir-stream (opendir dir)))
+        (let loop ((new (readdir dir-stream))
+                   (acc '()))
+          (if (eof-object? new)
+              (begin
+                (closedir dir-stream)
+                acc)
+              (loop (readdir dir-stream)
+                    (if (or (string=? "."  new)             ; ignore
+                            (string=? ".." new))            ; ignore
+                        acc
+                        (cons new acc))))))
+      '()))
+
+(define (strip-extensions path)
+  (or-map (lambda (ext)
+            (and
+             (string-suffix? ext path)
+             (substring path 0
+                        (- (string-length path) (string-length ext)))))
+          (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+  (cond ((null? l) l)
+        ((null? (cdr l)) l)
+        ((equal? (car l) (cadr l)) (unique (cdr l)))
+        (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+  (let ((shead (map symbol->string head)))
+    (unique
+     (sort
+      (append-map (lambda (path)
+                    (fold (lambda (x rest)
+                            (let ((stripped (strip-extensions x)))
+                              (if stripped (cons stripped rest) rest)))
+                          '()
+                          (directory-files
+                           (fold (lambda (x y) (in-vicinity y x)) path shead))))
+                  %load-path)
+      string<?))))
+
+(define (list-scripts . args)
+  (for-each (lambda (x)
+              ;; would be nice to show a summary.
+              (format #t "~A\n" x))
+            (find-submodules '(scripts))))
+
+(define main list-scripts)
-- 
1.7.4.1

Re: [PATCH 5/5] Reveal guile-tools's inner simplicity...

[Neil Jerram]

[-- Attachment #1: Type: text/plain, Size: 224 bytes --]

Neil Jerram <neil@ossau.uklinux.net> writes:

> ...by not using its own-rolled getopt, and moving the `list' function
> to a separate script

That one wasn't quite right, please refer to the attached instead.

        Neil


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0005-Reveal-guile-tools-s-inner-simplicity.patch --]
[-- Type: text/x-diff, Size: 11316 bytes --]

From c106e51707004fb1549add9d1db59c0b45bfed18 Mon Sep 17 00:00:00 2001
From: Neil Jerram <neil@ossau.uklinux.net>
Date: Sun, 8 May 2011 22:51:07 +0100
Subject: [PATCH] Reveal guile-tools's inner simplicity...

...by not using its own-rolled getopt, and moving the `list' function
to a separate script

* meta/guile-tools.in: Use (ice-9 getopt-long).

  (directory-files, strip-extensions, unique, find-submodules,
  list-scripts): Deleted (and moved to new `list.scm' file).

  (getopt): Deleted.

  (main): Use getopt-long.  Default to calling the `list' script if no
  script is specified.

* module/scripts/list.scm: New script.

* module/Makefile.am (SCRIPTS_SOURCES): Add list.scm.
---
 meta/guile-tools.in     |  162 +++++++---------------------------------------
 module/Makefile.am      |    1 +
 module/scripts/list.scm |   83 ++++++++++++++++++++++++
 3 files changed, 109 insertions(+), 137 deletions(-)
 create mode 100644 module/scripts/list.scm

diff --git a/meta/guile-tools.in b/meta/guile-tools.in
index 7f156ff..2f335b8 100755
--- a/meta/guile-tools.in
+++ b/meta/guile-tools.in
@@ -24,7 +24,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@"
 ;;;; Boston, MA 02110-1301 USA
 
 (define-module (guile-tools)
-  #:use-module ((srfi srfi-1) #:select (fold append-map))
+  #:use-module (ice-9 getopt-long)
   #:autoload (ice-9 format) (format))
 
 ;; Hack to provide scripts with the bug-report address.
@@ -55,146 +55,34 @@ This is free software: you are free to change and redistribute it.
 There is NO WARRANTY, to the extent permitted by law.
 " (version) (effective-version)))
 
-(define (directory-files dir)
-  (if (and (file-exists? dir) (file-is-directory? dir))
-      (let ((dir-stream (opendir dir)))
-        (let loop ((new (readdir dir-stream))
-                   (acc '()))
-          (if (eof-object? new)
-              (begin
-                (closedir dir-stream)
-                acc)
-              (loop (readdir dir-stream)
-                    (if (or (string=? "."  new)             ; ignore
-                            (string=? ".." new))            ; ignore
-                        acc
-                        (cons new acc))))))
-      '()))
-
-(define (strip-extensions path)
-  (or-map (lambda (ext)
-            (and
-             (string-suffix? ext path)
-             (substring path 0
-                        (- (string-length path) (string-length ext)))))
-          (append %load-compiled-extensions %load-extensions)))
-
-(define (unique l)
-  (cond ((null? l) l)
-        ((null? (cdr l)) l)
-        ((equal? (car l) (cadr l)) (unique (cdr l)))
-        (else (cons (car l) (unique (cdr l))))))
-
-(define (find-submodules head)
-  (let ((shead (map symbol->string head)))
-    (unique
-     (sort
-      (append-map (lambda (path)
-                    (fold (lambda (x rest)
-                            (let ((stripped (strip-extensions x)))
-                              (if stripped (cons stripped rest) rest)))
-                          '()
-                          (directory-files
-                           (fold (lambda (x y) (in-vicinity y x)) path shead))))
-                  %load-path)
-      string<?))))
-
-(define (list-scripts)
-  (for-each (lambda (x)
-              ;; would be nice to show a summary.
-              (format #t "~A\n" x))
-            (find-submodules '(scripts))))
-
 (define (find-script s)
   (resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
 
-(define (getopt args grammar)
-  (define (fail)
-    (format (current-error-port)
-            "Try `guile-tools --help' for more information.~%")
-    (exit 1))
-
-  (define (unrecognized-arg arg)
-    (format (current-error-port)
-            "guile-tools: unrecognized option: `~a'~%" arg)
-    (fail))
-
-  (define (unexpected-value sym val)
-    (format (current-error-port)
-            "guile-tools: option `--~a' does not take an argument (given ~s)~%"
-            sym val)
-    (fail))
-
-  (define (single-char-table grammar)
-    (cond
-     ((null? grammar) '())
-     ((assq 'single-char (cdar grammar))
-      => (lambda (form)
-           (acons (cadr form) (car grammar)
-                  (single-char-table (cdr grammar)))))
-     (else
-      (single-char-table (cdr grammar)))))
-  
-  (let ((single (single-char-table grammar)))
-    (let lp ((args (cdr args)) (options '()))
-      (cond
-       ((or (null? args) (equal? (car args) "-"))
-        (values (reverse options) args))
-       ((equal? (car args) "--")
-        (values (reverse options) (cdr args)))
-       ((string-prefix? "--" (car args))
-        (let* ((str (car args))
-               (eq (string-index str #\= 2))
-               (sym (string->symbol
-                     (substring str 2 (or eq (string-length str)))))
-               (val (and eq (substring str (1+ eq))))
-               (spec (assq sym grammar)))
-          (cond
-           ((not spec)
-            (unrecognized-arg (substring str 0 (or eq (string-length str)))))
-           (val
-            ;; no values for now
-            (unexpected-value sym val))
-           ((assq-ref (cdr spec) 'value)
-            (error "options with values not supported right now"))
-           (else
-            (lp (cdr args) (acons sym #f options))))))
-       ((string-prefix? "-" (car args))
-        (let lp* ((chars (cdr (string->list (car args)))) (options options))
-          (if (null? chars)
-              (lp (cdr args) options)
-              (let ((spec (assv-ref single (car chars))))
-                (cond
-                 ((not spec)
-                  (unrecognized-arg (string #\- (car chars))))
-                 ((assq-ref (cdr spec) 'value)
-                  (error "options with values not supported right now"))
-                 (else
-                  (lp* (cdr chars) (acons (car spec) #f options))))))))
-       (else (values (reverse options) args))))))
-
 (define (main args)
   (if (defined? 'setlocale)
       (setlocale LC_ALL ""))
 
-  (call-with-values (lambda () (getopt args *option-grammar*))
-    (lambda (options args)
-      (cond
-       ((assq 'help options)
-        (display-help)
-        (exit 0))
-       ((assq 'version options)
-        (display-version)
-        (exit 0))
-       ((or (equal? args '())
-            (equal? args '("list")))
-        (list-scripts))
-       ((find-script (car args))
-        => (lambda (mod)
-             (exit (apply (module-ref mod 'main) (cdr args)))))
-       (else
-        (format (current-error-port)
-                "guile-tools: unknown script ~s~%" (car args))
-        (format (current-error-port)
-                "Try `guile-tools --help' for more information.~%")
-        (exit 1))))))
+  (let ((options (getopt-long args *option-grammar*
+                              #:stop-at-first-non-option #t)))
+    (cond
+     ((option-ref options 'help #f)
+      (display-help)
+      (exit 0))
+     ((option-ref options 'version #f)
+      (display-version)
+      (exit 0))
+     (else
+      (let ((args (option-ref options '() '())))
+        (cond ((find-script (if (null? args)
+                                "list"
+                                (car args)))
+               => (lambda (mod)
+                    (exit (apply (module-ref mod 'main) (if (null? args)
+                                                            '()
+                                                            (cdr args))))))
+              (else
+               (format (current-error-port)
+                       "guile-tools: unknown script ~s~%" (car args))
+               (format (current-error-port)
+                       "Try `guile-tools --help' for more information.~%")
+               (exit 1))))))))
diff --git a/module/Makefile.am b/module/Makefile.am
index 42aff18..ddd4674 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -155,6 +155,7 @@ SCRIPTS_SOURCES =				\
   scripts/frisk.scm				\
   scripts/generate-autoload.scm			\
   scripts/lint.scm				\
+  scripts/list.scm				\
   scripts/punify.scm				\
   scripts/read-scheme-source.scm		\
   scripts/read-text-outline.scm			\
diff --git a/module/scripts/list.scm b/module/scripts/list.scm
new file mode 100644
index 0000000..046d8f5
--- /dev/null
+++ b/module/scripts/list.scm
@@ -0,0 +1,83 @@
+;;; List --- List scripts that can be invoked by guile-tools  -*- coding: iso-8859-1 -*-
+
+;;;; 	Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Usage: list
+;;
+;; List scripts that can be invoked by guile-tools.
+
+;;; Code:
+
+(define-module (scripts list)
+  #:use-module ((srfi srfi-1) #:select (fold append-map))
+  #:export (list-scripts))
+
+\f
+(define (directory-files dir)
+  (if (and (file-exists? dir) (file-is-directory? dir))
+      (let ((dir-stream (opendir dir)))
+        (let loop ((new (readdir dir-stream))
+                   (acc '()))
+          (if (eof-object? new)
+              (begin
+                (closedir dir-stream)
+                acc)
+              (loop (readdir dir-stream)
+                    (if (or (string=? "."  new)             ; ignore
+                            (string=? ".." new))            ; ignore
+                        acc
+                        (cons new acc))))))
+      '()))
+
+(define (strip-extensions path)
+  (or-map (lambda (ext)
+            (and
+             (string-suffix? ext path)
+             (substring path 0
+                        (- (string-length path) (string-length ext)))))
+          (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+  (cond ((null? l) l)
+        ((null? (cdr l)) l)
+        ((equal? (car l) (cadr l)) (unique (cdr l)))
+        (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+  (let ((shead (map symbol->string head)))
+    (unique
+     (sort
+      (append-map (lambda (path)
+                    (fold (lambda (x rest)
+                            (let ((stripped (strip-extensions x)))
+                              (if stripped (cons stripped rest) rest)))
+                          '()
+                          (directory-files
+                           (fold (lambda (x y) (in-vicinity y x)) path shead))))
+                  %load-path)
+      string<?))))
+
+(define (list-scripts . args)
+  (for-each (lambda (x)
+              ;; would be nice to show a summary.
+              (format #t "~A\n" x))
+            (find-submodules '(scripts))))
+
+(define main list-scripts)
-- 
1.7.4.1

Re: [PATCH] Simplifying guile-tools

[Neil Jerram]

Neil Jerram <neil@ossau.uklinux.net> writes:

> The end result is that guile-tools is a lot shorter and (IMO) sweeter.
>
> Here are the titles of the following patches.
>
>  [PATCH 1/5] Fix "occurrances" typos in getopt-long code and test
>  [PATCH 2/5] Simplify getopt-long handling of option values, esp with multiple occurrences
>  [PATCH 3/5] Handle short option unclumping progressively, instead of all upfront
>  [PATCH 4/5] Implement #:stop-at-first-non-option option for getopt-long
>  [PATCH 5/5] Reveal guile-tools's inner simplicity...
>
> What do you think?

Just a gentle ping regarding these patches...  Andy / Ludo, I guess you
might be assuming that I'd just go ahead and push these anyway - but I'd
prefer an explicit opinion or OK from you.

(And the same for the 1-based line number fix.)

Regards,
       Neil

Re: [PATCH] Simplifying guile-tools

[Andy Wingo]

On Tue 24 May 2011 00:23, Neil Jerram <neil@ossau.uklinux.net> writes:

> Neil Jerram <neil@ossau.uklinux.net> writes:
>
>>  [PATCH 1/5] Fix "occurrances" typos in getopt-long code and test
>>  [PATCH 2/5] Simplify getopt-long handling of option values, esp with multiple occurrences
>>  [PATCH 3/5] Handle short option unclumping progressively, instead of all upfront
>>  [PATCH 4/5] Implement #:stop-at-first-non-option option for getopt-long
>>  [PATCH 5/5] Reveal guile-tools's inner simplicity...
>
> Just a gentle ping regarding these patches...  Andy / Ludo, I guess you
> might be assuming that I'd just go ahead and push these anyway - but I'd
> prefer an explicit opinion or OK from you.
>
> (And the same for the 1-based line number fix.)

Sorry for the delay.  They look great to me!  The 1-based line number
fix too.

Happy hacking,

Andy
-- 
http://wingolog.org/

Re: [PATCH] Simplifying guile-tools

[Neil Jerram]

Andy Wingo <wingo@pobox.com> writes:

> On Tue 24 May 2011 00:23, Neil Jerram <neil@ossau.uklinux.net> writes:
>
>> Neil Jerram <neil@ossau.uklinux.net> writes:
>>
>>>  [PATCH 1/5] Fix "occurrances" typos in getopt-long code and test
>>>  [PATCH 2/5] Simplify getopt-long handling of option values, esp with multiple occurrences
>>>  [PATCH 3/5] Handle short option unclumping progressively, instead of all upfront
>>>  [PATCH 4/5] Implement #:stop-at-first-non-option option for getopt-long
>>>  [PATCH 5/5] Reveal guile-tools's inner simplicity...
>>
>> Just a gentle ping regarding these patches...  Andy / Ludo, I guess you
>> might be assuming that I'd just go ahead and push these anyway - but I'd
>> prefer an explicit opinion or OK from you.
>>
>> (And the same for the 1-based line number fix.)
>
> Sorry for the delay.  They look great to me!  The 1-based line number
> fix too.

Thanks; those patches are in now.  I'll also soon provide a doc update
for the new getopt option.

       Neil