;;;; (texinfo docbook) -- translating sdocbook into stexinfo
;;;;
;;;; 	Copyright (C) 2009  Free Software Foundation, Inc.
;;;;    Copyright (C) 2007, 2009 Andy Wingo <wingo at pobox dot com>
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; 

;;; Commentary:
;;
;; @c
;; This module exports procedures for transforming a limited subset of
;; the SXML representation of docbook into stexi. It is not complete by
;; any means. The intention is to gather a number of routines and
;; stylesheets so that external modules can parse specific subsets of
;; docbook, for example that set generated by certain tools.
;;
;;; Code:

(define-module (texinfo docbook)
  :use-module (sxml fold)
  :export (*sdocbook->stexi-rules*
           *sdocbook-block-commands*
           sdocbook-flatten
           filter-empty-elements
           replace-titles))

(define (identity . args)
  args)

(define (identity-deattr tag . body)
  `(,tag ,@(if (and (pair? body) (pair? (car body))
                    (eq? (caar body) '@))
               (cdr body)
               body)))

(define (detag-one tag body)
  body)

(define tag-replacements
  '((parameter var)
    (replaceable var)
    (type code)
    (function code)
    (literal samp)
    (emphasis emph)
    (simpara para)
    (programlisting example)
    (firstterm dfn)
    (filename file)
    (quote cite)
    (application cite)
    (symbol code)
    (note cartouche)
    (envar env)))

(define ignore-list '())

(define (stringify exp)
  (with-output-to-string (lambda () (write exp))))

(define *sdocbook->stexi-rules*
  #;
  "A stylesheet for use with SSAX's @code{pre-post-order}, which defines
a number of generic rules for transforming docbook into texinfo."
  `((@ *preorder* . ,identity)
    (% *preorder* . ,identity)
    (para . ,identity-deattr)
    (orderedlist ((listitem
                   . ,(lambda (tag . body)
                        `(item ,@body))))
                 . ,(lambda (tag . body)
                      `(enumerate ,@body)))
    (itemizedlist ((listitem
                    . ,(lambda (tag . body)
                         `(item ,@body))))
                  . ,(lambda (tag . body)
                       `(itemize ,@body)))
    (term . ,detag-one)
    (informalexample . ,detag-one)
    (section . ,identity)
    (subsection . ,identity)
    (subsubsection . ,identity)
    (ulink . ,(lambda (tag attrs . body)
                `(uref (% ,(assq 'url (cdr attrs))
                          (title ,@body)))))
    (*text* . ,detag-one)
    (*default* . ,(lambda (tag . body)
                    (let ((subst (assq tag tag-replacements)))
                      (cond
                       (subst
                        (if (and (pair? body) (pair? (car body)) (eq? (caar body) '@))
                            (begin
                              (warn "Ignoring" tag "attributes" (car body))
                              (append (cdr subst) (cdr body)))
                            (append (cdr subst) body)))
                       ((memq tag ignore-list) #f)
                       (else 
                        (warn "Don't know how to convert" tag "to stexi")
                        `(c (% (all ,(stringify (cons tag body))))))))))))

;;     (variablelist
;;      ((varlistentry
;;        . ,(lambda (tag term . body)
;;             `(entry (% (heading ,@(cdr term))) ,@body)))
;;       (listitem
;;        . ,(lambda (tag simpara)
;;             simpara)))
;;      . ,(lambda (tag attrs . body)
;;           `(table (% (formatter (var))) ,@body)))

(define *sdocbook-block-commands*
  #;
  "The set of sdocbook element tags that should not be nested inside
each other. @xref{texinfo docbook sdocbook-flatten,,sdocbook-flatten},
for more information." 
  '(para programlisting informalexample indexterm variablelist
    orderedlist refsect1 refsect2 refsect3 refsect4 title example
    note itemizedlist))

(define (inline-command? command)
  (not (memq command *sdocbook-block-commands*)))

(define (sdocbook-flatten sdocbook)
  "\"Flatten\" a fragment of sdocbook so that block elements do not nest
inside each other.

Docbook is a nested format, where e.g. a @code{refsect2} normally
appears inside a @code{refsect1}. Logical divisions in the document are
represented via the tree topology; a @code{refsect2} element
@emph{contains} all of the elements in its section.

On the contrary, texinfo is a flat format, in which sections are marked
off by standalone section headers like @code{@@chapter}, and block
elements do not nest inside each other.

This function takes a nested sdocbook fragment @var{sdocbook} and
flattens all of the sections, such that e.g.
@example
 (refsect1 (refsect2 (para \"Hello\")))
@end example
becomes
@example
 ((refsect1) (refsect2) (para \"Hello\"))
@end example

Oftentimes (always?) sectioning elements have @code{<title>} as their
first element child; users interested in processing the @code{refsect*}
elements into proper sectioning elements like @code{chapter} might be
interested in @code{replace-titles} and @code{filter-empty-elements}.
@xref{texinfo docbook replace-titles,,replace-titles}, and @ref{texinfo
docbook filter-empty-elements,,filter-empty-elements}.

Returns a nodeset, as described in @ref{sxml xpath}. That is to say,
this function returns an untagged list of stexi elements."
  (define (fhere str accum block cont)
    (values (cons str accum)
            block
            cont))
  (define (fdown node accum block cont)
    (let ((command (car node))
          (attrs (and (pair? (cdr node)) (pair? (cadr node))
                      (eq? (caadr node) '%)
                      (cadr node))))
      (values (if attrs (cddr node) (cdr node))
              '()
              '()
              (lambda (accum block)
                (values
                 `(,command ,@(if attrs (list attrs) '())
                            ,@(reverse accum))
                 block)))))
  (define (fup node paccum pblock pcont kaccum kblock kcont)
    (call-with-values (lambda () (kcont kaccum kblock))
      (lambda (ret block)
        (if (inline-command? (car ret))
            (values (cons ret paccum) (append kblock pblock) pcont)
            (values paccum (append kblock (cons ret pblock)) pcont)))))
  (call-with-values
      (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
    (lambda (accum block cont)
      (reverse block))))
    
(define (filter-empty-elements sdocbook)
  "Filters out empty elements in an sdocbook nodeset. Mostly useful
after running @code{sdocbook-flatten}."
  (reverse
   (fold
    (lambda (x rest)
      (if (and (pair? x) (null? (cdr x)))
          rest
          (cons x rest)))
    '()
    sdocbook)))

(define (replace-titles sdocbook-fragment)
  "Iterate over the sdocbook nodeset @var{sdocbook-fragment},
transforming contiguous @code{refsect} and @code{title} elements into
the appropriate texinfo sectioning command. Most useful after having run
@code{sdocbook-flatten}.

For example:
@example
 (replace-titles '((refsect1) (title \"Foo\") (para \"Bar.\")))
    @result{} '((chapter \"Foo\") (para \"Bar.\"))
@end example
"
  (define sections '((refsect1 . chapter)
                     (refsect2 . section)
                     (refsect3 . subsection)
                     (refsect4 . subsubsection)))
  (let lp ((in sdocbook-fragment) (out '()))
    (cond
     ((null? in)
      (reverse out))
     ((and (pair? (car in)) (assq (caar in) sections))
      ;; pull out the title
      => (lambda (pair)
           (lp (cddr in) (cons `(,(cdr pair) ,@(cdadr in)) out))))
     (else
      (lp (cdr in) (cons (car in) out))))))