module/scripts/punify.scm

   1 ;;; punify --- Display Scheme code w/o unnecessary comments / whitespace
   2
   3 ;;      Copyright (C) 2001, 2006 Free Software Foundation, Inc.
   4 ;;
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public License
   7 ;; as published by the Free Software Foundation; either version 3, or
   8 ;; (at your option) any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this software; see the file COPYING.LESSER.  If
  17 ;; not, write to the Free Software Foundation, Inc., 51 Franklin
  18 ;; Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 ;;; Author: Thien-Thi Nguyen
  21
  22 ;;; Commentary:
  23
  24 ;; Usage: punify FILE1 FILE2 ...
  25 ;;
  26 ;; Each file's forms are read and written to stdout.
  27 ;; The effect is to remove comments and much non-essential whitespace.
  28 ;; This is useful when installing Scheme source to space-limited media.
  29 ;;
  30 ;; Example:
  31 ;; $ wc ./punify ; ./punify ./punify | wc
  32 ;;     89     384    3031 ./punify
  33 ;;      0      42     920
  34 ;;
  35 ;; TODO: Read from stdin.
  36 ;;       Handle vectors.
  37 ;;       Identifier punification.
  38
  39 ;;; Code:
  40
  41 (define-module (scripts punify)
  42   :export (punify))
  43
  44 (define (write-punily form)
  45   (cond ((and (list? form) (not (null? form)))
  46          (let ((first (car form)))
  47            (display "(")
  48            (write-punily first)
  49            (let loop ((ls (cdr form)) (last-was-list? (list? first)))
  50              (if (null? ls)
  51                  (display ")")
  52                  (let* ((new-first (car ls))
  53                         (this-is-list? (list? new-first)))
  54                    (and (not last-was-list?)
  55                         (not this-is-list?)
  56                         (display " "))
  57                    (write-punily new-first)
  58                    (loop (cdr ls) this-is-list?))))))
  59         ((and (symbol? form)
  60               (let ((ls (string->list (symbol->string form))))
  61                 (and (char=? (car ls) #\:)
  62                      (not (memq #\space ls))
  63                      (list->string (cdr ls)))))
  64          => (lambda (symbol-name-after-colon)
  65               (display #\:)
  66               (display symbol-name-after-colon)))
  67         (else (write form))))
  68
  69 (define (punify-one file)
  70   (with-input-from-file file
  71     (lambda ()
  72       (let ((toke (lambda () (read (current-input-port)))))
  73         (let loop ((form (toke)))
  74           (or (eof-object? form)
  75               (begin
  76                 (write-punily form)
  77                 (loop (toke)))))))))
  78
  79 (define (punify . args)
  80   (for-each punify-one args))
  81
  82 (define main punify)
  83
  84 ;;; punify ends here