1 ;;; xml2texi.scm --- Convert gnus-faq.xml to gnus-faq.texi
2 ;; Copyright (C) 2005 Free Software Foundation, Inc.
4 ;; Author: Karl Pflästerer <sigurd@12move.de>
7 ;; This file is not part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
29 (require (lib "ssax.ss" "ssax")
30 (lib "sxpath.ss" "ssax")
31 (lib "sxml-tree-trans.ss" "ssax")
35 (rename (lib "1.ss" "srfi") list-index list-index)
36 (rename (lib "13.ss" "srfi") string-join string-join))
40 ;; In and out; for convenience if we work from the REPL
41 (define +infile+ "gnus-faq.xml")
42 (define +outfile+ "gnus-faq.texi")
44 ;; These are the names of the sections. These variables hold the names
45 ;; of the sections where numbering starts in the main menu.
46 ;; Where we start numbering in menu
47 (define +first-numbered-section+ "Installation FAQ")
48 ;; Where we end numbering in menu
49 (define +last-numbered-section+ "Tuning Gnus")
51 ;; Which sections not to include; i.e. not to name a node.
52 (define +ignored-sections+ '("Frequently Asked Questions with Answers"))
54 ;; Names of menu entries and the corresponding descriptions (used in the
56 (define +section-comments-alist+
57 '(("Introduction" . "About Gnus and this FAQ.")
58 ("Installation FAQ" . "Installation of Gnus.")
59 ("Startup / Group buffer" . "Start up questions and the first buffer Gnus shows you.")
60 ("Getting Messages" . "Making Gnus read your mail and news.")
61 ("Reading messages" . "How to efficiently read messages.")
62 ("Composing messages" . "Composing mails or Usenet postings.")
63 ("Old messages" . "Importing, archiving, searching and deleting messages.")
64 ("Gnus in a dial-up environment" . "Reading mail and news while offline.")
65 ("Getting help" . "When this FAQ isn't enough.")
66 ("Tuning Gnus" . "How to make Gnus faster.")
67 ("Glossary" . "Terms used in the FAQ explained.")))
69 ;; Where to break descriptions in menus
72 ;; The boilerplate text we include before the document
77 @c \\input texinfo @c -*-texinfo-*-~%\
78 @c Uncomment 1st line before texing this file alone.~%\
79 @c %**start of header~%\
80 @c Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.~%\
81 @setfilename gnus-faq.info~%\
83 @c %**end of header~%\
86 ;; Inserted right before the end of the file
87 (define +tag-for-gnus-faq-texi+
92 tag: 64dc5692-edb4-4848-a965-7aa0181acbb8~%\
98 (define (number-list start inc lst)
99 (let loop ((lst lst) (lvl start) (acc '()))
102 (loop (cdr lst) (+ inc lvl) (cons lvl acc)))))
104 ;; Given an alist made of regexps and their replacements (key and value
105 ;; are in a proper list) returns a function which given a string
106 ;; replaces all occurences of the regexps (from left to right).
107 ;; ((re1 repl1) (re2 repl2)) -> str -> str
108 (define make-reg-replacer
110 (let ((allreg (string-join (map car defalist) "|")))
112 (if (and (string? str) (pregexp-match allreg str))
113 (let loop ((lst defalist) (str str))
116 (loop (cdr lst) (pregexp-replace* (caar lst) str (cadar lst)))))
120 (make-reg-replacer '(("@" "@@") ("{" "@{") ("}" "@}"))))
123 (compose escape-texi (make-reg-replacer `((,(format "~%\\s+") ,(format "~%"))))))
125 (define normalize-example
126 (compose escape-texi (make-reg-replacer '(("^\\s+|\\s+$" "")))))
128 (define trim-ws (make-reg-replacer '(("^\\s+|\\s+$" ""))))
132 (filter (lambda (e) (not (member e +ignored-sections+))) lst)))
136 (lambda (list-of-entries)
137 (format "~%~A~%" (trim-ws (apply string-append list-of-entries)))))
140 (define format-q-level
142 (apply format "[~A.~A]" (reverse level))))
144 (define format-q-description
145 (compose trim-ws (make-reg-replacer `((,(format "~%") " ")))))
148 ;; curr-node up-node (list of nodes) (list of node names) ->
149 ;; ((curr-node curr-name) (next next-name) (prev prev-name) up)
150 (define (find-prev-next-up curr up search-list name-list)
151 (do ((lst search-list (cdr lst))
152 (rlst name-list (cdr rlst))
154 (prevn up (car rlst)))
155 ((or (null? lst) (equal? (car lst) curr))
156 (values (cons curr (if (pair? rlst) (car rlst) curr))
157 (if (and (pair? lst) (pair? (cdr lst))) ;next
158 (cons (cadr lst) (cadr rlst))
164 (define (format-node section title up lst-of-nodes lst-of-names)
165 (if (member title +ignored-sections+)
168 (lambda () (find-prev-next-up title up lst-of-nodes lst-of-names))
169 (lambda (currn prevn nextn up)
170 (format "~%@node ~A~%~A ~A~%"
171 (cdr currn) ;; (cdr prevn) (cdr nextn) up
172 section ;; @subsection etc.
174 (apply format "~A.~A" (reverse title))
180 (lambda (alist-of-entries)
181 (let ((len (apply max (map (lambda (s) (string-length (car s))) alist-of-entries))))
182 (format "~%@menu~%~A@end menu~%"
185 (format "* ~A::~A~A~%"
187 (make-string (- len (string-length (car e)) -3) #\ )
188 (format-menu-description (cdr e) +width+ (+ len 7))))
189 alist-of-entries))))))
192 (define format-menu-description
193 (lambda (entry width offset)
194 (let loop ((lst (pregexp-split "\\s" entry)) (len 0) (acc '()))
196 (apply string-append (reverse! acc))
197 (let ((slen (+ 1 (string-length (car lst))))) ; +1 because of whitespace added later
198 (if (> (+ slen len) (- width offset))
199 (loop (cdr lst) 0 (cons
200 (format "~%~A ~A" ; start a new line
201 (make-string offset #\ ) ; the whitespace
204 (loop (cdr lst) (+ slen len) (cons (format " ~A"(car lst)) acc))))))))
207 (define format-sub-titles
208 (lambda (list-of-entries first-number-entry last-number-entry)
209 (let ((offset (or (list-index (lambda (e) (equal? e first-number-entry)) list-of-entries) 0))
210 (end (or (list-index (lambda (e) (equal? e last-number-entry)) list-of-entries)
211 (length list-of-entries))))
212 (map (lambda (entry ind)
214 (if (<= offset ind end)
215 (format "~A -" (- ind offset -1)) ;numbered entry
218 list-of-entries (number-list 0 1 list-of-entries)))))
220 ;;;; We number some sections first
222 ;; ntags is an alist => ((tag startcounter increment)
223 (define (number-nodes tree level ntags)
226 (let* ((vals (car ntags))
228 (start (second vals))
233 (lambda (node sublevel)
237 . ,(lambda (tag . entry)
238 `(,tag ,(cons sublevel level)
239 ,@(number-nodes entry (cons sublevel level) ntags))))
240 (*default* . ,(lambda x x))
241 (*text* . ,(lambda (tag s) s)))))
242 tree (number-list start inc tree)))))
245 ;;(transform->numbered faqsxml '(section article qandaset ((qandadiv 1 1) (qandaentry 0 1))))
246 (define transform->numbered
248 (let* ((rules (reverse rules))
251 (styles (map (lambda (tag) (cons tag (lambda x x))) (list-tail rules 2))))
254 `((*default* *preorder* . ,(lambda x x))
255 (*TOP* . ,(lambda x x))
258 . ,(lambda (tag . nodes)
259 (cons tag (number-nodes nodes '() rule)))))))))
262 ;;;; The main transform function
264 (define (transform sxml)
265 (let* ((sxml (transform->numbered
266 sxml '(section article qandaset ((qandadiv 1 1) (qandaentry 0 1)))))
267 (qandadivtitles (filter-sect (map second ((sxpath '(// qandadiv title)) sxml))))
268 (fqandadivtitles (format-sub-titles qandadivtitles "" ""))
269 (subtitles (filter-sect (append (map second ((sxpath '(// section title)) sxml))
271 (map second ((sxpath '(// glossary title)) sxml)))))
272 (fsubtitles (format-sub-titles subtitles +first-numbered-section+
273 +last-numbered-section+))
274 (questlevel (map second ((sxpath '(article section qandaset qandadiv qandaentry)) sxml)))
275 (up1 (cadar ((sxpath '(article articleinfo title)) sxml)))
277 ;;; ************************************************************
279 ;;; ************************************************************
282 ;;; ************************************************************
283 ;;; First the SXML special markers
284 ;;; ************************************************************
285 ;; *TOP* *PI* @ are markers from SXML
286 (*TOP* . ,(lambda (tag . x) x))
287 (*PI* . ,(lambda _ '()))
290 ;; Look for the example rule where we overwrite the *text* rule
291 ;; so code doesn't get mangled.
293 . ,(lambda (tag string)
295 ;; If nothing else matches
296 (*default* . ,(lambda x x))
297 ;;; ************************************************************
298 ;;; Now to the tags of our FAQ
299 ;;; ************************************************************
300 (article . ,(lambda (tag . sects)
301 (list (boilerplate up1) sects
302 +tag-for-gnus-faq-texi+)))
305 ((*default* . ,(lambda _ '()))
307 . ,(lambda (tag titel)
308 (let ((menucom (map (lambda (entry)
309 (let ((e (assoc entry +section-comments-alist+)))
312 (list (format-node '@section titel "" '() '())
313 (format-menu (map cons fsubtitles menucom)))))))
314 . ,(lambda (tag . info) info))
318 . ,(lambda (tag . text)
319 (cons (format "~%@subheading Abstract~%") text)))
322 . ,(lambda (tag titel)
323 (format-node '@subheading titel up1 subtitles fsubtitles))))
324 . ,(lambda (tag . entry) entry))
326 ;; Q&A well it's called FAQ isn't it?
327 (qandaset . ,(lambda (tag . x) x))
330 . ,(lambda (tag titel) titel)))
331 . ,(lambda (tag level titel . entries)
332 (let ((questions (map cadr entries))
333 (nlevel (filter (lambda (lvl) (eq? (car level) (cadr lvl))) questlevel)))
335 (format-node '@subsection titel up1 subtitles fsubtitles)
336 (format-menu (map (lambda (lvl quest)
337 (cons (format-q-level lvl)
338 (format-q-description quest)))
342 . ,(lambda (tag level question answer)
344 (filter (lambda (lvl) (eq? (cadr lvl) (cadr level))) questlevel))
345 (up (list-ref fqandadivtitles (- (cadr level) 1))))
347 (format-node "@subsubheading Question" level up nodes (map format-q-level nodes))
349 (question . ,(lambda (tag quest) quest))
351 . ,(lambda (tag . answ) (list* (format "~%@subsubheading Answer~%") answ)))
354 (para . ,(lambda (tag . x) (format-para x)))
355 (simpara . ,(lambda (tag . x) (cons (format "~%") x)))
358 ;; We rewrite para here because it plays here the role of an
361 . ,(lambda (tag lstitem)
362 (format "~%@itemize @bullet~%~A@end itemize~%" lstitem)))
365 . ,(lambda (tag item)
366 (format "~%@item~%~A~%" (trim-ws item)))))
367 . ,(lambda (tag . x) (string-join x "")))
371 ((title . ,(lambda _'())))
372 . ,(lambda (tag . terms)
373 (let ((titel (cadar ((sxpath '(article glossary title)) sxml))))
374 (cons (format-node '@subsection titel up1 subtitles fsubtitles)
375 (list (format "~%@table @dfn~%")
377 (format "~%@end table~%"))))))
378 (glossentry . ,(lambda (tag . entry) entry))
380 . ,(lambda (tag term)
381 (format "~%@item ~A" term)))
383 . ,(lambda (tag def) def))
386 ;; We rewrite the *text* rule so code stays the way it's writen.
389 . ,(lambda (tag exampl)
390 (normalize-example exampl))))
391 . ,(lambda (tag . exampl)
392 (format "~%@example~%~A~%@end example~%@noindent~%" (string-join exampl ""))))
395 ;; Here we are interested in the attributes, so we rewrite the @
396 ;; rule. If we find a value we look if it's an email or http
400 . ,(lambda (at val) val)))
401 . ,(lambda (tag uri name)
402 (if (pregexp-match "^http:|^ftp:" uri)
403 (if (equal? uri name)
404 (format "@uref{~A}" uri)
405 (format "@uref{~A, ~A}" uri name))
406 (format "@email{~A, ~A}" (substring uri 7) name))))
408 . ,(lambda (tag val) val))
413 (format "@samp{~A}" val)))
415 (pre-post-order sxml style-sheet)))
417 ;;;; We call main with infile and outfile as arguments
420 (with-output-to-file out
422 (call-with-input-file in
424 (SRV:send-reply (transform (ssax:xml->sxml port '()))))))
428 ;; coding: iso-8859-1
431 ;; arch-tag: cdd948f7-def9-4ea1-b5ae-b57c308097d7
432 ;;; xml2texi.scm ends here