#!/usr/bin/scsh \
-o package-commands-internal -o environments -o ensures-loaded -o i/o -o i/o-internal -e main -s
!#
;; breval --- Interpret bracketed scheme code
;;
;; Copyright (C)  2004  Jorgen Schaefer
;; URL: http://www.forcix.cx/computer/programs/breval.html
;;
;; 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
;; of the License, 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 program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;; Thanks a lot to Riastradh of #scheme on Freenode for the help with
;; the module system stuff!

;;; Example:

;; Hello [(list->string (reverse (string->list "dlroW")))]!
;; produces
;; Hello World!
;; This is done using this intermediate scheme program:
;; (for-each display
;;  (list "Hello "
;;        (list->string (reverse (string->list "dlroW")))
;;        "!"))
;; That is, the parts between ] and [ are just considered to be
;; strings.

(define breval-version "2.0")

(define (main args)
  (let loop ((opts (cdr args))
             (infile #f)
             (outfile #f)
             (files '())
             (modules '())
             (structures '()))
    (cond
     ((null? opts)
      (breval infile outfile files modules structures))
     ((string=? "-l" (car opts))
      (loop (cddr opts)
            infile outfile
            (cons (cadr opts) files)
            modules
            structures))
     ((string=? "-m" (car opts))
      (loop (cdddr opts)
            infile outfile
            files
            (cons (cadr opts) modules)
            (cons (string->symbol (caddr opts)) structures)))
     ((string=? "-o" (car opts))
      (loop (cddr opts) infile (cadr opts) files modules structures))
     ((string=? "--help" (car opts))
      (usage (current-output-port))
      (exit 0))
     ((string=? "--version" (car opts))
      (version)
      (exit 0))
     (else
      (loop (cdr opts) (car opts) outfile files modules structures)))))

(define (usage port)
  (display (string-append
            "Usage: breval [OPTIONS] infile\n"
            "Process the breval file INFILE.\n"
            "\n"
            "Options:\n"
            " -l FILE        Load definitions from FILE.\n"
            " -m FILE        Load FILE into the config module.\n"
            " -o FILE        Output data to FILE.\n"
            "     --help     Display this help.\n"
            "     --version  Display the version.\n")
           port))

(define (version)
  (display
   (string-append
    "breval " breval-version "\n"
    "Copyright (C) 2004 Jorgen Schäfer\n"
    "breval comes with ABSOLUTELY NO WARRANTY.\n"
    "You may redistribute copies of breval under the terms of the\n"
    "GNU General Public License.\n"
    "For more information about these matters, see the file named COPYING.\n")))

;; Read the breval data from infile, evaluate them and write the
;; result to outfile.
(define (breval infile outfile files modules structs)
  (let ((config (config-package)))
    (call-with-current-noise-port (make-null-output-port)
      (lambda ()
        (for-each (lambda (module-file)
                    (load module-file config))
                  modules)
        (eval `(define-structure breval-code (export breval-run)
                 (open scheme
                       scsh
                       srfi-1
                       tree-display
                       ,@structs)
                 (files ,@files)
                 (begin
                   (define (breval-run)
                     ,(breval-read (if infile
                                       (open-input-file infile)
                                       (current-input-port))))))
              config)
        (let ((struct (environment-ref config 'breval-code)))
          (ensure-loaded struct)
          (if outfile
              (with-output-to-file outfile
                (lambda ()
                  ((*structure-ref struct 'breval-run))))
              ((*structure-ref struct 'breval-run))))))))

;; Read a whole breval file from iport and transform it into a sexp.
(define (breval-read iport)
  (read
   (make-string-input-port
    (call-with-string-output-port
     (lambda (oport)
       (with-current-output-port oport
           (with-current-input-port iport
               (out "(tree-display (list \"")
             (breval-fsm)
             (out "))"))))))))

;; Display each element in a tree.
(eval
 '(define-structure tree-display (export tree-display)
    (open scheme)
    (begin
      (define (tree-display tree)
        (cond
         ((pair? tree)
          (tree-display (car tree))
          (tree-display (cdr tree)))
         ((null? tree)
          (if #f #f))
         (else
          (display tree))))))
 (config-package))

;;; A finite state machine.

;;; Start: -> (out "(display-recursive (list \""), Special-String
;;; 
;;; SpecialString: eof -> (out "\""), End
;;;                [ -> MaybeCode
;;;                " -> (out "\\\""), SpecialString
;;;                \ -> (out "\\\\"), SpecialString
;;;                x -> (out x), SpecialString
;;; MaybeCode: eof -> SyntaxError
;;;            [ -> (out "["), SpecialString
;;;            " -> (out "\" \""), String
;;;            x -> (out "\""), (out x), Code
;;; Code: eof -> End
;;;       #   -> (out "#"), Special
;;;       "   -> (out "\""), String
;;;       ]   -> (out "\""), SpecialString
;;;       x   -> (out x), Code
;;; Special: eof -> SyntaxError
;;;          \   -> (out "\\"), Character
;;;          x   -> (out x), Code
;;; Character: eof -> SyntaxError
;;;            x   -> (out x), Code
;;; String: eof -> SyntaxError
;;;         \ -> (out "\\"), StringEscape
;;;         " -> (out "\""), Code
;;;         x -> (out x), String
;;; StringEscape: eof -> SyntaxError
;;;               x -> (out x), String
;;; End: (out "))")

(define-syntax define-fsm
  (syntax-rules ()
    ((_ name args ...)
     (define (name) (run-fsm args ...)))))

(define-syntax run-fsm
  (syntax-rules (+ =>)
    ((_ source start-state
        (this-state + pred? => next-state
                    body ...)
        ...)
     (let loop ((state 'start-state)
                (current (source)))
       (cond
        ((and (eq? state 'this-state)
              (pred? current))
         (let ((this-state current)) body ...)
         (if 'next-state
             (loop 'next-state (source))))
        ...)))))

(define-fsm breval-fsm read-char special-string
  (special-string + eof-object? => #f
                  (out "\""))
  (special-string + open-bracket? => maybe-code
                  #f)
  (special-string + quot? => special-string
                  (out "\\\""))
  (special-string + backslash? => special-string
                  (out "\\\\"))
  (special-string + any? => special-string
                  (out special-string))

  (maybe-code     + eof-object? => #f
                  (error "Syntax error" "End-of-file on code string"))
  (maybe-code     + open-bracket? => special-string
                  (out "["))
  (maybe-code     + quot? => string
                  (out "\"\""))
  (maybe-code     + any? => code
                  (out "\"")
                  (out maybe-code))

  (code           + eof-object? => #f
                  (error "Syntax error" "End-of-file in code string"))
  (code           + hash? => special
                  (out "#"))
  (code           + quot? => string
                  (out "\""))
  (code           + close-bracket? => special-string
                  (out "\""))
  (code           + any? => code
                  (out code))

  (special        + eof-object? => #f
                  (error "Syntax error"
                         "End-of-file after hash in code string"))
  (special        + backslash? => character
                  (out "\\"))
  (special        + any? => code
                  (out special))

  (character      + eof-object? => #f
                  (error "Syntax error"
                         "End-of-file in character"))
  (character      + any? => code
                  (out character))

  (string         + eof-object? => #f
                  (error "Syntax error"
                         "End-of-file in string"))
  (string         + backslash? => string-escape
                  (out "\\"))
  (string         + quot? => code
                  (out "\""))
  (string         + any? => string
                  (out string))

  (string-escape  + eof-object? => #f
                  (error "Syntax error"
                         "End-of-file in string"))
  (string-escape  + any? => string
                  (out string-escape)))

(define (any? x)
  #t)
(define (open-bracket? x)
  (char=? x #\[))
(define (close-bracket? x)
  (char=? x #\]))
(define (quot? x)
  (char=? x #\"))
(define (backslash? x)
  (char=? x #\\))
(define (hash? x)
  (char=? x #\#))
(define (out x)
  (display x))