faq-conversion-program


The following program was used to convert the scheme-faq from its original DocBook sources to the format used by this wiki.

 ;; Convert Scheme FAQ from DocBook to WiLiKi wiki format 
 ;; by Jorgen Schäfer and Anton van Straaten, July 2005 
 ;; 
 ; imports for PLT - all portable libraries 
 (require (lib "ssax.ss" "ssax") 
          (lib "sxml-match.ss" "sxml-match") 
          (lib "1.ss" "srfi") 
          (lib "13.ss" "srfi")) 
  
 (define base-path      "~/dev/schemefaq/") 
 (define site-url       "http://community.schemewiki.org/") 
 (define file-extension ".xml") 
 (define page-prefix    "scheme-faq-") 
  
 (define xref-targets 
   ;  file name      xref targets in file 
   '((general        lisp uses emacs) 
     (implementation) 
     (language       dottedapp dyntop) 
     (macros         hygienic portablemacro macroellipses nestedmacro multidefine macrodata) 
     (misc           sexp sicp) 
     (programming    cont) 
     (standards      standards R6RS reference srfi implementations libraries ffi java specialimpl debuggers))) 
  
 (define source-files (map car xref-targets)) 
  
 (define (pagename->url pagename) 
   (format "~a?~a~a" site-url page-prefix pagename)) 
  
 ; super-inefficient due to xref-targets list format; doesn't matter 
 (define (xref-id->url id) 
   (call/cc 
    (lambda (return) 
      (for-each 
       (lambda (targets) 
         (if (memq id (cdr targets)) 
             (return (format "~a#~a" (pagename->url (car targets)) id)))) 
       xref-targets)))) 
  
 (define (file->sxml filename) 
   (call-with-input-file (string-append base-path (symbol->string filename) file-extension) 
     (lambda (port) (ssax:xml->sxml port '())))) 
  
 ; compress-spaces : replaces sequences of multiple whitespace characters with a single space or newline 
 ; easier to do this with a native regex procedure, but this is portable 
 (define (compress-spaces s) 
   (list->string 
    (reverse 
     (string-fold 
      (lambda (c t) 
        (let ((c-prev (if (null? t) #\Z (car t)))) 
          (if (char-whitespace? c) 
              (if (char-whitespace? c-prev) 
                  (if (and (char=? c #\newline) 
                           (not (char=? c-prev #\newline))) 
                      (cons c (cdr t)) 
                      t) 
                  (cons c t)) 
              (cons c t)))) 
      '() 
      s)))) 
  
 ; compress-whitespace : string ->string 
 ; Replaces sequences of multiple whitespace characters with a single space, 
 ; and eliminates any leading or trailing whitespace. 
 (define (compress-whitespace s) 
   (list->string 
    (reverse 
     (string-fold 
      (lambda (c t) 
        (if (char-whitespace? c) 
            (if (or (null? t) 
                    (char-whitespace? (car t))) 
                t 
                (cons #\space t)) 
            (cons c t))) 
      '() 
      s)))) 
  
 ; convert-markup : match markup found in para bodies and convert to wiliki format 
 ; a para body is a list of strings and sxml. 
 (define (convert-markup body . compress?) 
   (let ((compress-spaces? (or (null? compress?) (car compress?)))) 
     (apply 
      string-append 
      (map 
       (lambda (frag) 
         (sxml-match frag 
                     ; match cases ordered alphabetically 
                     [(application ,text) 
                      (format "{{{~a}}}" (compress-whitespace text))] 
                     [(b ,text) 
                      (format "'''~a'''" text)] 
                     [(blockquote (para ,text)) 
                      (format "~n<<<~n~a~n>>>~n" text)] 
                     [(br) 
                      "%~"] 
                     [(citation ,text) 
                      (format "[~a]" (compress-spaces text))] 
                     [(citetitle ,text) 
                      (format "'''~a'''" text)] 
                     [(command ,text) 
                      (format "{{{~a}}}" (compress-spaces text))] 
                     [(emphasis ,text) 
                      (format "''~a''" text)] 
                     [(function ,text) 
                      (format "{{{~a}}}" (compress-spaces text))] 
                     [(informaltable (tgroup (thead (row (entry ,head1) (entry ,head2))) 
                                             (tbody (row (entry ,body1 ...) 
                                                         (entry ,body2 ...)) 
                                                    ...))) 
                      (string-append (format "|| '''~a''' || '''~a''' ||\n" head1 head2) 
                                     (format "|| ~a || ~a ||\n" 
                                             (convert-markup body1) 
                                             (convert-markup body2)) 
                                     ...)] 
                     [(itemizedlist (listitem (para ,text ...)) ...) 
                      (string-append (format "- ~a\n" (convert-body text)) 
                                     ...)] 
                     [(itemizedlist 
                       (listitem 
                        (formalpara 
                         (title ,title ...) 
                         (para ,body ...) 
                         ...)) 
                       ...) 
                      (string-append 
                       (format ":~a:~n~a\n" (convert-header title) 
                               (string-append (compress-whitespace (convert-para body)) 
                                              ...)) 
                       ...)] 
                     [(literal ,text) 
                      (format "{{{~a}}}" (compress-whitespace text))] 
                     [(programlisting ,code ...) 
                      (format "~n{{{scheme~n~a~n}}}~n" (convert-markup code #f))] ; code may have markup, but don't compress spaces 
                     [(quote ,text ...) 
                      (format "\"~a\"" (convert-markup text))] 
                     [(remark ,text) 
                      (format "'''~a'''" (compress-whitespace text))] 
                     ; only occurs in program-listing; wiki doesn't support in conjunction with scheme highlighting 
                     [(replaceable ,text) 
                      text] 
                     [(row (entry (application ,name)) (entry (ulink (@ (url ,url))))) 
                      (format "- [~a ~a]~n" url name)] 
                     [(simplelist (member ,text ...) ...) 
                      (string-append 
                       (format "- ~a~n" (convert-para text)) 
                       ...)] 
                     [(superscript ,text) 
                      (format "^~a" text)] 
                     [(ulink (@ (url ,url)) ,body ...) 
                      (let ((body (convert-body body))) 
                        (if body 
                            (format "[~a ~a]" url body) 
                            (format "[~a]" url)))] 
                     [(xref (@ (linkend ,id))) 
                      (format "[~a here]" (xref-id->url (string->symbol id)))] 
                     [,other 
                       (if (string? other) 
                           (if compress-spaces? 
                               (compress-spaces other) 
                               (format "~a" other)) 
                           (begin 
                             (printf "Markup not handled: ~a~n" other) 
                             (format "~a" other)))])) 
       body)))) 
    
 (define (convert-body frags) 
   (if (null? frags) 
       #f 
       (convert-markup frags))) 
  
 (define (convert-para body) 
   (string-append 
    (convert-markup body) 
    "\n\n")) 
  
 (define (convert-header body) 
   (compress-whitespace 
    (convert-markup body))) 
  
 ; extract-para-bodies : extract bodies from paras 
 ; Converts a list of paras to a list of body lists 
 ; each body list is a list of text or sxml values 
 (define (extract-para-bodies paras) 
   (map 
    (lambda (sxml) 
      (sxml-match sxml 
        [(para ,body ...) body] 
        [(remark ,body ...) (cons "WTF is this doing here? " body)] 
        [,else (error "expected PARA - found: " else)])) 
    paras)) 
  
 ; convert-using : convert the specified paras using proc 
 ; Extracts bodies from the specified paras, converts each body with proc, 
 ; and turns the resulting list of strings into a single string 
 (define (convert-using proc paras) 
   (apply string-append (map proc (extract-para-bodies paras)))) 
  
 (define (convert-qanda sxml) 
   (sxml-match sxml 
     [(qandaentry 
       (question (@ (id (,id #f))) ,question ...) 
       (answer ,answer ...)) 
      (format "~a*** ~a~n~a~n" 
              (if id (format "[[$$label ~a]]~n" id) "") 
              (convert-using convert-header question) ; probably overkill for questions, but works 
              (convert-using convert-para answer))] 
     ; match question without answer 
     [(qandaentry 
       (question (@ (id (,id #f))) ,question ...)) 
      (format "~a*** ~a~n" 
              (if id (format "[[$$label ~a]]~n" id) "") 
              (convert-using convert-header question))])) ; probably overkill for questions, but works 
  
 (define (sxml->faq sxml) 
   (sxml-match sxml 
     [(qandadiv 
       (title ,title) 
       ,entry 
       ...) 
      (list 
       (format "** ~a~n~n" title) 
       (convert-qanda entry) 
       ...)] 
     [,else (error "expected QANDADIV - found" else)])) 
  
 (define (faq-page pagename) 
   (printf "Processing ~a~n" pagename) 
   (apply 
    string-append 
    `("* Scheme Frequently Asked Questions\n" 
      "The material on this page is licensed under the GNU Free Documentation License; either version 2, or (at your option) any later version. See [[scheme-faq-license]] for more information.\n\n" 
      ; link to all pages except current one 
      ,@(cdr 
         (append-map 
          (lambda (page) 
            (if (eq? page pagename) 
                (list " | " (format "'''~a'''" page)) 
                (list " | " (format "[~a ~a]"  (pagename->url page) page)))) 
          source-files)) 
      "\n" 
      ,@(sxml->faq (cadr (file->sxml pagename))) 
      "----\n[[category-scheme-faq]]\n"))) 
  
 (define faq-sources (map faq-page source-files)) 
 (display (list-ref faq-sources 6)) ; display a page 
 }}}  
  

category-code