;; Alternative versions of pre-post-order and friends. This pre-post-order
;; calls tag handlers with two args: the name of the tag and the inner tree

(define (pre-post-order* tree bindings)
  (let* ((default-binding (assq '*default* bindings))
	 (text-binding (or (assq '*text* bindings) default-binding))
	 (text-handler			; Cache default and text bindings
	   (and text-binding
	     (if (procedure? (cdr text-binding))
	         (cdr text-binding) (cddr text-binding)))))
    (let loop ((tree tree))
      (cond
	((null? tree) '())
	((not (pair? tree))
	  (let ((trigger '*text*))
	    (if text-handler (text-handler trigger tree)
	      (error "Unknown binding for " trigger " and no default"))))
	((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
	(else				; tree is an SXML node
	  (let* ((trigger (car tree))
		 (binding (or (assq trigger bindings) default-binding)))
	    (cond
	      ((not binding)
		(error "Unknown binding for " trigger " and no default"))
	      ((not (pair? (cdr binding)))  ; must be a procedure: handler
		((cdr binding) trigger (map loop (cdr tree))))
	      ((eq? '*preorder* (cadr binding))
		((cddr binding) (car tree) (cdr tree)))
	      ((eq? '*preorder/ss* (cadr binding))
		((cddr binding) (car tree) (cdr tree) bindings))
	      ((eq? '*macro* (cadr binding))
		(loop ((cddr binding) (car tree) (cdr tree))))
	      (else			    ; (cadr binding) is a local binding
		((cddr binding) trigger
                 (pre-post-order* (cdr tree) (append (cadr binding) bindings)))
		))))))))

(define (pre-post-order-splice* tree bindings)
  (let* ((default-binding (assq '*default* bindings))
	 (text-binding (or (assq '*text* bindings) default-binding))
	 (text-handler			; Cache default and text bindings
	   (and text-binding
	     (if (procedure? (cdr text-binding))
	         (cdr text-binding) (cddr text-binding)))))
    (let loop ((tree tree))
      (cond
	((null? tree) '())
	((not (pair? tree))
	  (let ((trigger '*text*))
	    (if text-handler (text-handler trigger tree)
	      (error "Unknown binding for " trigger " and no default"))))
					; tree is a nodelist
	((not (symbol? (car tree))) (map-node-concat loop tree))
	(else				; tree is an SXML node
	  (let* ((trigger (car tree))
		 (binding (or (assq trigger bindings) default-binding)))
	    (cond
	      ((not binding) 
		(error "Unknown binding for " trigger " and no default"))
	      ((not (pair? (cdr binding)))  ; must be a procedure: handler
		((cdr binding) trigger
		  (map-node-concat loop (cdr tree))))
	      ((eq? '*preorder* (cadr binding))
		((cddr binding) (car tree) (cdr tree)))
	      ((eq? '*macro* (cadr binding))
		(loop ((cddr binding) (car tree) (cdr tree))))
	      (else			    ; (cadr binding) is a local binding
		((cddr binding) trigger 
                 (pre-post-order* (cdr tree) (append (cadr binding) bindings)))
		))))))))

(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)))))

(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 " " elems)))))

(define alist-conv-rules*
  `((*default* . ,(lambda (tag elems) (cons tag elems)))
    (*text* . ,(lambda (trigger str) str))))

;; Just overwrite extant SXML->HTML before exporting
(define (SXML->HTML tree)
 (SRV:send-reply
   (pre-post-order* tree
                ; Universal transformation rules. Work for every HTML,
                ; present and future
    `((@
      ((*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)))
 
                ; Handle a nontraditional but convenient top-level element:
                ; (html:begin title <html-body>) element
     (html:begin . ,(lambda (tag title elems)
        (list "Content-type: text/html"         ; HTTP headers
              nl nl                            ; two nl end the headers
              "<HTML><HEAD><TITLE>" title "</TITLE></HEAD>"
	      elems
              "</HTML>"))))
 
     )))