Remove non-free old and crusty clearcase pkg
[packages] / xemacs-packages / gnus / texi / xml2texi.scm
1 ;;; xml2texi.scm --- Convert gnus-faq.xml to gnus-faq.texi
2 ;; Copyright (C) 2005  Free Software Foundation, Inc.
3
4 ;; Author:  Karl Pflästerer <sigurd@12move.de>
5 ;; Keywords: tools
6
7 ;; This file is not part of GNU Emacs.
8
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 3, or (at your option)
12 ;; any later version.
13
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.
18
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., 51 Franklin Street, Fifth Floor,
22 ;; Boston, MA 02110-1301, USA.
23
24 ;;; Commentary:
25 ;; 
26
27 ;;; Code:
28
29 (require (lib "ssax.ss" "ssax")
30          (lib "sxpath.ss" "ssax")
31          (lib "sxml-tree-trans.ss" "ssax")
32          (lib "pregexp.ss")
33          (lib "list.ss")
34          (lib "etc.ss")
35          (rename (lib "1.ss" "srfi") list-index list-index)
36          (rename (lib "13.ss" "srfi") string-join string-join))
37
38
39 ;;; Constants
40 ;; In and out; for convenience if we work from the REPL
41 (define +infile+ "gnus-faq.xml")
42 (define +outfile+ "gnus-faq.texi")
43
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")
50
51 ;; Which sections not to include; i.e. not to name a node.
52 (define +ignored-sections+ '("Frequently Asked Questions with Answers"))
53
54 ;; Names of menu entries and the corresponding descriptions (used in the
55 ;; main menu).
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.")))
68
69 ;; Where to break descriptions in menus
70 (define +width+ 72)
71
72 ;; The boilerplate text we include before the document
73 (define boilerplate
74     (lambda (titel)
75       (format
76        "\
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 @c~%\
82 @c Do not modify this file, it was generated from gnus-faq.xml, available from~%\
83 @c <URL:http://my.gnus.org/FAQ/>.~%\
84 @c~%\
85 @setfilename gnus-faq.info~%\
86 @settitle ~A~%\
87 @c %**end of header~%\
88 @c~%\
89 " titel)))
90
91 ;; Inserted right before the end of the file
92 (define +tag-for-gnus-faq-texi+
93     (format "\
94 ~%\
95 @ignore~%\
96 arch-\
97 tag: 64dc5692-edb4-4848-a965-7aa0181acbb8~%\
98 @end ignore~%\
99 "))
100
101 ;;; Little Helpers
102 ;; (a b c) -> (1 2 3)
103 (define (number-list start inc lst)
104     (let loop ((lst lst) (lvl start) (acc '()))
105          (if (null? lst)
106            (reverse acc)
107            (loop (cdr lst) (+ inc lvl) (cons lvl acc)))))
108
109 ;; Given an alist made of regexps and their replacements (key and value
110 ;; are in a proper list) returns a function which given a string
111 ;; replaces all occurences of the regexps (from left to right).
112 ;; ((re1 repl1) (re2 repl2)) -> str -> str
113 (define make-reg-replacer
114     (lambda (defalist)
115       (let ((allreg (string-join (map car defalist) "|")))
116         (lambda (str)
117           (if (and (string? str) (pregexp-match allreg str))
118             (let loop ((lst defalist) (str str))
119                  (if (null? lst)
120                    str
121                    (loop (cdr lst) (pregexp-replace* (caar lst) str (cadar lst)))))
122             str)))))
123
124 (define escape-texi
125     (make-reg-replacer '(("@"  "@@") ("{"  "@{") ("}"  "@}"))))
126
127 (define normalize
128     (compose escape-texi (make-reg-replacer `((,(format "~%\\s+") ,(format "~%"))))))
129
130 (define normalize-example
131     (compose escape-texi (make-reg-replacer '(("^\\s+|\\s+$" "")))))
132
133 (define trim-ws (make-reg-replacer '(("^\\s+|\\s+$" ""))))
134
135 (define filter-sect
136     (lambda (lst)
137       (filter (lambda (e) (not (member e +ignored-sections+))) lst)))
138
139 ;;;; Para
140 (define format-para
141     (lambda (list-of-entries)
142       (format "~%~A~%" (trim-ws (apply string-append list-of-entries)))))
143
144 ;;;; Questions
145 (define format-q-level
146     (lambda (level)
147       (apply format "[~A.~A]" (reverse level))))
148
149 (define format-q-description
150     (compose trim-ws (make-reg-replacer `((,(format "~%") " ")))))
151
152 ;;;; Building nodes
153 ;; curr-node up-node (list of nodes) (list of node names) ->
154 ;;   ((curr-node curr-name) (next next-name) (prev prev-name) up)
155 (define (find-prev-next-up curr up search-list name-list)
156     (do ((lst   search-list (cdr lst))
157          (rlst  name-list   (cdr rlst))
158          (prev  up   (car lst))
159          (prevn up   (car rlst)))
160         ((or (null? lst) (equal? (car lst) curr))
161          (values (cons curr (if (pair? rlst) (car rlst) curr))
162                  (if (and (pair? lst) (pair? (cdr lst))) ;next
163                    (cons (cadr lst) (cadr rlst))
164                    (cons "" ""))
165                  (cons prev prevn)
166                  up))))
167
168
169 (define (format-node section title up lst-of-nodes lst-of-names)
170     (if (member title +ignored-sections+)
171       ()
172       (call-with-values
173        (lambda () (find-prev-next-up title up lst-of-nodes lst-of-names))
174        (lambda (currn prevn nextn up)
175          (format "~%@node ~A~%~A ~A~%"
176                  (cdr currn) ;; (cdr prevn) (cdr nextn) up
177                  section ;; @subsection etc.
178                  (if (pair? title)
179                    (apply format "~A.~A" (reverse title))
180                    title))))))
181
182 ;;;; Building menus
183
184 (define format-menu
185     (lambda (alist-of-entries)
186       (let ((len (apply max (map (lambda (s) (string-length (car s))) alist-of-entries))))
187         (format "~%@menu~%~A@end menu~%"
188                 (apply string-append
189                        (map (lambda (e)
190                               (format "* ~A::~A~A~%"
191                                       (car e) ;the entry
192                                       (make-string (- len (string-length (car e)) -3) #\ )
193                                       (format-menu-description (cdr e) +width+ (+ len 7))))
194                             alist-of-entries))))))
195
196
197 (define format-menu-description
198     (lambda (entry width offset)
199       (let loop ((lst (pregexp-split "\\s" entry)) (len 0) (acc '()))
200            (if (null? lst)
201              (apply string-append (reverse! acc))
202              (let ((slen (+ 1 (string-length (car lst))))) ; +1 because of whitespace added later
203                (if (> (+ slen len) (- width offset))
204                  (loop (cdr lst) 0 (cons
205                                     (format "~%~A ~A"                 ; start a new line
206                                             (make-string offset #\ ) ; the whitespace
207                                             (car lst))
208                                     acc))
209                  (loop (cdr lst) (+ slen len) (cons (format " ~A"(car lst)) acc))))))))
210
211
212 (define format-sub-titles
213     (lambda (list-of-entries first-number-entry last-number-entry)
214       (let ((offset (or (list-index (lambda (e) (equal? e first-number-entry)) list-of-entries) 0))
215             (end (or (list-index (lambda (e) (equal? e last-number-entry)) list-of-entries)
216                      (length list-of-entries))))
217       (map (lambda (entry ind)
218              (format "FAQ ~A ~A"
219                      (if (<= offset ind end)
220                        (format "~A -" (- ind offset -1)) ;numbered entry
221                        "-")
222                      entry))
223            list-of-entries (number-list 0 1 list-of-entries)))))
224
225 ;;;; We number some sections first
226
227 ;; ntags is an alist => ((tag startcounter increment)
228 (define (number-nodes tree level ntags)
229     (if (null? ntags)
230       tree
231       (let* ((vals  (car ntags))
232              (ntag  (car vals))
233              (start (second vals))
234              (inc   (third vals))
235              (ntags (cdr ntags)))
236
237         (map
238          (lambda (node sublevel)
239            (pre-post-order
240             node
241             `((,ntag *preorder*
242                      . ,(lambda (tag . entry)
243                           `(,tag ,(cons sublevel level)
244                                  ,@(number-nodes entry (cons sublevel level) ntags))))
245               (*default* . ,(lambda x x))
246               (*text* . ,(lambda (tag s) s)))))
247          tree (number-list start inc tree)))))
248
249
250 ;;(transform->numbered faqsxml '(section article qandaset ((qandadiv 1 1) (qandaentry 0 1))))
251 (define transform->numbered
252     (lambda (sxml rules)
253       (let* ((rules (reverse rules))
254              (rule (car rules))
255              (ntag (cadr rules))
256              (styles (map (lambda (tag) (cons tag (lambda x x))) (list-tail rules 2))))
257   (pre-post-order
258    sxml
259      `((*default* *preorder* . ,(lambda x x))
260        (*TOP* . ,(lambda x x))
261        ,@styles
262        (,ntag *preorder*
263         . ,(lambda (tag . nodes)
264              (cons tag (number-nodes nodes '() rule)))))))))
265
266
267 ;;;; The main transform function
268
269 (define (transform sxml)
270     (let* ((sxml (transform->numbered
271                   sxml '(section article qandaset ((qandadiv 1 1) (qandaentry 0 1)))))
272            (qandadivtitles (filter-sect (map second ((sxpath '(// qandadiv title)) sxml))))
273            (fqandadivtitles (format-sub-titles qandadivtitles "" ""))
274            (subtitles (filter-sect (append (map second ((sxpath '(// section title)) sxml))
275                                            qandadivtitles
276                                            (map second ((sxpath '(// glossary title)) sxml)))))
277            (fsubtitles (format-sub-titles subtitles +first-numbered-section+
278                                           +last-numbered-section+))
279            (questlevel (map second ((sxpath '(article section qandaset qandadiv qandaentry)) sxml)))
280            (up1 (cadar ((sxpath '(article articleinfo title)) sxml)))
281
282 ;;; ************************************************************
283 ;;; The Style Sheet
284 ;;; ************************************************************
285            (style-sheet
286              `(
287 ;;; ************************************************************
288 ;;; First the SXML special markers
289 ;;; ************************************************************
290                ;; *TOP* *PI* @ are markers from SXML
291                (*TOP* . ,(lambda (tag . x) x))
292                (*PI* . ,(lambda _ '()))
293                (@ . ,(lambda _ ""))
294
295                ;; Look for the example rule where we overwrite the *text* rule
296                ;; so code doesn't get mangled.
297                (*text*
298                 . ,(lambda (tag string)
299                      (normalize string)))
300                ;; If nothing else matches
301                (*default* . ,(lambda x x))
302 ;;; ************************************************************
303 ;;; Now to the tags of our FAQ
304 ;;; ************************************************************
305                (article . ,(lambda (tag . sects)
306                              (list (boilerplate up1) sects 
307                                    +tag-for-gnus-faq-texi+)))
308
309                (articleinfo
310                 ((*default* . ,(lambda _ '()))
311                  (title
312                   . ,(lambda (tag titel)
313                        (let ((menucom (map (lambda (entry)
314                                              (let ((e (assoc entry +section-comments-alist+)))
315                                                (if e (cdr e) "")))
316                                            subtitles)))
317                          (list (format-node '@section titel "" '() '())
318                                (format-menu (map cons fsubtitles menucom)))))))
319                 . ,(lambda (tag . info) info))
320
321                ;; Sections
322                (abstract
323                 . ,(lambda (tag . text)
324                      (cons (format "~%@subheading Abstract~%") text)))
325                (section
326                 ((title
327                   . ,(lambda (tag titel)
328                        (format-node '@subheading titel up1 subtitles fsubtitles))))
329                 . ,(lambda (tag . entry) entry))
330
331                ;; Q&A well it's called FAQ isn't it?
332                (qandaset . ,(lambda (tag . x) x))
333                (qandadiv
334                 ((title
335                   . ,(lambda (tag titel) titel)))
336                 . ,(lambda (tag level titel . entries)
337                      (let ((questions (map cadr entries))
338                            (nlevel (filter (lambda (lvl) (eq? (car level) (cadr lvl))) questlevel)))
339                        (list*
340                         (format-node '@subsection titel up1 subtitles fsubtitles)
341                         (format-menu (map (lambda (lvl quest)
342                                             (cons (format-q-level lvl)
343                                                   (format-q-description quest)))
344                                           nlevel questions))
345                         entries))))
346                (qandaentry
347                 . ,(lambda (tag level question answer)
348                      (let ((nodes
349                              (filter (lambda (lvl) (eq? (cadr lvl) (cadr level))) questlevel))
350                            (up (list-ref fqandadivtitles (- (cadr level) 1))))
351                        (list*
352                         (format-node "@subsubheading Question" level up nodes (map format-q-level nodes))
353                         question answer))))
354                (question . ,(lambda (tag quest) quest))
355                (answer
356                 . ,(lambda (tag  . answ) (list* (format "~%@subsubheading Answer~%") answ)))
357
358                ;; Para
359                (para . ,(lambda (tag . x) (format-para x)))
360                (simpara . ,(lambda (tag . x) (cons (format "~%")  x)))
361
362                ;; Itemized lists.
363                ;; We rewrite para here because it plays here the role of an
364                ;; item marker
365                (itemizedlist
366                 . ,(lambda (tag lstitem)
367                      (format "~%@itemize @bullet~%~A@end itemize~%" lstitem)))
368                (listitem
369                 ((para
370                   . ,(lambda (tag item)
371                        (format "~%@item~%~A~%" (trim-ws item)))))
372                 . ,(lambda (tag . x) (string-join x "")))
373
374                ;; The glossary.
375                (glossary
376                 ((title . ,(lambda _'())))
377                 . ,(lambda (tag . terms)
378                      (let ((titel (cadar ((sxpath '(article glossary title)) sxml))))
379                        (cons (format-node '@subsection titel up1 subtitles fsubtitles)
380                              (list (format "~%@table @dfn~%")
381                                    terms
382                                    (format "~%@end table~%"))))))
383                (glossentry . ,(lambda (tag . entry) entry))
384                (glossterm
385                 . ,(lambda (tag term)
386                      (format "~%@item ~A" term)))
387                (glossdef
388                 . ,(lambda (tag def) def))
389
390                ;; Lisp examples
391                ;; We rewrite the *text* rule so code stays the way it's writen.
392                (programlisting
393                 ((*text*
394                   . ,(lambda (tag exampl)
395                        (normalize-example exampl))))
396                 . ,(lambda (tag . exampl)
397                      (format "~%@example~%~A~%@end example~%@noindent~%" (string-join exampl ""))))
398
399                ;; The link handling
400                ;; Here we are interested in the attributes, so we rewrite the @
401                ;; rule.  If we find a value we look if it's an email or http
402                ;; uri.
403                (ulink
404                 ((@
405                   . ,(lambda (at val) val)))
406                 . ,(lambda (tag uri name)
407                      (if (pregexp-match "^http:|^ftp:" uri)
408                          (if (equal? uri name)
409                              (format "@uref{~A}"  uri)
410                              (format "@uref{~A, ~A}"  uri name))
411                          (format "@email{~A, ~A}" (substring uri 7) name))))
412                (url
413                 . ,(lambda (tag val) val))
414
415                ;; userinput
416                (userinput
417                 . ,(lambda (tag val)
418                      (format "@samp{~A}" val)))
419                )))
420       (pre-post-order sxml style-sheet)))
421
422 ;;;; We call main with infile and outfile as arguments
423 (define main
424     (lambda (in out)
425       (with-output-to-file out
426         (lambda ()
427           (call-with-input-file in
428             (lambda (port)
429               (SRV:send-reply (transform (ssax:xml->sxml port '()))))))
430         'replace)))
431
432 ;; Local Variables:
433 ;; coding: iso-8859-1
434 ;; End:
435
436 ;; arch-tag: cdd948f7-def9-4ea1-b5ae-b57c308097d7
437 ;;; xml2texi.scm ends here