;     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 rdelim))
;;; 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).

; I know, not very nice...but it works
(define (parser-error . args)
  (apply error args))

(load-from-path "web/internal/myenv.scm")
(load-from-path "web/internal/input-parse.scm")

(define start-regexp (make-regexp "<[?]guile"))
(define end-regexp (make-regexp "^[?]>"))

(define (my-escape-string str)
  (let loop ((old-string (string->list str))
	     (new-string (list)))
    (cond ((null? old-string)
	   (list->string (reverse! new-string)))
	  (else
	   (if (char=? (car old-string) #\")
	     (loop (cdr old-string)
		   (cons* (car old-string) #\\ new-string))
	     (loop (cdr old-string)
		   (cons (car old-string) new-string)))))))
    

;;; the returned form uses this
(define ___%&$@cout cout)

(define space-chars '(#\space #\tab #\newline #\return))

;;; Copied and modified from input-parse.scm
(define-opt (skip-while skip-chars (optional (port (current-input-port))))
  (let read-loop ((skipped (list))
		  (c (peek-char port)))
    (if (not (memv c skip-chars))
      (cons c (reverse! skipped))
      (read-loop (cons (read-char port) skipped)
		 (peek-char port)))))
;;; Rewrite next-token to return list with token and whitespace before
;;; it. Then rewrite hash-dash to use this to preserve whitespace. 

(define (my-next-token port)
  (next-token space-chars space-chars
	      "Unterminated #- -# block?"
	      port))

(define (pi-helper port)
  (let pi-loop ((str "(lambda () ")
		(token (my-next-token port)))
    (let ((matched (regexp-exec end-regexp token)))
    (if matched
      (read 
       (open-input-string
	(string-append str "(display \"" 
		       (my-escape-string
			(substring token
				   (cdr (vector-ref matched 1)) 
				   (string-length token))) "\"))")))
      (pi-loop (string-append str " " token)
	       (my-next-token port))))))

;;; this function makes me cry, but it works
; (define (hash-dash char port)
;   (let loop ((exp (list '___%&$@cout)))
;     (let* ((token (my-next-token port))
; 	   (matched (regexp-exec start-regexp token)))
;       (cond ((string=? token "-#")
; 	     (reverse! exp))
; 	    (matched
; 	     (loop (cons* " " 
; 			  (pi-helper port)
; 			  (substring token 0 (car (vector-ref matched 1)))
; 			  exp)))
; 	    (else
; 	     (loop (cons (string-append token " ") exp)))))))

(define (hash-dash char port)
  (let build-string ((string-list (list)))
    (let ((current-string
	   (read-delimited "-" port 'split)))
      (cond ((eof-object? (cdr current-string))
	     (error "End of File in #- -# block"))
	    ((char=? (peek-char port) #\#)
	     (read-char port)
	     (apply string-append (reverse!
				   (cons
				    (car current-string)
				    string-list))))
	    (else
	     (build-string (cons* (string (cdr current-string))
				  (car current-string)
				  string-list)))))))

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