#!/usr/bin/guile \
-e "(scripts punify)" -s
!#
;;; punify --- Display Scheme code w/o unnecessary comments / whitespace

;; 	Copyright (C) 2001,2003,2004 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program 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
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: punify [-i] [-n] [FILE1 FILE2 ...]
;;
;; Read forms from each FILE (or stdin if no files are specified) and
;; write them to stdout, removing comments and non-essential whitespace.
;; This is useful when installing Scheme source to space-limited media.
;; An exception is made for certain whitespace characters appearing in a
;; string.  They are expanded to their two-character "escaped" form:
;;
;;     #\bel  \a     #\newline  \n     #\ht  \t
;;     #\np   \f     #\cr       \r     #\vt  \v
;;
;; Option `--newline-after-top-level-form' (or `-n' for short) means to
;; output a newline after each top-level form.
;;
;; Option `--inplace' (or `-i' for short) means to modify the file in place,
;; and display to stdout an informational message for each file processed.
;;
;; Example:
;; $ wc ./punify ; ./punify ./punify | wc
;;   220     978    8460 ./punify
;;     0     167    3025
;;
;;
;; Usage from a Scheme program:
;;  (use-modules (scripts punify))
;;  (punify [input ...])
;;
;; Each INPUT is either a filename (string) or an input port.

;;; Code:

(define-module (scripts punify)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:export (punify))

(define (write-punily form)
  (cond ((vector? form)
         (display #\#)
         (write-punily (vector->list form)))
        ((and (list? form) (not (null? form)))
         (let ((first (car form)))
           (display "(")
           (write-punily first)
           (let loop ((ls (cdr form)) (last-was-list? (list? first)))
             (if (null? ls)
                 (display ")")
                 (let* ((new-first (car ls))
                        (this-is-list? (list? new-first)))
                   (and (not last-was-list?)
                        (not this-is-list?)
                        (display #\space))
                   (write-punily new-first)
                   (loop (cdr ls) this-is-list?))))))
        ((string? form)
         (display #\")
         (let loop ((ls (string->list form)))
           (or (null? ls)
               (let ((c (car ls)))
                 (display (case c
                            ((#\bel)     "\\a")
                            ((#\np)      "\\f")
                            ((#\newline) "\\n")
                            ((#\cr)      "\\r")
                            ((#\ht)      "\\t")
                            ((#\vt)      "\\v")
                            ((#\")      "\\\"")
                            ((#\\)      "\\\\")
                            (else c)))
                 (loop (cdr ls)))))
         (display #\"))
        ((and (symbol? form)
              (let ((ls (string->list (symbol->string form))))
                (and (char=? (car ls) #\:)
                     (not (memq #\space ls))
                     (list->string (cdr ls)))))
         => (lambda (symbol-name-after-colon)
              (display #\:)
              (display symbol-name-after-colon)))
        (else (write form))))

(define *newline-after-top-level-form* #f)

(define (punify-one port)
  (let ((toke (lambda () (read port))))
    (let loop ((form (toke)))
      (or (eof-object? form)
          (begin
            (write-punily form)
            (and *newline-after-top-level-form* (newline))
            (loop (toke)))))))

(define (punify . input)
  (for-each (lambda (x)
              (cond ((string? x)
                     (let ((p (open-input-file x)))
                       (punify-one p)
                       (close-port p)))
                    ((port? x)
                     (punify-one x))
                    (else
                     (error "bad input:" x))))
            input))

(define (punify-one-in-place filename)
  (let ((bef-sz (stat:size (stat filename)))
        (aft-sz #f)
        (p (open-io-file filename))
        (forms (list #f)))
    (cond ((not (false-if-exception
                 (let loop ((form (read p)) (tp forms))
                   (or (eof-object? form)
                       (begin
                         (set-cdr! tp (list form))
                         (loop (read p) (cdr tp)))))))
           (close-port p)
           (simple-format #t "punify: ignoring ~A (error during read)\n"
                          filename))
          (else
           (seek p 0 SEEK_SET)
           (with-output-to-port p
             (lambda ()
               (for-each (lambda (form)
                           (write-punily form)
                           (and *newline-after-top-level-form* (newline)))
                         (cdr forms))))
           (set! aft-sz (seek p 0 SEEK_CUR))
           (truncate-file p)
           (close-port p)
           (simple-format #t "punify: wrote ~A (~A ~A ~A%)\n"
                          filename bef-sz aft-sz
                          (/ (inexact->exact (* 1000 (/ (- bef-sz aft-sz)
                                                        bef-sz)))
                             10))))))

(define (punify-in-place . input)
  (for-each (lambda (x)
              (define (ignoring! why)
                (simple-format #t "punify: ignoring ~A (~A)\n" x why))
              (cond ((not (file-exists? x))
                     (ignoring! "no such file"))
                    ((not (access? x W_OK))
                     (ignoring! "no permission to write"))
                    ((not (access? x R_OK))
                     (ignoring! "no permission to read"))
                    (else
                     (punify-one-in-place x))))
            input))

(define (punify/qop qop)
  (and (qop 'newline-after-top-level-form)
       (set! *newline-after-top-level-form* #t))
  (let ((in-place? (qop 'inplace))
        (victims (qop '())))
    (and in-place? (null? victims)
         (error "option `inplace' incompatible w/ stdin processing"))
    (apply (if in-place?
               punify-in-place
               punify)
           (if (null? victims)
               (list (current-input-port))
               victims))))

(define (main args)
  (HVQC-MAIN args punify/qop
             '(usage . commentary)
             '(package . "Guile")
             '(option-spec (newline-after-top-level-form (single-char #\n))
                           (inplace (single-char #\i)))))

;;; punify ends here
