;
;========================================================================
;			HTML generation template

(require-extension srfi-1)
(require-extension srfi-13)
(require-extension sxml-transforms)
(require-extension doctype)
(require-extension html-form)

(define nl (list->string (list #\newline)))

(define lookup-def 
  (lambda (k lst . rest)
    (let-optionals rest ((default #f))
      (alist-ref k lst eq? default))))


(define lookup-field 
  (lambda (k lst . rest)
    (let-optionals rest ((default #f))
      (let loop ((lst lst))
	(if (null? lst) default
	    (let ((elm (car lst)))
	      (match elm
		     ((s . _)  (if (eq? s k) (cdr elm)  (loop (cdr lst))))
		     (else  (loop (cdr lst))))))))))

(define (s+ . rest) 
  (apply string-append (map ->string rest)))


(define (make-schedule def)
  (let* ((evs    (filter-map (lambda (x) (and (eq? 'event (car x)) (cdr x))) def))
	 (brief  (lookup-def 'brief def)))
    `(div (@ (class ,(if brief 'brief-schedule 'schedule)))
	  ,@(map (lambda (ev) 
		   (let ((date  (lookup-def 'date ev))
			 (time  (lookup-def 'time ev))
			 (desc  (or (lookup-def 'desc ev)
				    (lookup-def 'description ev))))
		     `(dl (@ (class event)) 
			    ,(if date  `(dt (@ (class date)) ,date) "")
			    ,(if time  `(dt (@ (class time)) ,time) "")
			    ,(if desc  `(dd (@ (class desc)) ,desc) ""))))
		 evs))))

(define (pid parent id)
  (let ((parent (and parent (if (string? parent) parent (symbol->string parent))))
	(id     (if (string? id) id (symbol->string id))))
    (if parent (string-concatenate (list parent "_" id)) id)))


(define (make-navbar head-parms)
  (let ((links (lookup-def 'Links head-parms '())))
    (and (pair? links)
	 `(div (@ (id "navbar"))
	       (ul . ,(map (lambda (x) 
			     (match x ((name val . rest)  
				       (let ((label (or  (lookup-def 'label rest) name)))
					 `(li (a (@ (href ,val)) ,label)))))) links))
	       (hr)))))


(define (make-header head-parms)
  `(head
    ,nl (title ,(lookup-def 'title head-parms))
    ,nl (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
    ,nl (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
    ,nl ,(let ((style  (lookup-def 'style head-parms))
	       (print-style  (lookup-def 'print-style head-parms)))
	   (list (if style `(link (@ (rel "stylesheet") (type "text/css") (href ,style))) '())
		 (if print-style `(link (@ (rel "stylesheet") (type "text/css") 
					   (media "print")  (href ,print-style))) '())))
    ,nl
    ,(zip
      (map
       (lambda (key)
	 (let ((val (lookup-def key head-parms )))
	   (and val
		`(meta (@ (name ,(symbol->string key)) (content ,val))))))
       '(description AuthorAddress keywords
		     Date-Revision-yyyymmdd Date-Creation-yyyymmdd))
      (circular-list nl))
    ,nl
    ,(let ((links (lookup-def 'Links head-parms '())))
      (and (pair? links)
           (map
            (lambda (link-key)
              (let ((val (lookup-def link-key links)))
                (and val
                  (let ((val (if (not (pair? val)) (list val) val)))
                     `(link (@ (rel ,(symbol->string link-key))
                               (href ,(car val))
                               ,@(cdr val)))))))
            '(start contents prev next))))))


(define (make-footer head-parms)
  `((br)
    (div  (@ (id "footer"))
     (hr)
     (h3 "Last updated "
	 ,(let* ((date-revised (car (lookup-def 'Date-Revision-yyyymmdd head-parms)))
		 (year  (string->number (string-copy date-revised 0 4)))
		 (month (string->number (string-copy date-revised 4 6)))
		 (day   (string->number (string-copy date-revised 6 8)))
		 (month-name
		  (vector-ref
		   '#("January" "February" "March" "April" "May" "June"
		      "July"   "August" "September" "October" "November"
		      "December")
		   (- month 1))))
	    (list month-name " " day ", " year))
	 ,(let ((revision (car (lookup-def 'Revision head-parms))))
	    (if revision (string-concatenate (list " (Revision " revision ") ")) "")))
     ,(let ((links (lookup-def 'Links head-parms '())))
	(and (pair? links)
	     (let ((home (lookup-def 'home links)))
	       (and home
		    `(p "This site's top page is "
			(a (@ (href ,home)) (strong ,home)))))))
     (div 
      (address ,(lookup-def 'AuthorAddress head-parms))
     (br)
     "Your comments, problem reports, questions are very welcome!")
     (p (font (@ (size "-2")) "Converted from SXML by SXML->HTML"))
     ,(let ((rcs-id (lookup-def 'rcs-id head-parms)))
	(and rcs-id `(h4 ,rcs-id))))))
  

(define (generate-HTML Content)
  (let*
      ;; Universal transformation rules. Work for every HTML,
      ;; present and future
   ((universal-conversion-rules
     `((@
	((*default*       ;; local override for attributes
	  . ,(lambda (attr-key . value) (enattr attr-key value))))
	. ,(lambda (trigger . value) (cons '@ value)))
       (*default* . 
	 ,(let ((with-nl	;; Block-level HTML elements:
				;; We insert a NL before them.
				;; No NL is inserted before or after an
				;; inline element.
		  '(br 			;; BR is technically inline, but we
					;; treat it as block
		     p div hr iframe
		     h1 h2 h3 h3 h5 h6
		     dl ul ol li dt dd pre
		     table tr th td
		     center blockquote form
		     address body thead tfoot tbody col colgroup)))
	    (lambda (tag . elems)
	       (let ((nl? (and (memq tag with-nl) #\newline)))
		 (if (and (pair? elems) (pair? (car elems))
		       (eq? '@ (caar elems)))
		   (list nl? #\< tag (cdar elems) #\>
		     (and (pair? (cdr elems))
		       (list (cdr elems) "</" tag #\> nl?)))
		   (list nl? #\< tag #\> 
		     (and (pair? elems) (list elems "</" tag #\> nl?))
		     ))))))
       (*text* . ,(lambda (trigger str) 
		    (if (string? str) (string->goodHTML str) str)))
       (n_		;; a non-breaking space
	. ,(lambda (tag . elems)
	     (list "&nbsp;" elems)))))

		;; Transformation rules to drop out everything but the
		;; 'Header' node
    (search-Header-rules
     `((Header
	*preorder*
	. ,(lambda (tag . elems) (cons tag elems)))
       (*default*
	. ,(lambda (attr-key . elems)
	     (let loop ((elems elems))
	       (cond
		((null? elems) '())
		((not (pair? (car elems))) (loop (cdr elems)))
		((eq? 'Header (caar elems)) (car elems))
		(else (loop (cdr elems)))))))
       (*text* . ,(lambda (trigger str) '()))))
    )

   (let ((header-parms  (lookup-def 'Header (list (post-order Content search-Header-rules)))))
     (SRV:send-reply
      (pre-post-order Content
		      `(
			,@universal-conversion-rules

			(html:begin
			 . ,(lambda (tag . elems)
			      (let ((embedded?    (lookup-def 'Embedded header-parms)))
				(if embedded? elems
				    (list
				     "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\""
				     nl 
				     "\"http://www.w3.org/TR/html4/loose.dtd\">" nl
				     "<html>" nl
				     elems
				     "</html>" nl)))))
			
			(Header
			 *macro*
			 . ,(lambda (tag . headers)
			      (let ((embedded?    (lookup-def 'Embedded header-parms)))
				(if embedded?  (list)  (make-header headers)))))

			(navbar			; Find the Header in the Content
			 . ,(lambda (tag)		; and create the navigation bar
			      (let ((header-parms
				     (lookup-def 'Header
						 (list (post-order Content
								   search-Header-rules))
						 )))
				(post-order (make-navbar header-parms)
					    universal-conversion-rules))))
			
			(body
			 . ,(lambda (tag . elems)
			      (list "<body>" nl elems "</body>")))

			(page-content *macro*
				      . ,(lambda (tag . elems)
					   `(div (@ (id "content")) ,nl ,elems)))

			(footer			;; Find the Header in the Content
			 . ,(lambda (tag)		;; and create the footer of the page
			      (post-order (make-footer header-parms)
					  universal-conversion-rules)))
			

			(page-title *macro*	;; Find the Header in the Content
				    . ,(lambda (tag)		;; and create the page title rule
					 `(div (@ (id "header")) 
					       (h1 ,(lookup-def 'title header-parms))
					       ,nl
					       (h2 ,(lookup-def 'subtitle header-parms)))))


			(abstract			;; The abstract of the document
			 ((Revision
			   . ,(lambda (tag)	;; Find the Header in the Content
				;; and create the revision record
				(list "<strong>Revision "
				      (lookup-def 'Revision header-parms)
				      "</strong>. ")))
			  
			  (keywords . ,(lambda (tag) '()))
			  )
			 . ,(lambda (tag . abstract-body)
			      (list "<div>" abstract-body "</div>" nl))
			 )
			
			(Section-Separator	;; (Section-Separator level "content ...")
			 *macro*
			 . ,(lambda (tag level . elems)
			      `((n_) 
				(,(string->symbol (string-append "h" (number->string level)))
				 (hr)))))

			(Section-Separator*	;; (Section-Separator level "content ...")
			 *macro*
			 . ,(lambda (tag level . elems)
			      `((n_) 
				(,(string->symbol (string-append "h" (number->string level)))
				 (hr)))))

			(Section	;; (Section level "content ...")
			 *macro*
			 . ,(lambda (tag level head-word . elems)
			      `((n_) (a (@ (name ,head-word)) (n_))
				(,(string->symbol (string-append "h" (number->string level)))
				 ,head-word ,elems))))

			(Section*	;; (Section* level "content ...")
			 *macro*
			 . ,(lambda (tag level head-word . elems)
			      `((n_) (a (@ (name ,head-word)) (n_))
				(,(string->symbol (string-append "h" (number->string level)))
				 ,head-word ,elems))))

			(References	;; (References bibitem ...)
			 *macro*
			 . ,(lambda (tag . bib-items)
			      `((Section 2 "References") ,@bib-items)))
			

			(TOC	;; Re-scan the Content for "Section" tags and generate
			 . ,(lambda (tag)	;; the Table of contents
			      (let ((sections
				     (pre-post-order Content
						     `(
						       (Section-Separator;; (Section-Separator level)
							((*text* . ,(lambda (tag str) str)))
							. ,(lambda (tag level) (list "<li><p><hr></p>" nl ))
							)
						       (Section	;; (Section level "content ...")
							((*text* . ,(lambda (tag str) str)))
							. ,(lambda (tag level head-word . elems)
							     (list "<li><a href=\"#" head-word
								   "\">" head-word elems "</a>" nl ))
							)
						       (References ;; (References bibitem ...)
							. ,(lambda (tag . bib-items)
							     (let ((head-word "References"))
							       (list "<li><a href=\"#" head-word
								     "\">" head-word "</a>" nl ))))
						       (*default*
							. ,(lambda (tag . elems) elems))

						       (*text* . ,(lambda (trigger str) (list)))))))
					;(write sections ##stderr)
				(list "<div id=\"toc\">" 
				      "<h3>In this page:</h3> "
				      "<ul>"
				      sections 
				      "</ul></div>" nl))))


			(verbatim	;; set off pieces of code: one or several lines
			 *macro*
			 . ,(lambda (tag . lines)
			      (cons 'pre
				    (map (lambda (line) (list "     " line nl))
					 lines))))

			(bibitem
			 *macro*
			 . ,(lambda (tag label key . text)
			      `(p (a (@ (name ,key)) "[" ,label "] ") ,text)))

			(pubitem
			 *macro*
			 . ,(lambda (tag key authors title where)
			      `(p (a (@ (name ,key)) ) ,authors ": " (i ,title) " " ,where)))

			(pubitem*
			 *macro*
			 . ,(lambda (tag key authors title where)
			      `((a (@ (name ,key)) ) ,authors ": " (i ,title) " " ,where)))

			(cite		;; ought to locate the label and use the label!
			 *macro*
			 . ,(lambda (tag key author title)
			      `(p ,author ": " (br) 
				  (a (@ (href "abstracts.html#" ,key)) ,title))))


			(url *macro* . ,(lambda (tag href . contents)
					  `(a (@ (href ,href))
					      ,(if (pair? contents)
						   contents
						   href))))

			(formvar *macro* . 
			      ,(lambda (tag . elems)
				 (map html-form elems)))
	 
			(schedule *macro* . 
				 ,(lambda (tag . elems)
				    (list (make-schedule elems) nl)))
	 

			(bio *macro*
			     . ,(lambda (tag  id . elems)
				  (list (make-bio id elems) nl)))



			(sexp		;; S-expression constructor
			 *macro*
			 . ,(lambda (tag . terms)
			      `((code (strong "(") " ") ,(list-intersperse terms " ")
				(code " " (strong ")")))))

			(sexp-cons		;; S-expression constructor, like cons
			 *macro*
			 . ,(lambda (tag pcar pcdr)
			      `((code (strong "(") " ") ,pcar (code (strong " . ")) ,pcdr
				(code " " (strong ")")))))

			(sset		;; A tagged unordered S-expression (i.e., a set)
			 *macro*
			 . ,(lambda (tag set-tag . terms)
			      `((code (strong "{")) ,(list-intersperse
						      (cons set-tag terms) " ")
				(code " " (strong "}")))))))))))