cgit.sxemacs.org Git - packages/blob - 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