;;; xml2texi.scm --- Convert gnus-faq.xml to gnus-faq.texi
;; Copyright (C) 2005  Free Software Foundation, Inc.

;; Author:  Karl Pflästerer <sigurd@12move.de>
;; Keywords: tools

;; This file is not part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs 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 General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:
;; 

;;; Code:

(require (lib "ssax.ss" "ssax")
         (lib "sxpath.ss" "ssax")
         (lib "sxml-tree-trans.ss" "ssax")
         (lib "pregexp.ss")
         (lib "list.ss")
         (lib "etc.ss")
         (rename (lib "1.ss" "srfi") list-index list-index)
         (rename (lib "13.ss" "srfi") string-join string-join))


;;; Constants
;; In and out; for convenience if we work from the REPL
(define +infile+ "gnus-faq.xml")
(define +outfile+ "gnus-faq.texi")

;; These are the names of the sections.  These variables hold the names
;; of the sections where numbering starts in the main menu.
;; Where we start numbering in menu
(define +first-numbered-section+ "Installation FAQ")
;; Where we end numbering in menu
(define +last-numbered-section+ "Tuning Gnus")

;; Which sections not to include; i.e. not to name a node.
(define +ignored-sections+ '("Frequently Asked Questions with Answers"))

;; Names of menu entries and the corresponding descriptions (used in the
;; main menu).
(define +section-comments-alist+
    '(("Introduction" . "About Gnus and this FAQ.")
      ("Installation FAQ" . "Installation of Gnus.")
      ("Startup / Group buffer" . "Start up questions and the first buffer Gnus shows you.")
      ("Getting Messages" . "Making Gnus read your mail and news.")
      ("Reading messages" . "How to efficiently read messages.")
      ("Composing messages" . "Composing mails or Usenet postings.")
      ("Old messages" . "Importing, archiving, searching and deleting messages.")
      ("Gnus in a dial-up environment" . "Reading mail and news while offline.")
      ("Getting help" . "When this FAQ isn't enough.")
      ("Tuning Gnus" .  "How to make Gnus faster.")
      ("Glossary" . "Terms used in the FAQ explained.")))

;; Where to break descriptions in menus
(define +width+ 72)

