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

[Neil Jerram <neil@ossau.uklinux.net>]

[-- 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