Implemented unless, when and dotimes using built-in macros.

[bpt/guile.git] / meta / guile-tools

#!/bin/sh
# -*- scheme -*-
exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@"
!#

;;;; guile-tools --- running scripts bundled with Guile
;;;; Andy Wingo <wingo@pobox.com> --- April 2009
;;;; 
;;;; 	Copyright (C) 2009 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

(define-module (guile-tools))

;; We can't import srfi-1, unfortunately, as we are used early in the
;; boot process, before the srfi-1 shlib is built.

(define (fold kons seed seq)
  (if (null? seq)
      seed
      (fold kons (kons (car seq) seed) (cdr seq))))

(define (help)
  (display "\
Usage: guile-tools --version
       guile-tools --help
       guile-tools PROGRAM [ARGS]

If PROGRAM is \"list\" or omitted, display available scripts, otherwise
PROGRAM is run with ARGS.
"))

(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))))))

;; for want of srfi-1
(define (append-map f l)
  (apply append (map f 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)
  (let ((m (resolve-module (append '(scripts) (list (string->symbol s))))))
    (and (module-public-interface m)
         m)))

(define (main args)
  (if (or (equal? (cdr args) '())
          (equal? (cdr args) '("list")))
      (list-scripts)
      (let ((mod (find-script (cadr args))))
        (exit (apply (module-ref mod 'main) (cddr args))))))