;; The boilerplate text we include before the document
(define boilerplate
    (lambda (titel)
      (format
       "\
@c \\input texinfo @c -*-texinfo-*-~%\
@c Uncomment 1st line before texing this file alone.~%\
@c %**start of header~%\
@c Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
@c   2008 Free Software Foundation, Inc.~%\
@c~%\
@c Do not modify this file, it was generated from gnus-faq.xml, available from~%\
@c <URL:http://my.gnus.org/FAQ/>.~%\
@c~%\
@setfilename gnus-faq.info~%\
@settitle ~A~%\
@c %**end of header~%\
@c~%\
" titel)))

;; Inserted right before the end of the file
(define +tag-for-gnus-faq-texi+
    (format "\
~%\
@ignore~%\
arch-\
tag: 64dc5692-edb4-4848-a965-7aa0181acbb8~%\
@end ignore~%\
"))

;;; Little Helpers
;; (a b c) -> (1 2 3)
(define (number-list start inc lst)
    (let loop ((lst lst) (lvl start) (acc '()))
         (if (null? lst)
           (reverse acc)
           (loop (cdr lst) (+ inc lvl) (cons lvl acc)))))

;; Given an alist made of regexps and their replacements (key and value
;; are in a proper list) returns a function which given a string
;; replaces all occurences of the regexps (from left to right).
;; ((re1 repl1) (re2 repl2)) -> str -> str
(define make-reg-replacer
    (lambda (defalist)
      (let ((allreg (string-join (map car defalist) "|")))
        (lambda (str)
          (if (and (string? str) (pregexp-match allreg str))
            (let loop ((lst defalist) (str str))
                 (if (null? lst)
                   str
                   (loop (cdr lst) (pregexp-replace* (caar lst) str (cadar lst)))))
            str)))))

(define escape-texi
    (make-reg-replacer '(("@"  "@@") ("{"  "@{") ("}"  "@}"))))

(define normalize
    (compose escape-texi (make-reg-replacer `((,(format "~%\\s+") ,(format "~%"))))))

(define normalize-example
    (compose escape-texi (make-reg-replacer '(("^\\s+|\\s+$" "")))))

(define trim-ws (make-reg-replacer '(("^\\s+|\\s+$" ""))))

(define filter-sect
    (lambda (lst)
      (filter (lambda (e) (not (member e +ignored-sections+))) lst)))

;;;; Para
(define format-para
    (lambda (list-of-entries)
      (format "~%~A~%" (trim-ws (apply string-append list-of-entries)))))

;;;; Questions
(define format-q-level
    (lambda (level)
      ;; (apply format "[~A.~A]" (reverse level))))
      (apply format "FAQ ~A-~A" (reverse level))))

(define format-q-description
    (compose trim-ws (make-reg-replacer `((,(format "~%") " ")))))

;;;; Building nodes
;; curr-node up-node (list of nodes) (list of node names) ->
;;   ((curr-node curr-name) (next next-name) (prev prev-name) up)
(define (find-prev-next-up curr up search-list name-list)
    (do ((lst   search-list (cdr lst))
         (rlst  name-list   (cdr rlst))
         (prev  up   (car lst))
         (prevn up   (car rlst)))
        ((or (null? lst) (equal? (car lst) curr))
         (values (cons curr (if (pair? rlst) (car rlst) curr))
                 (if (and (pair? lst) (pair? (cdr lst))) ;next
                   (cons (cadr lst) (cadr rlst))
                   (cons "" ""))
                 (cons prev prevn)
                 up))))


(define (format-node section title up lst-of-nodes lst-of-names)
    (if (member title +ignored-sections+)
      ()
      (call-with-values
       (lambda () (find-prev-next-up title up lst-of-nodes lst-of-names))
       (lambda (currn prevn nextn up)
         (format "~%@node ~A~%~A ~A~%"
                 (cdr currn) ;; (cdr prevn) (cdr nextn) up
                 section ;; @subsection etc.
                 (if (pair? title)
                   (apply format "~A.~A" (reverse title))
                   title))))))

;;;; Building menus

(define format-menu
    (lambda (alist-of-entries)
      (let ((len (apply max (map (lambda (s) (string-length (car s))) alist-of-entries))))
        (format "~%@menu~%~A@end menu~%"
                (apply string-append
                       (map (lambda (e)
                              (format "* ~A::~A~A~%"
                                      (car e) ;the entry
                                      (make-string (- len (string-length (car e)) -3) #\ )
                                      (format-menu-description (cdr e) +width+ (+ len 7))))
                            alist-of-entries))))))


(define format-menu-description
    (lambda (entry width offset)
      (let loop ((lst (pregexp-split "\\s" entry)) (len 0) (acc '()))
           (if (null? lst)
             (apply string-append (reverse! acc))
             (let ((slen (+ 1 (string-length (car lst))))) ; +1 because of whitespace added later
               (if (> (+ slen len) (- width offset))
                 (loop (cdr lst) 0 (cons
                                    (format "~%~A ~A"                 ; start a new line
                                            (make-string offset #\ ) ; the whitespace
                                            (car lst))
                                    acc))
                 (loop (cdr lst) (+ slen len) (cons (format " ~A"(car lst)) acc))))))))


(define format-sub-titles
    (lambda (list-of-entries first-number-entry last-number-entry)
      (let ((offset (or (list-index (lambda (e) (equal? e first-number-entry)) list-of-entries) 0))
            (end (or (list-index (lambda (e) (equal? e last-number-entry)) list-of-entries)
                     (length list-of-entries))))
      (map (lambda (entry ind)
             (format "FAQ ~A ~A"
                     (if (<= offset ind end)
                       (format "~A -" (- ind offset -1)) ;numbered entry
                       "-")
                     entry))
           list-of-entries (number-list 0 1 list-of-entries)))))

;;;; We number some sections first

;; ntags is an alist => ((tag startcounter increment)
(define (number-nodes tree level ntags)
    (if (null? ntags)
      tree
      (let* ((vals  (car ntags))
             (ntag  (car vals))
             (start (second vals))
             (inc   (third vals))
             (ntags (cdr ntags)))

        (map
         (lambda (node sublevel)
           (pre-post-order
            node
            `((,ntag *preorder*
                     . ,(lambda (tag . entry)
                          `(,tag ,(cons sublevel level)
                                 ,@(number-nodes entry (cons sublevel level) ntags))))
              (*default* . ,(lambda x x))
              (*text* . ,(lambda (tag s) s)))))
         tree (number-list start inc tree)))))


;;(transform->numbered faqsxml '(section article qandaset ((qandadiv 1 1) (qandaentry 0 1))))
(define transform->numbered
    (lambda (sxml rules)
      (let* ((rules (reverse rules))
             (rule (car rules))
             (ntag (cadr rules))
             (styles (map (lambda (tag) (cons tag (lambda x x))) (list-tail rules 2))))
  (pre-post-order
   sxml
     `((*default* *preorder* . ,(lambda x x))
       (*TOP* . ,(lambda x x))
       ,@styles
       (,ntag *preorder*
        . ,(lambda (tag . nodes)
             (cons tag (number-nodes nodes '() rule)))))))))


;;;; The main transform function

(define (transform sxml)
    (let* ((sxml (transform->numbered
                  sxml '(section article qandaset ((qandadiv 1 1) (qandaentry 0 1)))))
           (qandadivtitles (filter-sect (map second ((sxpath '(// qandadiv title)) sxml))))
           (fqandadivtitles (format-sub-titles qandadivtitles "" ""))
           (subtitles (filter-sect (append (map second ((sxpath '(// section title)) sxml))
                                           qandadivtitles
                                           (map second ((sxpath '(// glossary title)) sxml)))))
           (fsubtitles (format-sub-titles subtitles +first-numbered-section+
                                          +last-numbered-section+))
           (questlevel (map second ((sxpath '(article section qandaset qandadiv qandaentry)) sxml)))
           (up1 (cadar ((sxpath '(article articleinfo title)) sxml)))

;;; ************************************************************
;;; The Style Sheet
;;; ************************************************************
           (style-sheet
             `(
;;; ************************************************************
;;; First the SXML special markers
;;; ************************************************************
               ;; *TOP* *PI* @ are markers from SXML
               (*TOP* . ,(lambda (tag . x) x))
               (*PI* . ,(lambda _ '()))
               (@ . ,(lambda _ ""))

               ;; Look for the example rule where we overwrite the *text* rule
               ;; so code doesn't get mangled.
               (*text*
                . ,(lambda (tag string)
                     (normalize string)))
               ;; If nothing else matches
               (*default* . ,(lambda x x))
;;; ************************************************************
;;; Now to the tags of our FAQ
;;; ************************************************************
               (article . ,(lambda (tag . sects)
                             (list (boilerplate up1) sects 
                                   +tag-for-gnus-faq-texi+)))

               (articleinfo
                ((*default* . ,(lambda _ '()))
                 (title
                  . ,(lambda (tag titel)
                       (let ((menucom (map (lambda (entry)
                                             (let ((e (assoc entry +section-comments-alist+)))
                                               (if e (cdr e) "")))
                                           subtitles)))
                         (list (format-node '@section titel "" '() '())
                               (format-menu (map cons fsubtitles menucom)))))))
                . ,(lambda (tag . info) info))

               ;; Sections
               (abstract
                . ,(lambda (tag . text)
                     (cons (format "~%@subheading Abstract~%") text)))
               (section
                ((title
                  . ,(lambda (tag titel)
                       (format-node '@subheading titel up1 subtitles fsubtitles))))
                . ,(lambda (tag . entry) entry))

               ;; Q&A well it's called FAQ isn't it?
               (qandaset . ,(lambda (tag . x) x))
               (qandadiv
                ((title
                  . ,(lambda (tag titel) titel)))
                . ,(lambda (tag level titel . entries)
                     (let ((questions (map cadr entries))
                           (nlevel (filter (lambda (lvl) (eq? (car level) (cadr lvl))) questlevel)))
                       (list*
                        (format-node '@subsection titel up1 subtitles fsubtitles)
                        (format-menu (map (lambda (lvl quest)
                                            (cons (format-q-level lvl)
                                                  (format-q-description quest)))
                                          nlevel questions))
                        entries))))
               (qandaentry
                . ,(lambda (tag level question answer)
                     (let ((nodes
                             (filter (lambda (lvl) (eq? (cadr lvl) (cadr level))) questlevel))
                           (up (list-ref fqandadivtitles (- (cadr level) 1))))
                       (list*
                        (format-node "@subsubheading Question" level up nodes (map format-q-level nodes))
                        question answer))))
               (question . ,(lambda (tag quest) quest))
               (answer
                . ,(lambda (tag  . answ) (list* (format "~%@subsubheading Answer~%") answ)))

               ;; Para
               (para . ,(lambda (tag . x) (format-para x)))
               (simpara . ,(lambda (tag . x) (cons (format "~%")  x)))

               ;; Itemized lists.
               ;; We rewrite para here because it plays here the role of an
               ;; item marker
               (itemizedlist
                . ,(lambda (tag lstitem)
                     (format "~%@itemize @bullet~%~A@end itemize~%" lstitem)))
               (listitem
                ((para
                  . ,(lambda (tag item)
                       (format "~%@item~%~A~%" (trim-ws item)))))
                . ,(lambda (tag . x) (string-join x "")))

               ;; The glossary.
               (glossary
                ((title . ,(lambda _'())))
                . ,(lambda (tag . terms)
                     (let ((titel (cadar ((sxpath '(article glossary title)) sxml))))
                       (cons (format-node '@subsection titel up1 subtitles fsubtitles)
                             (list (format "~%@table @dfn~%")
                                   terms
                                   (format "~%@end table~%"))))))
               (glossentry . ,(lambda (tag . entry) entry))
               (glossterm
                . ,(lambda (tag term)
                     (format "~%@item ~A" term)))
               (glossdef
                . ,(lambda (tag def) def))

               ;; Lisp examples
               ;; We rewrite the *text* rule so code stays the way it's writen.
               (programlisting
                ((*text*
                  . ,(lambda (tag exampl)
                       (normalize-example exampl))))
                . ,(lambda (tag . exampl)
                     (format "~%@example~%~A~%@end example~%@noindent~%" (string-join exampl ""))))

               ;; The link handling
               ;; Here we are interested in the attributes, so we rewrite the @
               ;; rule.  If we find a value we look if it's an email or http
               ;; uri.
               (ulink
                ((@
                  . ,(lambda (at val) val)))
                . ,(lambda (tag uri name)
                     (if (pregexp-match "^http:|^ftp:" uri)
			 (if (equal? uri name)
			     (format "@uref{~A}"  uri)
			     (format "@uref{~A, ~A}"  uri name))
			 (format "@email{~A, ~A}" (substring uri 7) name))))
               (url
                . ,(lambda (tag val) val))

               ;; userinput
               (userinput
                . ,(lambda (tag val)
                     (format "@samp{~A}" val)))
               )))
      (pre-post-order sxml style-sheet)))

;;;; We call main with infile and outfile as arguments
(define main
    (lambda (in out)
      (with-output-to-file out
        (lambda ()
          (call-with-input-file in
            (lambda (port)
              (SRV:send-reply (transform (ssax:xml->sxml port '()))))))
        'replace)))

;; Local Variables:
;; coding: iso-8859-1
;; End:

;;; xml2texi.scm ends here