>From c106e51707004fb1549add9d1db59c0b45bfed18 Mon Sep 17 00:00:00 2001 From: Neil Jerram 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) - stringsymbol 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)) + + +(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