#!r6rs
;; Copyright 2009 Derick Eddington.  My MIT-style license is in the file named
;; LICENSE from the original collection this file is distributed with.

(library (yuni lib ssax private to-html-ext)
  (export
    make-header
    make-navbar
    make-footer
    universal-conversion-rules
    universal-protected-rules
    alist-conv-rules
    find-Header
    generic-web-rules)
  (import
    (except (rnrs) error)
    (rnrs r5rs)
    (except (srfi :13 strings) 
            string-copy string-for-each string->list
            string-upcase string-downcase string-titlecase string-hash)
    (yuni lib ssax private to-html)
    (yuni lib ssax tree-trans)
    (yuni lib ssax private error)
    (yuni lib ssax private output)
    (yuni lib ssax private misc)
    (yuni lib ssax private util))
  
  (define (OS:file-length filename)
    (if (file-exists? filename) 1 0))
  
  (define error (make-errorer "(wak ssax private to-html-ext)"))

;	   HTML Authoring in SXML for my personal Web pages
;
; The present file defines several functions and higher-order
; SXML "tags" that are used to compose HTML pages on my web site.
; In LaTeX terms, this file is similar to article.cls.
;
; See http://pobox.com/~oleg/ftp/Scheme/xml.html#XML-authoring
; for more examples and explanation.
;
; IMPORT
; Approporiate Prelude: myenv.scm or myenv-bigloo.scm
; srfi-13-local.scm or the appropriate native implementation of SRFI-13
; util.scm
; SXML-tree-trans.scm
; SXML-to-HTML.scm
; OS:file-length, unless it is included into the core system
;   (see myenv-bigloo.scm for example)
;
; $Id: SXML-to-HTML-ext.scm,v 1.8 2004/07/07 16:02:30 sperber Exp $


; Look up a value associated with a symbolic key in alist (key value)
; and return (value)
; If failed, write a warning and return the default value, if non-#f
; A lookup failure is fatal if the default value is #f
(define (lookup-def key alist default-value)
  (cond
   ((assq key alist) => cdr)
   (default-value
     (cerr "Failed to find a binding for a key " key
	   ". The default value " default-value " will be used")
     default-value)
   (else
    (error "Failed to find a binding for a key " key))))


; skip the lst trough the first significant element
; return the tail of lst such that (car result) is significant
; Insignificant elems are '(), #f, and lists made of them
; If all of the list is insignificant, return #f
(define (signif-tail lst)
  (define (signif? obj)
    (and (not (null? obj)) obj
	 (if (pair? obj)
	     (or (signif? (car obj))
		 (signif? (cdr obj)))
	     obj)))
  (and (signif? lst)
       (assert (pair? lst))
       (if (signif? (car lst)) lst
	   (signif-tail (cdr lst)))))

; Procedure make-header HEAD-PARMS
; Create the 'head' SXML/HTML tag. HEAD-PARMS is an assoc list of
; (h-key h-value), where h-value is a typically string;
; h-key is a symbol:
; title, description, AuthorAddress, keywords,
; Date-Revision-yyyymmdd, Date-Creation-yyyymmdd,
; long-title
; One of the h-key can be Links.
; In that case, h-value is a list of
;	(l-key l-href (attr value) ...)
; where l-key is one of the following:
;	start, contents, prev, next, top, home

(define (make-header head-parms)
  `(head
    (title ,(car (lookup-def 'title head-parms #f)))
    ,(map
      (lambda (key)
	(let ((val (car (lookup-def key head-parms '(#f)))))
	  (and val
	       `(meta (^ (name ,(symbol->string key)) (content ,val))))))
      '(description AuthorAddress keywords
	Date-Revision-yyyymmdd Date-Creation-yyyymmdd))
    ,(let ((links (lookup-def 'Links head-parms '())))
      (and (pair? links)
	   (map
	    (lambda (link-key)
	      (let ((val (lookup-def link-key links '())))
		(and (pair? val)
		     `(link (^ (rel ,(symbol->string link-key))
			       (href ,(car val))
			       ,@(cdr val))))))
	    '(start contents prev next)))))
)

; Create a navigational bar. The argument head-parms is the same
; as the one passed to make-header. We're only concerned with the
; h-value Links
(define (make-navbar head-parms)
  (let ((links (lookup-def 'Links head-parms '()))
	(nav-labels '((prev . "previous")
		      (next . "next")
		      (contents . "contents")
		      (top . "top"))))
    (and (pair? links)
      `(div (^ (align "center") (class "navbar"))
	 ,(let loop ((nav-labels nav-labels) (first? #t))
	    (if (null? nav-labels) '()
		(let ((val (car
			    (lookup-def (caar nav-labels) links '(#f)))))
		  (if (not val)
		      (loop (cdr nav-labels) first?)
		      (cons
		       (list " " (if first? #f '(n_)) " "
			     `(a (^ (href ,val)) ,(cdar nav-labels)))
		       (loop (cdr nav-labels) #f))))))
	 (hr)))
))
			      

; Create a footer. The argument head-parms is the same
; as passed to make-header.
(define (make-footer head-parms)
  `((br)
    (div (hr))
    (h3 "Last updated "
	,(let* ((date-revised
		 (car (lookup-def 'Date-Revision-yyyymmdd head-parms #f)))
		(year (string->integer date-revised 0 4))
		(month (string->integer date-revised 4 6))
		(day   (string->integer date-revised 6 8))
		(month-name
		 (vector-ref
		  '#("January" "February" "March" "April" "May" "June"
		    "July"   "August" "September" "October" "November"
		    "December")
		  (dec month))))
	   (list month-name " " day ", " year)))
    ,(let ((links (lookup-def 'Links head-parms '())))
       (and (pair? links)
	    (let ((home (car (lookup-def 'home links '(#f)))))
	      (and home
		   `(p "This site's top page is "
		       (a (^ (href ,home)) (strong ,home)))))))
    (div 
      (address "oleg-at-pobox.com or oleg-at-acm.org or oleg-at-computer.org"
       (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 (pair? rcs-id)
	    `(h4 ,rcs-id)))
    ))

; Bindings for the post-order function, which traverses the SXML tree
; and converts it to a tree of fragments

; The universal transformation from SXML to HTML. The following rules
; work for every HTML, present and future
(define universal-conversion-rules
  `((^
      ((*DEFAULT*       ; local override for attributes
        . ,(lambda (attr-key . value) (enattr attr-key value))))
      . ,(lambda (trigger . value) (cons '^ value)))
    (*DEFAULT* . ,(lambda (tag . elems) (entag tag elems)))
    (*TEXT* . ,(lambda (trigger str) 
		 (if (string? str) (string->goodHTML str) str)))
    (n_		; a non-breaking space
     . ,(lambda (tag . elems)
	  (cons " " elems)))))

; A variation of universal-conversion-rules which keeps '<', '>', '&'
; and similar characters intact. The universal-protected-rules are
; useful when the tree of fragments has to be traversed one more time.
(define universal-protected-rules
  `((^
      ((*DEFAULT*       ; local override for attributes
        . ,(lambda (attr-key . value) (enattr attr-key value))))
      . ,(lambda (trigger . value) (cons '^ value)))
    (*DEFAULT* . ,(lambda (tag . elems) (entag tag elems)))
    (*TEXT* . ,(lambda (trigger str) 
		 str))
    (n_		; a non-breaking space
     . ,(lambda (tag . elems)
	  (cons "&nbsp;" elems)))))

; The following rules define the identity transformation
(define alist-conv-rules
  `((*DEFAULT* . ,(lambda (tag . elems) (cons tag elems)))
    (*TEXT* . ,(lambda (trigger str) str))))


; Find the 'Header' node within the 'Content' SXML expression.
; Currently this query is executed via a transformation, with
; rules that drop out everything but the 'Header' node.
; We use the _breadth-first_ traversal of the Content tree.
(define (find-Header Content)
  (letrec 
    ((search-rules
	 `((*DEFAULT*
	    *PREORDER*
	    . ,(lambda (tag . elems)
		 (let loop ((elems elems) (worklist '()))
		   (cond
		    ((null? elems) 
		     (if (null? worklist) '()
			 (pre-post-order worklist search-rules)))
		    ((not (pair? (car elems))) (loop (cdr elems) worklist))
		    ((eq? 'Header (caar elems)) (car elems)) ; found
		    (else (loop (cdr elems) (cons (car elems) worklist)))))))
	   )))
    (lookup-def 'Header
		(list (pre-post-order Content search-rules))
		#f)))


; Transformation rules that define a number of higher-order tags,
; which give "style" to all my pages.
; Some of these rules require a pre-post-order iterator
; See xml.scm or any other of my web page master files for an example
; of using these stylesheet rules

(define (generic-web-rules Content additional-rules)
  (append
   additional-rules
   universal-conversion-rules
   `((html:begin 
      . ,(lambda (tag . 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
      *PREORDER*
      . ,(lambda (tag . headers)
	   (post-order (make-header headers) universal-conversion-rules)
	   ))

     (body
      . ,(lambda (tag . elems)
	   (list "<body bgcolor=\"#FFFFFF\">" nl elems "</body>")))

     (navbar			; Find the Header in the Content
      . ,(lambda (tag)		; and create the navigation bar
	   (let ((header-parms (find-Header Content)))
	     (post-order (make-navbar header-parms)
			 universal-conversion-rules))))
     
     (footer			; Find the Header in the Content
      . ,(lambda (tag)		; and create the footer of the page
	   (let ((header-parms (find-Header Content)))
	     (post-order (make-footer header-parms)
			 universal-conversion-rules))))
     
     (page-title		; Find the Header in the Content
      . ,(lambda (tag)		; and create the page title rule
	   (let ((header-parms (find-Header Content)))
	     (list "<h1 align=center>" 
		   (lookup-def 'long-title header-parms #f) "</h1>" nl))))


     (Section	; (Section level "content ...")
      . ,(lambda (tag level head-word . elems)
	   (list "<br>&nbsp;<a name=\"" head-word "\">&nbsp;</a>" nl
		 "<h" level ">"  head-word elems "</h" level ">" nl)))

     (TOC	; Re-scan the Content for "Section" tags and generate
      . ,(lambda (tag)	; the Hierarchical Table of contents
	   (let ((sections
		  (post-order Content
		    `((Section	; (Section level "content ...")
		       ((*TEXT* . ,(lambda (tag str) str)))
		       . ,(lambda (tag level head-word . elems)
			    (vector level
				    (list "<li><a href=\"#" head-word
					  "\">" head-word elems "</a>" nl))))
		      (*DEFAULT*
		       . ,(lambda (attr-key . elems) elems))
		      (*TEXT* . ,(lambda (trigger str) '()))))))
	     ;(cerr sections)
	     (list "<div>"
	      (let loop ((curr-level 1) (sections sections))
	       (cond
		((null? sections)
		 (let fill ((curr-level curr-level))
		   (if (> curr-level 1)
		       (cons "</ol>" (fill (dec curr-level)))
		       '())))
		((null? (car sections)) (loop curr-level (cdr sections)))
		((pair? (car sections)) (loop curr-level
					      (append (car sections)
						      (cdr sections))))
		((vector? (car sections))
		 (let ((new-level (vector-ref (car sections) 0)))
		   (cond
		    ((= new-level curr-level)
		     (cons (vector-ref (car sections) 1)
			   (loop curr-level (cdr sections))))
		    ((= (inc new-level) curr-level)
		     (cons "</ol>"
			   (cons (vector-ref (car sections) 1)
				 (loop new-level (cdr sections)))))
		    ((= new-level (inc curr-level))
		     (cons nl (cons "<ol>"
			   (cons (vector-ref (car sections) 1)
				 (loop new-level (cdr sections))))))
		    (else 
		     (error "inconsistent levels: " curr-level new-level)))))
		(else "wrong item: " sections)))
	      nl "</div>" nl))))

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

     (cite		; ought to locate the label and use the label!
      . ,(lambda (tag key)
	   (list "[<a href=\"#" key "\">" key "</a>]")))


     (trace		; A debugging aid
      . ,(lambda (tag . content)
	   (cerr tag content nl)
	   '()))

     (URL  *MACRO*
      . ,(lambda (tag url)
	   `((br) "<" (a (^ (href ,url)) ,url) ">")))


     (verbatim	; set off pieces of code: one or several lines
      . ,(lambda (tag . lines)
	   (list "<pre>"
		 (map (lambda (line) (list "     " line nl))
		      lines)
		 "</pre>")))
		; (note . text-strings)
		; A note (remark), similar to a footnote
     (note
      . ,(lambda (tag . text-strings)
	   (list " <font size=\"-1\">[" text-strings "]</font>" nl)))

		; A reference to a file
     (fileref
      . ,(lambda (tag pathname . descr-text)
	   (list "<a href=\"" pathname "\">"
		 (car (reverse (string-split pathname '(#\/))))
		 "</a> [" 
		 (let ((file-size (OS:file-length pathname)))
		   (if (not (positive? file-size))
		       (error "File not found: " pathname))
		   (cond
		    ((< file-size 1024) "&lt;1K")
		    (else (list (quotient (+ file-size 1023) 1024) "K"))))
		 "]<br>"
		 descr-text)))

		; A reference to a plain-text file (article)
     (textref
       . ,(lambda (tag pathname title . descr)
	    (let ((file-size (OS:file-length pathname)))
	      (if (not (positive? file-size))
		  (error "File not found: " pathname))
	      (list "<a href=\"" pathname "\">" title
		    "</a> <font size=\"-1\">[plain text file]</font><br>" nl
		    descr))))

		; A reference to an anchor in the present file
		; (local-ref target . title)
		; If title is given, generate a regular
		;	<a href="#target">title</a>
		; Otherwise, transform the content so that a
		; construct that may generate an anchor 'target' (such
		; as Section or Description-unit) is re-written to the
		; title SXML. All other constructs re-write to
		; nothing.
     (local-ref
      *MACRO*
      . ,(lambda (tag target . title)
	   (let
	       ((title
		 (if (pair? title) title	; it is given explicitly
		     (pre-post-order Content
		       `((*TEXT* . ,(lambda (trigger str) '()))
			 (*DEFAULT*
			  . ,(lambda (tag . elems)
			       (let ((first-sign (signif-tail elems)))
				 (if first-sign
				     (let ((second-sign
					    (signif-tail (cdr first-sign))))
				       (assert (not second-sign))
				       (car first-sign))
				     '()))))
			 (Description-unit
			  *PREORDER*
			  . ,(lambda (tag key title . elems)
			       (if (equal? key target)
				   (list title)
				   '()))))))))
	     (assert (pair? title))
	     (cerr "title: " title nl)
	     `(a (^ (href #\# ,target)) ,title))))

		; Unit of a description for a piece of code
		; (Description-unit key title . elems)
		; where elems is one of the following:
		; headline, body, platforms, version
     (Description-unit
      ((headline
	. ,(lambda (tag . elems)
	     (list "<dt>" elems "</dt>" nl)))
       (body
	. ,(lambda (tag . elems)
	     (list "<dd>" elems "</dd>" nl)))
       (platforms
	. ,(lambda (tag . elems)
	     (list "<dt><strong>Platforms</strong><dt><dd>"
		   elems "</dd>" nl)))
       (version
	. ,(lambda (tag . elems)
	     (list "<dt><strong>Version</strong><dt><dd>"
		   "The current version is " elems ".</dd>" nl)))
       (references
	. ,(lambda (tag . elems)
	     (list "<dt><strong>References</strong><dt><dd>"
		   elems "</dd>" nl)))
       (requires
	. ,(lambda (tag . elems)
	     (list "<dt><strong>Requires</strong><dt><dd>"
		   elems "</dd>" nl)))
       )
      . ,(lambda (tag key title . elems)
	   (post-order
	    `((a (^ (name ,key)) (n_))
	      (h2 ,title)
	      (dl (insert-elems))
	      )
	    `(,@universal-protected-rules
	      (insert-elems
	       . ,(lambda (tag) elems))))))
)))
)