diff options
author | Neil Jerram <neil@ossau.uklinux.net> | 2011-05-08 22:51:07 +0100 |
---|---|---|
committer | Neil Jerram <neil@ossau.uklinux.net> | 2011-05-26 17:58:18 +0100 |
commit | 9228f9eb956e8a7588c315239511fc4e08e16553 (patch) | |
tree | 040c49ed41815d9b01522a57a5e080da7c32e380 /module/scripts | |
parent | 6b4b4bfb0925adb2da66f4b49deb570da33c737d (diff) | |
download | guile-9228f9eb956e8a7588c315239511fc4e08e16553.tar.gz |
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.
Diffstat (limited to 'module/scripts')
-rw-r--r-- | module/scripts/list.scm | 83 |
1 files changed, 83 insertions, 0 deletions
diff --git a/module/scripts/list.scm b/module/scripts/list.scm new file mode 100644 index 000000000..046d8f5b8 --- /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<?)))) + +(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) |