;;-*-mode:lisp-*-
;;
;; name:    chtml.scm
;; purpose: scheme support for chunks of html. 
;;
;; Author:  George Carrette
;; Usage:   (load-chtml "filename")
;;          (write-chtml <stream> <hash-table> <chtml-template-data>)
;;          (compile-chtml input-filename output-filename)
;;
;; ENHANCEMENTS COPYRIGHT (c) 1997 BY INFORMATION ACCESS COMPANY.
;; ALL RIGHTS RESERVED. See IAC ENHANCEMENT NOTICE BELOW.
;;
;;
;; COPYRIGHT (c) 1995-1996 BY NEWS INTERNET SERVICES
;; ALL RIGHTS RESERVED.
;; Permission to use, copy, modify, distribute and sell this software
;; and its documentation for any purpose and without fee is hereby 
;; granted, provided that the above copyright notice appear in all
;; copies, that the version and WEB location comment produced by the 
;; software, which is of the following form:
;; appears in program output, and not be removed or filtered, and that 
;; both the copyright notice and this permission notice appear in
;; supporting documentation, and that the name of News Internet 
;; Services not be used in advertising or publicity pertaining to 
;; distribution of the software without specific, written prior 
;; permission.
;; 
;; THIS SOFTWARE IS MADE AVAILABLE WITHOUT CHARGE, AS-IS.  NEWS 
;; INTERNET SERVICES DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS 
;; SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 
;; FITNESS, IN NO EVENT SHALL NEWS INTERNET BE LIABLE FOR ANY SPECIAL, 
;; INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER 
;; RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION
;; OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
;;
;;
;; Data format:
;;  A compiled chunk html document is a list of elements. An element
;;  is a string, a symbol, or a (repeat-count . list-of-elements).
;;  or more optimal an array #(repeat-count ... elements)
;;
;; Hash table:
;;  provided key -> value mapping. Value semantics:
;;   string/number ... printed representation used.
;;   list ............ car printed. list popped if length > 1.
;;   procedure ....... called to return string to use.
;;
;; Note: This is not a real parser. Just a line-oriented kludge,
;;       with hacks to allow leftover markup at the end
;;       of comments lines because html editors such as
;;       Microsoft Frontpage are leaving that kind
;;       of thing.

;; 
;; IAC ENHANCEMENT NOTICE.
;; The code was getting too ugly when trying to hack it to parse
;; output of Microsoft Frontpage, so I started again from
;; scratch with a new theory of parsing. There is now:
;;  1. a readline-stream with pushback.
;;  2. a read data function that recognizes comments.
;;  3. a single parser function.
;;
;; Note that I was intrigued with writing a siod extension
;; to utilize the code provided by
;; http://www.w3.org/team/WWW/MarkUp/SGML/sgml-lex/sgml-lex.html
;; however it looked like it would be in fact just as easy to
;; code to "the real thing" an sgml parser such as sp,
;; referenced in the chtml.html document. 
;; For compatibility with existing templates I decided not
;; punt the comments and go with marked sections.
;; Also note that the comment syntax recognized is oversimplified
;; from full conforming sgml.
;; The only thing I kept from the original Newscorp code
;; are the comments about the public interface and the functions
;; optimize-chtml and interface-line. The new code took
;; about 3 hours work, and it compatible with the old
;; code except for the fact that whitespace around
;; the special comments is handled in a slightly different
;; manner.

(define *chtml-calling-card*
  "<!-- Filtered by http://people.delphi.com/gjc/chtml.html S1.6 -->")

(define *chtml-id*
  "$Id: chtml.scm,v 1.16 1998/06/19 15:27:23 gjc Exp $"
  )

