From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Neil Jerram Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 5/5] Reveal guile-tools's inner simplicity... Date: Sun, 8 May 2011 23:18:17 +0100 Message-ID: <1304893097-10889-6-git-send-email-neil@ossau.uklinux.net> References: <1304893097-10889-1-git-send-email-neil@ossau.uklinux.net> NNTP-Posting-Host: lo.gmane.org X-Trace: dough.gmane.org 1304893197 27093 80.91.229.12 (8 May 2011 22:19:57 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sun, 8 May 2011 22:19:57 +0000 (UTC) Cc: Neil Jerram To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon May 09 00:19:51 2011 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([140.186.70.17]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1QJCKM-0003ry-AC for guile-devel@m.gmane.org; Mon, 09 May 2011 00:19:50 +0200 Original-Received: from localhost ([::1]:37424 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJCKL-0000ie-Pe for guile-devel@m.gmane.org; Sun, 08 May 2011 18:19:49 -0400 Original-Received: from eggs.gnu.org ([140.186.70.92]:42108) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJCKF-0000hS-Kh for guile-devel@gnu.org; Sun, 08 May 2011 18:19:44 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1QJCKD-0002sB-Cr for guile-devel@gnu.org; Sun, 08 May 2011 18:19:43 -0400 Original-Received: from mail3.uklinux.net ([80.84.72.33]:52021) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJCKC-0002mr-P6 for guile-devel@gnu.org; Sun, 08 May 2011 18:19:41 -0400 Original-Received: from arudy (unknown [78.149.196.143]) by mail3.uklinux.net (Postfix) with ESMTP id D6DF61F66A8 for ; Sun, 8 May 2011 23:18:54 +0100 (BST) Original-Received: from neil-laptop.520b.com (unknown [192.168.11.9]) by arudy (Postfix) with ESMTP id 4C15B38043; Sun, 8 May 2011 23:18:51 +0100 (BST) X-Mailer: git-send-email 1.7.4.1 In-Reply-To: <1304893097-10889-1-git-send-email-neil@ossau.uklinux.net> X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.4-2.6 X-Received-From: 80.84.72.33 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:12469 Archived-At: ...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) - 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) (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)) + + +(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