;;;;
;;;;  Texinfo stylesheet
;;;; 

(define (section? content)
  (and (pair? content) (and (eq? 'section (car content)))))


(define-record-type texinfo-section
  (make-section level head-word content children)
  texinfo-section?
  (level     section-level)
  (head-word section-head)
  (content   section-content)
  (children  section-children))


(define-datatype loc loc?
  (Top   (section texinfo-section?) )
  (Below (parent loc?)  (section texinfo-section?) )
  (Right (peer   loc?)  (section texinfo-section?) ))



(define (make-section-tree sections)

  (define (loc-section l)
    (cases loc l
	   (Top (s) s)
	   (Below (p s) s)
	   (Right (p s) s)))


  (define (loc-section-update l s)
    (cases loc l
	   (Top (_) (Top s))
	   (Below (p _) (Below p s))
	   (Right (p _) (Right p s))))


  (define (add-children l nodes) 
    (let* ((s (loc-section l))
	   (s1 (make-section 
		(section-level s)
		(section-head s)
		(section-content s)
		(append (section-children s) nodes))))
      (loc-section-update l s1)))
	   

  (define (add-content l content) 
    (let* ((s (loc-section l))
	   (s1 (make-section 
		(section-level s)
		(section-head s)
		(cons (section-content s) content )
		(section-children s))))
      (loc-section-update l s1)))
  
  (define (down l node)   (Below l node))
  (define (right l node)  (Right l node))
  
  (define (up l node)
    (let recur ((p l) (cs '()))
      (cases loc p
	     (Top (s) (error 'up "already at top level"))
	     (Below (p s) (right (add-children p (cons s cs)) node))
	     (Right (p s) (recur p (cons s cs))))))
				 
  
  (define (top l )
    (let recur ((p l) (cs '()))
      (cases loc p
	     (Top (s) p)
	     (Below (p s) (top (add-children p (cons s cs))))
	     (Right (p s) (recur p (cons s cs))))))

  (let recur ((lst sections) 
	      (cur (Top (make-section 0 #f '() '()))))
    
    (cond ((null? lst)  (loc-section (top cur)))

	  ((and (pair? (car lst)) (section?    (caar lst)))
	   (let ((section (caar lst))
		 (contents (cdar lst)))
	     (let ((level (cadr section))
		   (head-word (cadr section)))
	       (let ((node (make-section level head-word contents '())))
		 
		 (cond ((< level (section-level (loc-section cur)))
			(recur (cdr lst) (up cur node)))
		       
		       ((= level (section-level (loc-section cur)))
			(recur (cdr lst) (right cur node)))
		       
		       (else
			(recur (cdr lst) (down cur node))))
		 ))))
	  (else
	   (recur (cdr lst) (add-content cur (car lst))))))
  )
	   
	   

;; Given a string, check to make sure it does not contain characters
;; such as '_' or '&' that require encoding. Return either the original
;; string, or a list of string fragments with special characters
;; replaced by appropriate "escape sequences"

(define string->goodTexinfo
  (make-char-quotator
   `(
     (#\{ . "@{") 
     (#\} . "@}")
     (#\@ . "@@")
     (#\, . "@comma{}") ;; only in argument lists
     (,(integer->char 160) . "@")
     )))

(define string->goodTexinfo-in-verbatim
  (make-char-quotator
   `(
     (#\{ . "@{") 
     (#\} . "@}")
     (#\@ . "@@")
     (,(integer->char 160) . "@")
     )))

(define (Texinfo-node-label head-word )
  (string->goodTexinfo (string-concatenate head-word)))

(define (in-Texinfo-cmd cmd-name body)
  (list #\@ cmd-name #\{ body #\} nl))

(define (in-Texinfo-env env-name options body)
  (list "@" env-name " " options nl
	body
	"@end " env-name nl))

(define Texinfo-headers (make-parameter (list)))

(define (Texinfo-add-header! str)
  (Texinfo-headers (cons str (Texinfo-headers))))

(define (make-Texinfo-header head-parms)
  (let ((titletext (lookup-def 'title head-parms))
	(authorstext (lookup-def 'Author head-parms)))
    (list "\\input texinfo" nl
	  (Texinfo-headers)
	  "@titlepage" nl
	  (and titletext (list "@title " titletext nl))
	  (and authorstext (list "@author " authorstext nl))
	  "@end titlepage"
	  )))

(define (Texinfo-format-menu-line section)
  (list "* " section " :: " nl))

(define (Texinfo-format-menu menu)
  (if (pair? menu)
      (list "@menu" nl
	    (map Texinfo-format-menu-line menu) nl
	    "@end menu")
      '()))
	

(define (Texinfo-transformation-rules content)

  (define (singleton-list? x)
    (and (pair? x) (pair? (car x)) (null? (cdr x))))

  `((     
     (body 
      *macro*
      . ,(lambda (tag elems) 
	   (let ((content (let recur ((elems elems))
			    (if (singleton-list? elems)
				(recur (car elems))
				elems))))
	     (let* ((sections ((sxpath '(// section)) content))
		    (tree     (make-section-tree sections)))
	       (let recur ((tree tree))
		 (let ((menu (map section-head (section-children tree))))
		   `(,(if (zero? (section-level tree))
			  `(Top ,menu)
			  `(Section ,(section-level tree) 
				     ,(section-head tree) 
				     ,menu))
		     ,(section-content tree)
		     ,(map recur (section-children tree))
		     )
		   ))))))

     ,@alist-conv-rules*)

    (
			; General conversion rules
     (@ . ,(lambda (trigger value) (cons '@ value)))

     (*default* . ,(lambda (tag elems) (cons (->string tag) elems)))

     (*text* . ,(lambda (trigger str) 
		  (if (string? str) (string->goodTexinfo str) str)))

     (n_		; a non-breaking space
      . ,(lambda (tag elems)
	   (list "@{ }" elems)))

     (Header		
      *preorder*
      . ,(lambda (tag elems) (make-Texinfo-header elems)))

     (Top 
      . ,(lambda (tag elems)
	   (let ((menu (car elems)))
	     (list nl "@node Top" nl
		   (Texinfo-format-menu menu) nl))))

     (section	; (section level "content ..." . contents)
      . ,(lambda (tag elems)
	   (let ((level (car elems))
		 (head-word (cadr elems))
		 (menu  (caddr elems))
                 (contents (cdddr elems)))
	     `(,nl
               "@node " ,(Texinfo-node-label head-word) ,nl
               ,(case level
                  ((1)   "@chapter ")
                  ((2)   "@section ")
                  ((3)   "@subsection ")
                  ((4)   "@subsubsection ")
                  ((5)   "@paragraph ")
                  ((6)   "@subparagraph ")
                  (else (error "unsupported section level: " level)))
               ,head-word ,nl
               ,(Texinfo-format-menu menu) ,nl . ,contents))))

     (toc . ,(lambda (tag elems) (list nl "@contents" nl)))


     (url 
      ((@
	((href . ,(lambda (tag value)
		    (list "@url{" value "}"))))
	. ,(lambda (tag elems) elems)))
      . ,(lambda (tag elems) elems))


     ; Standard typography
     (small
      . ,(lambda (tag elems)
	   (in-Texinfo-cmd "smallformat" elems)))

     (strong
      . ,(lambda (tag elems)
	   (in-Texinfo-cmd "strong" elems)))

     (tt
      . ,(lambda (tag elems)
	   (in-Texinfo-cmd "code" elems)))

     (em
      . ,(lambda (tag elems)
	   (in-Texinfo-cmd "emph" elems)))

     (p
      . ,(lambda (tag elems)
	   (list elems nl nl)))

     (div
      . ,(lambda (tag elems)
	   (list elems nl)))

     (br
      . ,(lambda (tag elems)
	   (list "@*")))

     (hr . ,(lambda (tag elems)  '()))

     (indent . ,(lambda (tag elems) '()))

     (ul			; Unnumbered lists
      . ,(lambda (tag elems)
	   (in-Texinfo-env "itemize" '() elems)))

     (ol			; Numbered lists
      . ,(lambda (tag elems)
	   (in-Texinfo-env "enumerate" '() elems)))

     (li
      . ,(lambda (tag elems)
	   (list "@item " elems nl)))

     (dl			; Definition list

      ;; dl and dt are translated to procedures that take one argument:
      ;; previously set label: list of fragments or #f if none
      ;; The procedure returns a pair: (new-label . generate-fragments)
      ;; Initially, label is #f

      ((dt			;; The item title
	. ,(lambda (tag elems)
	    (lambda (label)
	      (cons elems	;; elems become the new label
		    (if label	;; the label was set: we've seen dt without dd
			(list "@item " label nl) ; empty body
			'())))))
       (dd			;; The item body
	. ,(lambda (tag elems)
	    (lambda (label)
	      (cons #f		;; consume the existing label
		    (list "@item " (or label "") nl elems nl)))))
       )
      . ,(lambda (tag procs)	;; execute procs generated by dt/dd
	  (let loop ((procs (flatten procs)) (label #f) (accum '()))
	    (if (null? procs) (in-Texinfo-env "table" '("@asis") (reverse accum))
		(let ((result ((car procs) label)))
		  (loop (cdr procs) (car result) (cons (cdr result) accum))))))
      )
	
     (def
       ((sig . ,(lambda (tag types)
                  (map (lambda (spec)
                         (in-Texinfo-env "table" '("@asis")
				   (list "@item " (car spec) nl (cdr spec) "}")))
                       types))))
       . ,(lambda (tag elems) elems))

     (blockquote
      . ,(lambda (tag elems)
	   (in-Texinfo-env "quotation" '() elems)))

     (pre
      *macro*
      . ,(lambda (tag elems)
           `(verbatim . ,elems)))
	  
     (verbatim	;; set off pieces of code: one or several lines
      ((*text* . ;; Different quotation rules apply within a "verbatim" block
	       ,(lambda (trigger str) 
		  (if (string? str) (string->goodTexinfo-in-verbatim str) str)))
	)
      . ,(lambda (tag lines)
	   (in-Texinfo-env "verbatim" '()
			   (map (lambda (line) 
				  (list (if (equal? line "") "~" line) 
					"@*" nl))
				lines))))


     (table
      ;; (table [(@ attrib ...)] tr ...
      ((@
	((*default* . ,(lambda (tag value)
			 (cons tag value))))
	. ,(lambda (tag elems) (cons tag elems))))
      . ,(lambda (tag elems)
	   (let*-values
	    (((attrs rows) (if (and (pair? elems) 
				    (pair? (car elems))
				    (eq? '@ (caar elems)))
			       (values (cdar elems) (cdr elems))
			       (values '() elems)))
	     ((border?)
	      (cond
	       ((assq 'border attrs) => 
		(lambda (border-attr) (not (equal? "0" (cadr border-attr)))))
	       (else #f)))

	     ((caption label table-type table-alignment)
	      (apply values
		     (map (lambda (name)
			    (cond
			     ((assq name attrs) => cadr)
			     (else #f)))
			  '(caption key table-type align))))

	     (dummy (assert (pair? rows))) ; at least one row must be given

	     ((ncols) (length (car rows)))

	     ((texinfo-cols)
	      (let* ((verbatim? 
		      (lambda (r) 
			(pre-post-order* r
			  `(
			    (verbatim
			     . ,(lambda (tag elems) elems))
			    
			    (*default*
			     . ,(lambda (tag elems) elems))
			    
			    (*text* . ,(lambda (trigger str) (list))))
			  )))

		     (col-prototypes (map (lambda (r) (list "{" r "}" )) (car rows))))

		(apply string-append col-prototypes)))
	     )
	    (list
	      (list
	       (and (equal? table-alignment "center")
		    "@center")
	       (in-Texinfo-env "multitable" texinfo-cols
		(list
		  (map
		   (lambda (row)
		     (list
		      "@item "
		      (intersperse
		       (map
			(lambda (col)
			  (apply
			   (lambda (alignment span . data) data)
			   col))
			row)
		       (list nl "@tab "))
		      nl
		   rows)
		  nl))
	       (and (equal? table-alignment "center")
		    "@end center")
	       ))
	    )))

	   ))

     (texinfo      ; raw texinfo expression
       *preorder*
       . ,(lambda (tag str) str))
	    
     )))