source: project/release/4/qwiki/trunk/qwiki-sxml.scm @ 15505

Last change on this file since 15505 was 15505, checked in by Ivan Raikov, 10 years ago

Some fixes to the qwiki LaTeX driver

File size: 20.4 KB
Line 
1;;
2;; qwiki-sxml - SXML rules and tools for qwiki
3;;
4;; Copyright (c) 2009 Peter Bex and Ivan Raikov
5;;
6;;  Redistribution and use in source and binary forms, with or without
7;;  modification, are permitted provided that the following conditions
8;;  are met:
9;;
10;;  - Redistributions of source code must retain the above copyright
11;;  notice, this list of conditions and the following disclaimer.
12;;
13;;  - Redistributions in binary form must reproduce the above
14;;  copyright notice, this list of conditions and the following
15;;  disclaimer in the documentation and/or other materials provided
16;;  with the distribution.
17;;
18;;  - Neither name of the copyright holders nor the names of its
19;;  contributors may be used to endorse or promote products derived
20;;  from this software without specific prior written permission.
21;;
22;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
23;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
24;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
25;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
26;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
27;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
29;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
30;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
31;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34;;  POSSIBILITY OF SUCH DAMAGE.
35
36(provide 'qwiki-sxml)
37
38(module qwiki-sxml
39
40  (qwiki-html-transformation-rules
41   qwiki-LaTeX-transformation-rules)
42
43(import chicken scheme)
44
45(use posix srfi-1 srfi-13 data-structures regex )
46(use sxml-transforms doctype uri-generic)
47
48
49(define lookup-def 
50  (lambda (k lst . rest)
51    (let-optionals rest ((default #f))
52      (alist-ref k lst eq? default))))
53
54
55;;;;
56;;;;  HTML stylesheet
57;;;;
58
59(define (qwiki-make-html-header head-parms)
60  `(head
61    (title ,(or (lookup-def 'title head-parms) "qwiki"))
62    (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
63    (meta (@ (http-equiv "Content-Type") 
64             (content ,(lookup-def 'Content-Type head-parms 
65                                   "text/html; charset=UTF-8"))))
66    ,(let ((style  (lookup-def 'style head-parms))
67           (print-style  (lookup-def 'print-style head-parms)))
68       (list (if style `(link (@ (rel "stylesheet") (type "text/css") (href ,style))) '())
69             (if print-style `(link (@ (rel "stylesheet") (type "text/css") 
70                                       (media "print")  (href ,print-style))) '())))
71    ,(map
72      (lambda (key)
73        (let ((val (lookup-def key head-parms )))
74          (and val
75               `(meta (@ (name ,(symbol->string key)) (content ,val))))))
76      '(description Author keywords
77                    Date-Revision-yyyymmdd Date-Creation-yyyymmdd))))
78
79(define (internal-link str)
80  (string-substitute* (string-downcase str) '(("[^A-Za-z0-9_ \t-]" . "")
81                                              ("[ \t]+" . "-"))))
82
83(define (qwiki-html-transformation-rules content)
84  `((
85     (@ *preorder* . ,(lambda element element))
86
87     (Header
88      *macro*
89      . ,(lambda (tag . headers)
90           (qwiki-make-html-header headers)))
91
92     (Section
93      *macro*
94      . ,(lambda (tag level head-word . elems)
95           `((,(string->symbol (string-append "h" (number->string level)))
96              (@ (id ,(internal-link head-word)))
97              ,head-word ,elems)
98             )))
99
100     (definition
101       *macro*
102       . ,(lambda (_ type . contents)
103            `(span (@ (class ,(conc "definition " type)))
104                   (em "[" ,(symbol->string type) "]")
105                   (type ,@contents)
106                   (br))))
107     
108     (special
109      *macro*
110      . ,(lambda (tag name arg)
111           `(,(string->symbol (string-upcase (symbol->string name))) ,arg)))
112
113     (preformatted
114      . ,(lambda (tag . elems)
115           `(pre (tt ,elems))))
116         
117     (type
118      *macro*
119      . ,(lambda (tag . terms)
120           `(tt ,@terms)))
121
122     (wiki *macro* . ,(lambda (tag href . contents)
123                        `(a (@ (class "wiki-page") (href ,href))
124                            ,(if (pair? contents) contents
125                                 href))))
126
127     (url *macro* . ,(lambda (tag href . contents)
128                       `(a (@ (class "external") (href ,href))
129                           ,(if (pair? contents) contents
130                                href))))
131
132   
133     ;; Maybe this should be done in multiple steps to make it more "hookable"
134     (history
135      *macro* . ,(lambda (history items)
136                   `(table
137                     (tr (th "revision")
138                         (th "author")
139                         (th "date")
140                         (th "description"))
141                     ,@(map (lambda (item)
142                              `(tr (td (url ,(string-append
143                                              "?action=show&rev="
144                                              (number->string (car item)))
145                                            ,(car item)))
146                                   (td ,(cadr item))
147                                   (td ,(time->string (caddr item)))
148                                   (td ,(cadddr item))))
149                            items))))
150     (page-specific-links
151      *macro* . ,(lambda _
152                   `(ul (@ (class "page-specific-links"))
153                        (li (url "?action=show" "show"))
154                        (li (url "?action=edit" "edit"))
155                        (li (url "?action=history" "history")))))
156
157     ,@alist-conv-rules
158     )
159    (
160     (wiki-page
161      . ,(lambda (tag . elems)
162           (list
163            xhtml-1.0-strict
164            "<html xmlns=\"http://www.w3.org/1999/xhtml\">"
165            elems
166            "</html>")))
167
168     (TOC ;; Re-scan the content for "Section" tags and generate
169      . ,(lambda (tag . rest) ;; the table of contents
170           (let ((sections
171                  (pre-post-order content
172                                  `(
173                                    (Section ;; (Section level "content ...")
174                                     ((*text* . ,(lambda (tag str) str)))
175                                     . ,(lambda (tag level head-word . elems)
176                                          (append
177                                           (list "<li><a href=\"#"
178                                                 (internal-link head-word)
179                                                 "\">" head-word "</a>")
180                                           (if (null? elems)
181                                               elems
182                                               (list "<ul>" elems "</ul>"))
183                                           (list "</li>")))
184                                     )
185                                    (*default*
186                                     . ,(lambda (tag . elems) elems))
187                                   
188                                    (*text* . ,(lambda (trigger str) (list)))))))
189             (list "<ul id=\"toc\">"
190                   sections 
191                   "</ul>"))))
192
193     (verbatim
194      *preorder*
195      . ,(lambda (tag . contents)
196           contents))
197
198     ,@universal-conversion-rules)
199    )
200  )
201
202;;;;
203;;;;  LaTeX stylesheet
204;;;;
205
206(define nl (list->string (list #\newline)))
207
208; Given a string, check to make sure it does not contain characters
209; such as '_' or '&' that require encoding. Return either the original
210; string, or a list of string fragments with special characters
211; replaced by appropriate "escape sequences"
212
213(define string->goodTeX
214  (make-char-quotator
215   '((#\# . "\\#") (#\$ . "\\$") (#\% . "\\%") (#\& . "\\&")
216     (#\~ . "\\textasciitilde{}") (#\_ . "\\_") (#\^ . "\\^")
217     (#\\ . "$\\backslash$") (#\{ . "\\{") (#\} . "\\}"))))
218
219(define LaTeX-packages
220  (make-parameter (list)))
221
222(define (add-LaTeX-package! package-name . options)
223  (let ((packages (LaTeX-packages)))
224    (if (not (assoc package-name packages))
225        (LaTeX-packages (cons (list package-name options)
226                              packages)))))
227
228;;
229;; Place the 'body' within the LaTeX environment named 'env-name'
230;; options is a string or a list of strings that specify optional or
231;; mandatory parameters for the environment
232;; Return the list of fragments.
233;;
234(define (in-LaTeX-env env-name options body)
235  (list "\\begin{" env-name "}" options nl
236        body
237        "\\end{" env-name "}" nl))
238
239(define (LaTeX-use-package package-name . options)
240  (list "\\usepackage{" package-name "}" 
241        (if (pair? options) (list "[" options "]") '()) 
242        nl))
243
244(define (LaTeX-label str)
245  (define (f0 str)
246    (let* ((cs   (string-split str " "))
247           (ins  (map (lambda (s) 
248                        (let ((s (string-downcase s)))
249                          (string-copy s 0 (min 3 (- (string-length s) 1))))) cs)))
250      (string-concatenate ins)))
251  (cond ((pair? str)   (string-concatenate (map f0 str)))
252        (else          (f0 (->string str)))))
253
254(define (qwiki-LaTeX-transformation-rules content)
255  `((
256                        ; General conversion rules
257     (@
258      ((*default*       ; local override for attributes
259        . ,(lambda (attr-key . value) (cons attr-key value))))
260      . ,(lambda (trigger . value) (list '@ value)))
261
262     (*default* . ,(lambda (tag . elems) (cons (->string tag) elems)))
263
264     (*text* . ,(lambda (trigger str) 
265                  (if (string? str) (string->goodTeX str) str)))
266
267     (n_                ; a non-breaking space
268      . ,(lambda (tag . elems)
269           (list "~" elems)))
270
271     (wiki-page
272      . ,(lambda (tag . elems)
273             (list
274              "\\documentclass[12pt]{article}" nl
275              "\\usepackage[left=3cm]{geometry}" nl
276             
277              (map (lambda (p) (LaTeX-use-package (car p) (cadr p)))
278                   (LaTeX-packages)) nl
279                     
280             "%%%%%%%%%%%%%%%%%%%%%%%%%% Textclass specific LaTeX commands." nl
281             " \\newenvironment{lyxcode}" nl
282             "   {\\begin{list}{}{" nl
283             "     \\raggedright" nl
284             "     \\setlength{\\itemsep}{-5pt}" nl
285             "     \\setlength{\\parsep}{-3pt}" nl
286             "     \\normalfont\\ttfamily}%" nl
287             "    \\item[]}" nl
288             "   {\\end{list}}" nl
289
290            "\\makeatother" nl
291            "\\sloppy" nl
292
293            "\\newcommand{\\minitab}[2][l]{\\begin{tabular}{#1}#2\\end{tabular}}" nl
294
295            nl
296            elems
297            ))
298      )
299
300     (Header           
301      *preorder*
302      . ,(lambda (tag . headers) '()))
303
304     (Section   ; (Section level "content ...")
305      . ,(lambda (tag level head-word . elems)
306           (list #\\
307                 (case level
308                   ((1 2) "section")
309                   ((3) "subsection")
310                   ((4) "subsubsection")
311                   (else (error "unsupported section level: " level)))
312                 "{" head-word elems "}"  nl
313                 (if (= level 1) 
314                     (list "\\label{" (LaTeX-label head-word)  "}") 
315                     (list)) nl)))
316
317     (TOC . ,(lambda (tag . elems) (list nl "\\tableofcontents{}" nl)))
318
319     (body
320      . ,(lambda (tag . elems)
321           (in-LaTeX-env "document" '() 
322                       (list elems)
323                       )))
324
325     (url 
326      . ,(lambda (tag href . contents) 
327           (add-LaTeX-package! 'url)
328           (if (null? contents)
329               (list "\\url{" href "}")
330               (list contents " (\\url{" href "})"))))
331
332     (wiki 
333      *macro* 
334      . ,(lambda (tag href . contents)
335           (add-LaTeX-package! 'hyperref "hypertex")
336           `((tex "\\hyperref[" ,(LaTeX-label href) "]")
337             (tex "{") 
338             ,(if (null? contents) href (or contents href)) 
339             (tex "}"))))
340
341     ; Standard typography
342     (small
343      . ,(lambda (tag . elems)
344           (list "{\\small{}" elems "}")))
345
346     (strong
347      . ,(lambda (tag . elems)
348           (list "{\\rmfamily\\bfseries{}" elems "}")))
349
350     (type
351      . ,(lambda (tag . elems)
352           (list "{\\ttfamily{}" elems "}")))
353
354     (em
355      . ,(lambda (tag . elems)
356           (list "\\emph{" elems "}")))
357
358     (p
359      . ,(lambda (tag . elems)
360           (list elems nl nl)))
361
362     (div
363      . ,(lambda (tag . elems)
364           (in-LaTeX-env "trivlist" '()  (list "\\item{}" elems))))
365
366     (br
367      . ,(lambda (tag)
368           (list "\\\\ ")))
369
370     (hr . ,(lambda (tag) 
371              (list "\\begin{center}" 
372                    "\\rule{0.8\\textwidth}{0.4pt}" 
373                    "\\end{center}" nl)))
374
375     (indent
376       . ,(lambda (tag) "\\indent{}"))
377
378     (ul                        ; Unnumbered lists
379      . ,(lambda (tag . elems)
380           (in-LaTeX-env "itemize" '() elems)))
381
382     (ol                        ; Numbered lists
383      . ,(lambda (tag . elems)
384           (in-LaTeX-env "enumerate" '() elems)))
385
386     (li
387      . ,(lambda (tag . elems)
388           (list "\\item " elems nl)))
389
390     (dl                        ; Definition list
391
392      ;; dl and dt are translated to procedures that take one argument:
393      ;; previously set label: list of fragments or #f if none
394      ;; The procedure returns a pair: (new-label . generate-fragments)
395      ;; Initially, label is #f
396
397      ((dt                      ;; The item title
398        . ,(lambda (tag . elems)
399            (lambda (label)
400              (cons elems       ;; elems become the new label
401                    (if label   ;; the label was set: we've seen dt without dd
402                        (list "\\item [" label "]" nl) ; empty body
403                        '())))))
404       (dd                      ;; The item body
405        . ,(lambda (tag . elems)
406            (lambda (label)
407              (cons #f          ;; consume the existing label
408                    (list "\\item [" (or label "") "] " elems nl)))))
409       )
410      . ,(lambda (tag . procs)  ;; execute procs generated by dt/dd
411          (let loop ((procs (flatten procs)) (label #f) (accum '()))
412            (if (null? procs) (in-LaTeX-env "description" '() (reverse accum))
413                (let ((result ((car procs) label)))
414                  (loop (cdr procs) (car result) (cons (cdr result) accum))))))
415      )
416       
417
418     (special
419      *macro*
420      . ,(lambda (tag name arg)
421           `(,(string->symbol (string-upcase (symbol->string name))) ,arg)))
422
423     (definition
424       . ,(lambda (_ type . elems)
425            (in-LaTeX-env "description" '()
426               (list "{\\ttfamily{}" elems "}"))))
427
428     (blockquote
429      . ,(lambda (tag . elems)
430           (in-LaTeX-env "quote" '() elems)))
431
432     (preformatted
433      *macro*
434      . ,(lambda (tag . elems)
435           `(verbatim ,elems)))
436         
437
438     (verbatim  ; set off pieces of code: one or several lines
439      ((*text* . ; Different quotation rules apply within a "verbatim" block
440               ,(let ((string->goodTeX-in-verbatim
441                      (make-char-quotator
442                       '((#\space "~")  ; All spaces are "hard"
443                         (#\# . "\\#") (#\$ . "\\$") (#\% . "\\%")
444                         (#\& . "\\&") (#\~ . "\\textasciitilde{}")
445                         (#\_ . "\\_") (#\^ . "\\^")
446                         (#\\ . "$\\backslash$") (#\{ . "\\{")
447                         (#\} . "\\}")))))
448                  (lambda (trigger str) 
449                    (if (string? str) (string->goodTeX-in-verbatim str) str)))
450               )
451        (strong
452          . ,(lambda (tag . elems)
453               (list "\\textrm{\\small\\bfseries{}" elems "}")))
454        )
455      . ,(lambda (tag . lines)
456           (in-LaTeX-env "lyxcode" '()
457                       (map (lambda (line) 
458                              (list (if (equal? line "") "~" line) 
459                                    "\\\\" nl))
460                            lines))))
461
462      (small-verbatim   ; set off pieces of code: one or several lines
463      ((*text* . ; Different quotation rules apply within a "verbatim" block
464               ,(let ((string->goodTeX-in-verbatim
465                      (make-char-quotator
466                       '((#\space "~")  ; All spaces are "hard"
467                         (#\# . "\\#") (#\$ . "\\$") (#\% . "\\%")
468                         (#\& . "\\&") (#\~ . "\\textasciitilde{}")
469                         (#\_ . "\\_") (#\^ . "\\^")
470                         (#\\ . "$\\backslash$") (#\{ . "\\{")
471                         (#\} . "\\}")))))
472                  (lambda (trigger str) 
473                    (if (string? str) (string->goodTeX-in-verbatim str) str)))
474               ))
475      . ,(lambda (tag . lines)
476           (in-LaTeX-env "list" '()
477             (list "{}"
478               "{%\\raggedright" nl
479                "\\setlength{\\rightmargin}{-15pt}" nl
480                "\\setlength{\\itemsep}{-12pt}" nl
481                "\\setlength{\\parsep}{-4pt}" nl
482                "\\small\\ttfamily}%" nl
483               (map (lambda (line) 
484                      (list "\\item  "
485                        (if (equal? line "") "~" line)
486                        "\\\\" nl))
487                 lines)))))
488
489     (table
490                ; verbatim mode does not work in tabular <deep sigh> ...
491                ; we have to emulate
492      ((verbatim       
493        ((*text* . ; Different quotation rules apply within a "verbatim" block
494               ,(let ((string->goodTeX-in-verbatim
495                      (make-char-quotator
496                       '((#\space . "~")        ; All spaces are "hard"
497                         (#\newline . "\\\\\n") 
498                         (#\# . "\\#") (#\$ . "\\$") (#\% . "\\%")
499                         (#\& . "\\&") (#\~ . "\\textasciitilde{}")
500                         (#\_ . "\\_") (#\^ . "\\^")
501                         (#\\ . "$\\backslash$") (#\{ . "\\{")
502                         (#\} . "\\}")))))
503                  (lambda (trigger str) 
504                    (if (string? str) (string->goodTeX-in-verbatim str) str)))
505               ))
506        . ,(lambda (tag . lines)       
507             (map (lambda (line) (list "\\ttfamily\\small " nl line "\\\\"))
508                  lines)))
509       (tr              ; elems ::= [(@ attrib ...)] td ...
510                        ; we disregard all attributes of a row
511                        ; The result is (td ...)
512        . ,(lambda (tag . elems)
513             (if (and (pair? elems) (pair? (car elems))
514                      (eq? '@ (caar elems)))
515                 (cdr elems)
516                 elems)))
517
518       (td              ; elems ::= [(@ attrib ...)] body ...
519                        ; we're only interested in (align "alignment") attr
520                        ; and the (colspan "number") attr
521                        ; The result is ("alignment" colspan body ...)
522                        ; where "alignment" will be #\l, #\c, #\r
523                        ; (#\l if not given); colspan is the integer
524        . ,(lambda (tag . elems)
525             (define (get-alignment attrs)
526               (cond
527                ((assq 'align attrs) =>
528                 (lambda (attr)
529                   ;(cerr "align attr: " attr nl)
530                   (cond
531                    ((string-ci=? (cadr attr) "left") #\l)
532                    ((string-ci=? (cadr attr) "right") #\r)
533                    ((string-ci=? (cadr attr) "center") #\c)
534                    (else (error "wrong alignment attribute: " attr)))))
535                (else #\l)))
536             (define (get-colspan attrs)
537               (cond
538                ((assq 'colspan attrs) =>
539                 (lambda (attr)
540                   (let ((val (string->number (cadr attr))))
541                     (assert val)
542                     val)))
543                (else 1)))
544             (if (and (pair? elems) (pair? (car elems))
545                      (eq? '@ (caar elems)))
546                 (cons (get-alignment (cadar elems))
547                   (cons (get-colspan (cadar elems))
548                         (cdr elems)))
549                 (cons (get-alignment '())
550                   (cons (get-colspan '())
551                        elems)))))
552
553       (th              ; elems ::= [(@ attrib ...)] body ...
554                        ; we're only interested in (align "alignment") attr
555                        ; and the (colspan "number") attr
556                        ; The result is ("alignment" colspan body ...)
557                        ; where "alignment" will be #\l, #\c, #\r
558                        ; (#\c if not given); colspan is the integer
559        . ,(lambda (tag . elems)
560             (define (get-alignment attrs)
561               (cond
562                ((assq 'align attrs) =>
563                 (lambda (attr)
564                   ;(cerr "align attr: " attr nl)
565                   (cond
566                    ((string-ci=? (cadr attr) "left") #\l)
567                    ((string-ci=? (cadr attr) "right") #\r)
568                    ((string-ci=? (cadr attr) "center") #\c)
569                    (else (error "wrong alignment attribute: " attr)))))
570                (else #\c)))
571             (define (get-colspan attrs)
572               (cond
573                ((assq 'colspan attrs) =>
574                 (lambda (attr)
575                   (let ((val (string->number (cadr attr))))
576                     (assert val)
577                     val)))
578                (else 1)))
579             (if (and (pair? elems) (pair? (car elems))
580                      (eq? '@ (caar elems)))
581                 (cons (get-alignment (cadar elems))
582                   (cons (get-colspan (cadar elems))
583                         (cdr elems)))
584                 (cons (get-alignment '())
585                   (cons (get-colspan '())
586                        elems)))))
587       )
588                        ; (table [(@ attrib ...)] tr ...
589      . ,(lambda (tag row . rows)
590           (let*-values
591            (((attrs rows)
592              (if (and (pair? row) (eq? '@ (car row)))
593                  (values (cadr row) rows)
594                  (values '() (cons row rows))))
595             ((border?)
596              (cond
597               ((assq 'border attrs) =>
598                (lambda (border-attr) (not (equal? "0" (cadr border-attr)))))
599               (else #f)))
600             ((caption label table-type table-alignment)
601              (apply values
602                     (map (lambda (name)
603                            (cond
604                             ((assq name attrs) => cadr)
605                             (else #f)))
606                          '(caption key table-type align))))
607             (dummy (assert (pair? rows))) ; at least one row must be given
608             ((ncols) (length (car rows)))
609             ((tex-cols)
610              (let ((col-codes
611                     (map (lambda (_) (if border? "l|" "l")) (car rows))))
612                (if border?
613                    (apply string-append 
614                           (cons "|" col-codes))
615                    (apply string-append col-codes))))
616             )
617            (list
618              (list
619               (and (equal? table-alignment "center")
620                    "\\centering")
621               (in-LaTeX-env "tabular"
622                             (list "{" ; "@{\\extracolsep{-25pt}}"
623                                   tex-cols "}")
624                (list (and border? "\\hline\n")
625                  (map
626                   (lambda (row)
627                     (list
628                      (intersperse
629                       (map
630                        (lambda (col)
631                          (apply
632                           (lambda (alignment span . data)
633                             (if (> span 1)
634                                 (list "\\multicolumn{" span "}{" alignment "}{"
635                                       "\\minitab[" alignment "]{"
636                                       data "}}")
637                                 (list "\\minitab[" alignment "]{" data "}")))
638                           col))
639                        row)
640                       " & ")
641                      "\\\\" (and border? "\\hline") nl))
642                   rows)
643                  nl))
644;              (and caption (list "\\caption{"
645;                                 (and label
646;                                      (list "\\label{" label "}"))
647;                                 caption "}"))
648               ))
649            )))
650
651
652     (history . ,(lambda (history items) (list)))
653     (page-specific-links . ,(lambda _ (list)))
654
655     (tex      ; raw tex expression
656       *preorder*
657       . ,(lambda (tag . str) str))
658           
659     )))
660
661
662)
Note: See TracBrowser for help on using the repository browser.