;     Guile Scheme "Hash-Dash" extension, part of Guile Web
;     Copyright (C) 2002 Clinton Ebadi

;     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

(define-module (web hash-dash)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 rdelim)
  #:export (___%&$@cout))
;;; This doesn't export anything, it only extends the system with the
;;; #- -# syntax.

;;; To use, do this:
;;; #-
;;; [LARGE BLOCK OF TEXT]
;;; -#
;;; Yep, #- -# echos large amounts of text to (current-output-port).
;;; The -# must be the last thing on the line

;;; read-line stuff (guile's read-line will not work for this because
;;; it only operates on file ports and this uses a soft port)

(define (++ i) (1+ i))

(define input-parse:init-buffer
  (let ((buffer (make-string 512)))
    (lambda () buffer)))

(define skip-while 
  (lambda*
   (skip-chars #:optional (port (current-input-port)))
   (do ((c (peek-char port) (peek-char port)))
       ((not (memv c skip-chars)) c)
     (read-char port))))

(define next-token 
  (lambda* 
   (prefix-skipped-chars break-chars
			 #:optional (comment "") (port (current-input-port)))
   (let* ((buffer (input-parse:init-buffer))
	  (curr-buf-len (string-length buffer)) (quantum 16))
     (let loop ((i 0) (c (skip-while prefix-skipped-chars port)))
       (cond
	 ((memq c break-chars) (substring buffer 0 i))
	 ((eof-object? c)
	  (if (memq '*eof* break-chars)
	    (substring buffer 0 i)              ; was EOF expected?
	    (parser-error port "EOF while reading a token " comment)))
	 (else
	  (if (>= i curr-buf-len)       ; make space for i-th char in buffer
	    (begin                      ; -> grow the buffer by the quantum
	      (set! buffer (string-append buffer (make-string quantum)))
	      (set! quantum curr-buf-len)
	      (set! curr-buf-len (string-length buffer))))
	  (string-set! buffer i c)
	  (read-char port)                      ; move to the next char
	  (loop (++ i) (peek-char port))))))))

(define sread-line
  (lambda* 
   (#:optional (port (current-input-port)))
   (if (eof-object? (peek-char port))
     (peek-char port)
     (let* ((line
	     (next-token '() '(#\newline #\return *eof*)
			 "reading a line" port))
	    (c (read-char port)))        ; must be either \n or \r or EOF
       (and (eq? c #\return) (eq? (peek-char port) #\newline)
	    (read-char port))                      ; skip \n that follows \r
       line))))


;;; the returned form uses this
(define (___%&$@cout . args)
  (for-each (lambda (x)
	      (if (thunk? x)
		(x)
		(display x)))
	    args ))

;;; does this work?
;;; this should output better code
(define (chunk-str line)
  (let ((start-regex (make-regexp "<[?]g"))
	(end-regex (make-regexp "[[:space:]]*[?]>")))
    (let loop ((str line)
	       (ins (list 'begin)))
      (let ((beg-m (regexp-exec start-regex str))
	    (end-m (regexp-exec end-regex str)))
	(cond ((and beg-m end-m)
	       (loop
		(substring str (cdr (vector-ref end-m 1)))
		(cons
		 (list '___%&$@cout
		  (if (not (< (car (vector-ref beg-m 1)) 2))
		    (substring str 0 (- (car (vector-ref beg-m 1)) 2))
		    "")
		  (list 'lambda '()
			(read
			 (open-input-string 
			  (substring str (cdr (vector-ref beg-m 1))
				     (- (cdr (vector-ref end-m 1)) 2))))))
		 ins)))
	      (else
	       (reverse! (cons (list 'write-line str) ins))))))))

;;; this constructs a list and returns it
;;; The list is eval'd and the output is written
(define (hash-dash char port)
  (let ((regex (make-regexp ".*-#[[:space:]]*")))
    (let loop ((line (sread-line port))
	       (ins (list 'begin)))
      (if (not (eof-object? line))
	(if (regexp-exec regex line)
	  (reverse! 
	   (cons (list 'write-line (substring line 0 
					      (- (string-length line) 2)))
		 ins ))
 	    (loop (sread-line port) 
		  (cons (chunk-str line)
			ins)))))))

(read-hash-extend #\- hash-dash)