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: Re: [PATCH 5/5] Reveal guile-tools's inner simplicity... Date: Mon, 09 May 2011 22:43:56 +0100 Message-ID: <87tyd335yb.fsf@ossau.uklinux.net> References: <1304893097-10889-1-git-send-email-neil@ossau.uklinux.net> <1304893097-10889-6-git-send-email-neil@ossau.uklinux.net> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1304977670 12776 80.91.229.12 (9 May 2011 21:47:50 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Mon, 9 May 2011 21:47:50 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon May 09 23:47:46 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 1QJYIn-00067n-Gz for guile-devel@m.gmane.org; Mon, 09 May 2011 23:47:41 +0200 Original-Received: from localhost ([::1]:56435 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJYIn-0000DM-10 for guile-devel@m.gmane.org; Mon, 09 May 2011 17:47:41 -0400 Original-Received: from eggs.gnu.org ([140.186.70.92]:35938) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJYFF-0002Uz-Dk for guile-devel@gnu.org; Mon, 09 May 2011 17:44:02 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1QJYFE-0007hR-2A for guile-devel@gnu.org; Mon, 09 May 2011 17:44:01 -0400 Original-Received: from mail3.uklinux.net ([80.84.72.33]:59724) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJYFD-0007hN-Jz for guile-devel@gnu.org; Mon, 09 May 2011 17:44:00 -0400 Original-Received: from arudy (unknown [78.149.196.143]) by mail3.uklinux.net (Postfix) with ESMTP id D46CC1F6090 for ; Mon, 9 May 2011 22:43:57 +0100 (BST) Original-Received: from neil-laptop (unknown [192.168.11.9]) by arudy (Postfix) with ESMTP id 2BDA03803B for ; Mon, 9 May 2011 22:43:57 +0100 (BST) In-Reply-To: <1304893097-10889-6-git-send-email-neil@ossau.uklinux.net> (Neil Jerram's message of "Sun, 8 May 2011 23:18:17 +0100") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.2 (gnu/linux) 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:12476 Archived-At: --=-=-= Neil Jerram 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 --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0005-Reveal-guile-tools-s-inner-simplicity.patch >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