(define *chtml-interface* nil)
(define *undefined-object-handler* 'error)

(define (make-gets-stream file)
  (let ((leftover nil)
	(line-number 0))
    (lambda (op arg)
      (let ((data nil))
	(cond ((eq? op 'gets)
	       (cond ((not leftover)
		      (set! data (gets file))
		      (and data (set! line-number (+ 1 line-number)))
		      data)
		     ('else
		      (set! data leftover)
		      (set! leftover nil)
		      data)))
	      ((eq? op 'ungets)
	       (set! leftover arg))
	      ((eq? op 'line-number)
	       line-number)
	      ((eq? op 'error)
	       (apply error
		      (cons (string-append
			     "On line number "
			     (number->string line-number)
			     ", "
			     (or (car arg) ""))
			    (cdr arg))))
	      ('else
	       (error "unknown operation" op)))))))

(define (parse-error s . args)
  (s 'error args))

(define (load-chtml filename)
  (let ((file (fopen filename "r"))
	(result nil))
    (set! *chtml-interface* nil)
    (set! result (optimize-chtml (parse-chtml (make-gets-stream file)
					      nil)))
    (fclose file)
    result))

(define (show-object s x)
  (writes nil "On line number "
	  (s 'line-number nil) " : ")
  (print x))

(define (lookup-repeat-count s k)
  (or (cdr (assoc k *chtml-interface*))
      (cond ((eq? *undefined-object-handler* 'error)
	     (parse-error s "not defined in interface" k))
	    ((eq? *undefined-object-handler* 'warn)
	     (writes nil "On line number "
		     (s 'line-number nil) " : "
		     "not defined in interface " k "\n")
	     (intern k))
	    ((intern k)))))

(define (parse-chtml s repeat-count)
  (let ((x nil)
	(result (cond ((not repeat-count)
		       (list 1))
		      ((not (caddr repeat-count))
		       (list (car repeat-count)))
		      ('else
		       (list 0 (car repeat-count)))))
	(tail nil)
	(flag t))
    (set! tail result)
    (while (and (pair? tail) (cdr tail))
      (set! tail (cdr tail)))
    (while (and flag (set! x (read-chtml-data s)))
      (cond ((not (pair? x))
	     (set-cdr! tail (interface-line *chtml-interface*
					    x))
	     (set! tail (last tail)))
	    ((eq? 'INTERFACE (car x))
	     (mapcar add-chtml-interface (cdr x))
	     (set-cdr! tail (list *chtml-calling-card*))
	     (set! tail (cdr tail)))
	    ((memq (car x) '(BEGIN DEF-START))
	     (if (>= (verbose) 2)
		 (show-object s x))
	     (set-cdr! tail
		       (list (parse-chtml
			      s
			      (list (lookup-repeat-count s (cadr x))
				    (cadr x)
				    (eq? (car x) 'DEF-START)))))
	     (set! tail (cdr tail)))
	    ((memq (car x) '(END DEF-END))
	     (if (>= (verbose) 2)
		 (show-object s x))
	     (cond ((not repeat-count)
		    (parse-error s "unbalanced END-REPEATING-OBJECT"))
		   ((not (cadr x)))
		   ((not (equal? (cadr x) (cadr repeat-count)))
		    (parse-error s "unbalanced END-REPEATING-OBJECT"
				 (cadr repeat-count))))
	     (set! flag nil))
	    ('else
	     ;; since comments may have object references
	     ;; in them for the purpose of side effects
	     ;; we must process them as if they were text.
	     (set-cdr! tail (list "<!--"))
	     (set! tail (cdr tail))
	     (set-cdr! tail (apply append
				   (mapcar (lambda (e)
					     (interface-line
					      *chtml-interface*
					      e))
					   x)))
	     (set! tail (last tail))
	     (set-cdr! tail (list "-->"))
	     (set! tail (cdr tail)))))
    (and flag repeat-count
	 (parse-error s "missing object end"
		      (cadr repeat-count)))
    result))

(define (interface-lines-from-file filename)
  (if (> (verbose) 1)
      (writes nil "Included file   : " filename "\n"))
  (let ((f (fopen filename "r"))
	(result nil)
	(line nil))
    (while (set! line (readline f))
      (set! result (cons line result)))
    (fclose f)
    (nreverse result)))

(define (add-chtml-interface line)
  (let ((data (mapcar string-trim
		      (strbreakup (string-trim line)
				  "::"))))
    (cond ((and (pair? data) (> (length (car data)) 0))
	   (set! *chtml-interface*
		 (append *chtml-interface*
			 (list (cons (or (cadr data) (car data))
				     (intern (car data)))))))
	  ((and (pair? data) (= 0 (length (car data)))
		(= 3 (length data))
		(equal? "include" (string-downcase (nth 1 data))))
	   (mapcar add-chtml-interface
		   (interface-lines-from-file (nth 2 data)))))))
	  

(define *chtml-specials* '(("CHTML-INTERFACE" INTERFACE)
			   ("BEGIN-REPEATING-OBJECT-" BEGIN)
			   ("END-REPEATING-OBJECT-" END)
			   ("END-REPEATING-OBJECT" END)
			   ("REPEAT-" BEGIN)
			   ("/REPEAT-" END)
			   ("/REPEAT" END)
			   ("BEGIN-OBJECT-" DEF-START)
			   ("END-OBJECT-" DEF-END)
			   ("END-OBJECT" DEF-END)
			   ("OBJECT-" DEF-START)
			   ("/OBJECT-" DEF-END)
			   ("/OBJECT" DEF-END)))

(define (chtml-special? str l)
  (cond ((null? l)
	 nil)
	((substring-equal? (caar l) str 0 (length (caar l)))
	 (cond ((> (length str) (length (caar l)))
		(list (cadr (car l))
		      (substring str (length (caar l)))))
	       ('else
		(list (cadr (car l))))))
	('else
	 (chtml-special? str (cdr l)))))
	 
  
(define (read-chtml-data s)
  (let ((line (s 'gets nil)))
    (cond ((not line)
	   nil)
	  ((not (string-search "<!--" line))
	   line)
	  ('else
	   (let ((j (string-search "<!--" line)))
	     (cond ((= j 0)
		    (let ((result nil)
			  (special nil))
		      (set! line (substring line 4))
		      (while (not (set! j (string-search "-->" line)))
			(set! result (cons line result))
			(or (set! line (s 'gets nil))
			    (parse-error s "end of file inside comment")))
		      (set! result (cons (substring line 0 j) result))
		      (set! result (nreverse result))
		      (set! line (substring line (+ j 3)))
		      (cond ((set! special (chtml-special?
					    (car result)
					    *chtml-specials*))
			     (cond ((and (not (eq? (car special)
						   'INTERFACE))
					 (member line 
						 '("\n" "\r\n"))))
				   ('else
				    (s 'ungets line)))
			     (nconc special (cdr result)))
			    ('else
			     (s 'ungets line)
			     result))))
		   ('else
		    (s 'ungets (substring line j))
		    (substring line 0 j))))))))

(define (optimize-chtml data)
  (if (pair? data)
      (let ((n (length data))
	    (a nil)
	    (j 0))
	(set! a (cons-array n))
	(while (< j n)
	  (aset a j (optimize-chtml (nth j data)))
	  (set! j (+ 1 j)))
	a)
    data))

(define (interface-line interface line)
  (if (not interface)
      (list line)
    (let ((j (string-search (caar interface) line)))
      (if j
	  (append (interface-line (cdr interface) (substring line 0 j))
		  (list (cdar interface))
		  (interface-line
		   interface
		   (substring line
			      (+ j
				 (length (caar interface))))))
	(interface-line (cdr interface) line)))))


;; swrite is a c-coded subr in SIOD.
(define write-chtml swrite)

(define (compile-chtml inf outf)
  (fast-save outf
	     (list (load-chtml inf))
	     t
	     "# CHTML -*-parser:fasl-*-\n"))

(define (chtml-object name obj)
  (cond ((or (number? obj) (symbol? obj) (string? obj))
	 nil)
	((eq? name (aref obj 0))
	 obj)
	('else
	 (let ((j 0)
	       (result nil))
	   (while (and (not result) (< j (length obj)))
	     (set! result (chtml-object name (aref obj j)))
	     (set! j (+ 1 j)))
	   result))))