;;;;
;;;;  HTML stylesheet
;;;; 
(define nl (string #\newline))
(define (make-html-header head-parms)
  `(head
    (title ,(or (lookup-def 'title head-parms) "multidoc"))
    (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
    (meta (@ (http-equiv "Content-Type") 
	     (content ,(lookup-def 'Content-Type head-parms 
				   "text/html; charset=UTF-8"))))
    ,(let ((style  (lookup-def 'style head-parms))
           (print-style  (lookup-def 'print-style head-parms))
           (canonical (lookup-def 'canonical 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))) '())
             (if canonical `(link (@ (rel "canonical") (href ,canonical))) '())))
    ,(map
      (lambda (key)
        (let ((val (lookup-def key head-parms )))
          (and val
               `(meta (@ (name ,(symbol->string key)) (content ,val))))))
      '(description Author keywords
                    Date-Revision-yyyymmdd Date-Creation-yyyymmdd))))


(define (internal-link r)
  (post-order 
   r
   `(
     (*default* . ,(lambda (tag . elems) elems))
     
     (*text* . ,(lambda (trigger str) 
		  (string-substitute* (string-downcase str) 
				      '(("^[^a-z]+" . "")
					("[^a-z0-9_ \t-]" . "")
					("[ \t]+" . "-")))))


     )))


(define (html-transformation-rules content)
  `((
     (@ *preorder* . ,(lambda (tag elements) (cons tag elements)))

     (Header
      *preorder*
      . ,(lambda (tag headers)
           (make-html-header headers)))

     (toc ;; Re-scan the content for "section" tags and generate
      *macro*
      . ,(lambda (tag rest) ;; the table of contents
           `(div (@ (id "toc"))
                 ,rest
                 (ol ,(let find-sections ((content content))
                        (cond
                         ((not (pair? content)) '())
                         ((pair? (car content))
                          (append (find-sections (car content))
                                  (find-sections (cdr content))))
                         ((eq? (car content) 'section)
                          (let* ((level (cadr content))
                                 (head-word (caddr content))
                                 (href (list "#" (internal-link head-word)))
                                 (subsections (find-sections (cdddr content))))
                            (cond ((and (integer? level) head-word)
                                   `((li (a (@ (href (,href))) ,head-word)
                                         ,@(if (null? subsections)
                                               '()
                                               `((ol ,subsections))))))
                                  (else
                                   (error 'html-transformation-rules
                                          "section elements must be of the form (section level head-word . contents)")))))
                         (else (find-sections (cdr content)))))))))
     
     (section
      *macro*
      . ,(lambda (tag elems)
	   (let ((level (car elems))
		 (head-word (cadr elems))
                 (contents (cddr elems)))
	     (cond ((and (integer? level) head-word)
		    `((,(string->symbol (string-append "h" (number->string level)))
		      (@ (id ,(internal-link head-word)))
		      ,head-word ) . ,contents))
		  (else
		   (error 'html-transformation-rules
			  (conc "section elements must be of the form (section level head-word . contents), got " elems))))
             )))

     (section*
      *macro*
      . ,(lambda (tag elems)
	   (let ((level (car elems))
		 (head-word (cadr elems))
                 (contents (cddr elems)))
	     (cond ((and (integer? level) head-word)
		    `((,(string->symbol (string-append "h" (number->string level)))
		      ,head-word ) . ,contents))
		  (else
		   (error 'html-transformation-rules
			  (conc "section elements must be of the form (section level head-word . contents), got " elems))))
             )))

     (def
       ((sig . ,(lambda (tag types)
                  (map (lambda (spec)
                         `(span (@ (class ,(conc "definition " (car spec))))
                                (em "[" ,(symbol->string (car spec)) "]")
                                " " (tt ,@(cdr spec)) (br)))
                       types))))
       . ,(lambda (tag elems) elems))
     
     (pre
      . ,(lambda (tag elems)
           `(pre (tt . ,elems))))

     (image-link
      *macro*
      . ,(lambda (tag elems)
	   `(img (@ (src ,(car elems)) . ,(if (null? (cdr elems))
                                              '()
                                              `((alt ,(cadr elems))
                                                (title ,(cadr elems))))))))
     
     (int-link
      *macro*
      . ,(lambda (tag elems)
           ;; Normalize links so people can refer to sections by their proper name
           (let* ((parts (string-split (car elems) "#" #t))
                  (nparts (intersperse
                           (cons (car parts) (internal-link (cdr parts)))
                           "#")))
            `(a (@ (href ,@nparts) (class "internal"))
                ,(if (null? (cdr elems)) (car elems) (cadr elems))))))
     
     (link
      *macro*
      . ,(lambda (tag elems)
	   `(a (@ (href ,(car elems)) (class "external"))
               ,(if (null? (cdr elems)) (car elems) (cadr elems)))))

     ,@alist-conv-rules*
     )

    (
     (html:begin
      . ,(lambda (tag elems)
	   (list
	    xhtml-1.0-strict
	    "<html xmlns=\"http://www.w3.org/1999/xhtml\">"
	     elems
	     "</html>")))

     (verbatim
      *preorder*
      . ,(lambda (tag elems)
           elems))

     ,@universal-conversion-rules*)
    )
  )