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

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

added initial LaTeX output driver for qwiki

File size: 19.8 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 (qwiki-LaTeX-transformation-rules content)
245  `((
246                        ; General conversion rules
247     (@
248      ((*default*       ; local override for attributes
249        . ,(lambda (attr-key . value) (cons attr-key value))))
250      . ,(lambda (trigger . value) (list '@ value)))
251
252     (*default* . ,(lambda (tag . elems) (cons (->string tag) elems)))
253
254     (*text* . ,(lambda (trigger str) 
255                  (if (string? str) (string->goodTeX str) str)))
256
257     (n_                ; a non-breaking space
258      . ,(lambda (tag . elems)
259           (list "~" elems)))
260
261     (wiki-page
262      . ,(lambda (tag . elems)
263             (list
264              "\\documentclass[12pt]{article}" nl
265              "\\usepackage[left=3cm]{geometry}" nl
266             
267              (map (lambda (p) (LaTeX-use-package (car p) (cadr p)))
268                   (LaTeX-packages)) nl
269                     
270             "%%%%%%%%%%%%%%%%%%%%%%%%%% Textclass specific LaTeX commands." nl
271             " \\newenvironment{lyxcode}" nl
272             "   {\\begin{list}{}{" nl
273             "     \\raggedright" nl
274             "     \\setlength{\\itemsep}{-5pt}" nl
275             "     \\setlength{\\parsep}{-3pt}" nl
276             "     \\normalfont\\ttfamily}%" nl
277             "    \\item[]}" nl
278             "   {\\end{list}}" nl
279
280            "\\makeatother" nl
281            "\\sloppy" nl
282
283            "\\newcommand{\\minitab}[2][l]{\\begin{tabular}{#1}#2\\end{tabular}}" nl
284
285            nl
286            elems
287            ))
288      )
289
290     (Header           
291      *preorder*
292      . ,(lambda (tag . headers) '()))
293
294     (Section   ; (Section level "content ...")
295      . ,(lambda (tag level head-word . elems)
296           (list #\\
297                 (case level
298                   ((1 2) "section")
299                   ((3) "subsection")
300                   ((4) "subsubsection")
301                   (else (error "unsupported section level: " level)))
302                 "{" head-word elems "}" nl)))
303
304     (TOC . ,(lambda (tag . elems) (list nl "\\tableofcontents{}" nl)))
305
306     (body
307      . ,(lambda (tag . elems)
308           (in-LaTeX-env "document" '() 
309                       (list elems)
310                       )))
311
312     (url 
313      . ,(lambda (tag href . contents) 
314           (add-LaTeX-package! 'url)
315           (if (null? contents)
316               (list "\\url{" href "}")
317               (list contents " (\\url{" href "})"))))
318
319     (wiki 
320      *macro* 
321      . ,(lambda (tag href . contents)
322           (add-LaTeX-package! 'hyperref "hypertex")
323           `("\\href{" (href ,href) "}"
324             "{" ,(if (pair? contents) contents href) "}")))
325
326     ; Standard typography
327     (em
328      . ,(lambda (tag . elems)
329           (list "\\emph{" elems "}")))
330
331     (p
332      . ,(lambda (tag . elems)
333           (list elems nl nl)))
334
335     (div
336      . ,(lambda (tag . elems)
337           (in-LaTeX-env "trivlist" '()  (list "\\item{}" elems))))
338
339     (br
340      . ,(lambda (tag)
341           (list "\\\\ ")))
342
343     (indent
344       . ,(lambda (tag) "\\indent{}"))
345
346     (ul                        ; Unnumbered lists
347      . ,(lambda (tag . elems)
348           (in-LaTeX-env "itemize" '() elems)))
349
350     (ol                        ; Numbered lists
351      . ,(lambda (tag . elems)
352           (in-LaTeX-env "enumerate" '() elems)))
353
354     (li
355      . ,(lambda (tag . elems)
356           (list "\\item " elems nl)))
357
358     (dl                        ; Definition list
359
360      ;; dl and dt are translated to procedures that take one argument:
361      ;; previously set label: list of fragments or #f if none
362      ;; The procedure returns a pair: (new-label . generate-fragments)
363      ;; Initially, label is #f
364
365      ((dt                      ;; The item title
366        . ,(lambda (tag . elems)
367            (lambda (label)
368              (cons elems       ;; elems become the new label
369                    (if label   ;; the label was set: we've seen dt without dd
370                        (list "\\item [" label "]" nl) ; empty body
371                        '())))))
372       (dd                      ;; The item body
373        . ,(lambda (tag . elems)
374            (lambda (label)
375              (cons #f          ;; consume the existing label
376                    (list "\\item [" (or label "") "] " elems nl)))))
377       )
378      . ,(lambda (tag . procs)  ;; execute procs generated by dt/dd
379          (let loop ((procs (flatten procs)) (label #f) (accum '()))
380            (if (null? procs) (in-LaTeX-env "description" '() (reverse accum))
381                (let ((result ((car procs) label)))
382                  (loop (cdr procs) (car result) (cons (cdr result) accum))))))
383      )
384       
385
386     (blockquote
387      . ,(lambda (tag . elems)
388           (in-LaTeX-env "quote" '() elems)))
389
390     (definition
391       *macro*
392       . ,(lambda (_ type . contents)
393            (in-LaTeX-env "description" '()
394                        `(type ,@contents))))
395     
396     (special
397      *macro*
398      . ,(lambda (tag name arg)
399           `(,(string->symbol (string-upcase (symbol->string name))) ,arg)))
400
401     (preformatted
402      *macro*
403      . ,(lambda (tag . elems)
404           `(verbatim ,elems)))
405         
406     (type
407      *macro*
408      . ,(lambda (tag . terms)
409           `("\\begin{texttt}" ,@terms "\\end{texttt}")))
410
411
412     (verbatim  ; set off pieces of code: one or several lines
413      ((*text* . ; Different quotation rules apply within a "verbatim" block
414               ,(let ((string->goodTeX-in-verbatim
415                      (make-char-quotator
416                       '((#\space "~")  ; All spaces are "hard"
417                         (#\# . "\\#") (#\$ . "\\$") (#\% . "\\%")
418                         (#\& . "\\&") (#\~ . "\\textasciitilde{}")
419                         (#\_ . "\\_") (#\^ . "\\^")
420                         (#\\ . "$\\backslash$") (#\{ . "\\{")
421                         (#\} . "\\}")))))
422                  (lambda (trigger str) 
423                    (if (string? str) (string->goodTeX-in-verbatim str) str)))
424               )
425        (strong
426          . ,(lambda (tag . elems)
427               (list "\\textrm{\\small\\bfseries{}" elems "}")))
428        )
429      . ,(lambda (tag . lines)
430           (in-LaTeX-env "lyxcode" '()
431                       (map (lambda (line) 
432                              (list (if (equal? line "") "~" line) 
433                                    "\\\\" nl))
434                            lines))))
435
436      (small-verbatim   ; set off pieces of code: one or several lines
437      ((*text* . ; Different quotation rules apply within a "verbatim" block
438               ,(let ((string->goodTeX-in-verbatim
439                      (make-char-quotator
440                       '((#\space "~")  ; All spaces are "hard"
441                         (#\# . "\\#") (#\$ . "\\$") (#\% . "\\%")
442                         (#\& . "\\&") (#\~ . "\\textasciitilde{}")
443                         (#\_ . "\\_") (#\^ . "\\^")
444                         (#\\ . "$\\backslash$") (#\{ . "\\{")
445                         (#\} . "\\}")))))
446                  (lambda (trigger str) 
447                    (if (string? str) (string->goodTeX-in-verbatim str) str)))
448               ))
449      . ,(lambda (tag . lines)
450           (in-LaTeX-env "list" '()
451             (list "{}"
452               "{%\\raggedright" nl
453                "\\setlength{\\rightmargin}{-15pt}" nl
454                "\\setlength{\\itemsep}{-12pt}" nl
455                "\\setlength{\\parsep}{-4pt}" nl
456                "\\small\\ttfamily}%" nl
457               (map (lambda (line) 
458                      (list "\\item  "
459                        (if (equal? line "") "~" line)
460                        "\\\\" nl))
461                 lines)))))
462
463     (table
464                ; verbatim mode does not work in tabular <deep sigh> ...
465                ; we have to emulate
466      ((verbatim       
467        ((*text* . ; Different quotation rules apply within a "verbatim" block
468               ,(let ((string->goodTeX-in-verbatim
469                      (make-char-quotator
470                       '((#\space . "~")        ; All spaces are "hard"
471                         (#\newline . "\\\\\n") 
472                         (#\# . "\\#") (#\$ . "\\$") (#\% . "\\%")
473                         (#\& . "\\&") (#\~ . "\\textasciitilde{}")
474                         (#\_ . "\\_") (#\^ . "\\^")
475                         (#\\ . "$\\backslash$") (#\{ . "\\{")
476                         (#\} . "\\}")))))
477                  (lambda (trigger str) 
478                    (if (string? str) (string->goodTeX-in-verbatim str) str)))
479               ))
480        . ,(lambda (tag . lines)       
481             (map (lambda (line) (list "\\ttfamily\\small " nl line "\\\\"))
482                  lines)))
483       (tr              ; elems ::= [(@ attrib ...)] td ...
484                        ; we disregard all attributes of a row
485                        ; The result is (td ...)
486        . ,(lambda (tag . elems)
487             (if (and (pair? elems) (pair? (car elems))
488                      (eq? '@ (caar elems)))
489                 (cdr elems)
490                 elems)))
491
492       (td              ; elems ::= [(@ attrib ...)] body ...
493                        ; we're only interested in (align "alignment") attr
494                        ; and the (colspan "number") attr
495                        ; The result is ("alignment" colspan body ...)
496                        ; where "alignment" will be #\l, #\c, #\r
497                        ; (#\l if not given); colspan is the integer
498        . ,(lambda (tag . elems)
499             (define (get-alignment attrs)
500               (cond
501                ((assq 'align attrs) =>
502                 (lambda (attr)
503                   ;(cerr "align attr: " attr nl)
504                   (cond
505                    ((string-ci=? (cadr attr) "left") #\l)
506                    ((string-ci=? (cadr attr) "right") #\r)
507                    ((string-ci=? (cadr attr) "center") #\c)
508                    (else (error "wrong alignment attribute: " attr)))))
509                (else #\l)))
510             (define (get-colspan attrs)
511               (cond
512                ((assq 'colspan attrs) =>
513                 (lambda (attr)
514                   (let ((val (string->number (cadr attr))))
515                     (assert val)
516                     val)))
517                (else 1)))
518             (if (and (pair? elems) (pair? (car elems))
519                      (eq? '@ (caar elems)))
520                 (cons (get-alignment (cadar elems))
521                   (cons (get-colspan (cadar elems))
522                         (cdr elems)))
523                 (cons (get-alignment '())
524                   (cons (get-colspan '())
525                        elems)))))
526
527       (th              ; elems ::= [(@ attrib ...)] body ...
528                        ; we're only interested in (align "alignment") attr
529                        ; and the (colspan "number") attr
530                        ; The result is ("alignment" colspan body ...)
531                        ; where "alignment" will be #\l, #\c, #\r
532                        ; (#\c if not given); colspan is the integer
533        . ,(lambda (tag . elems)
534             (define (get-alignment attrs)
535               (cond
536                ((assq 'align attrs) =>
537                 (lambda (attr)
538                   ;(cerr "align attr: " attr nl)
539                   (cond
540                    ((string-ci=? (cadr attr) "left") #\l)
541                    ((string-ci=? (cadr attr) "right") #\r)
542                    ((string-ci=? (cadr attr) "center") #\c)
543                    (else (error "wrong alignment attribute: " attr)))))
544                (else #\c)))
545             (define (get-colspan attrs)
546               (cond
547                ((assq 'colspan attrs) =>
548                 (lambda (attr)
549                   (let ((val (string->number (cadr attr))))
550                     (assert val)
551                     val)))
552                (else 1)))
553             (if (and (pair? elems) (pair? (car elems))
554                      (eq? '@ (caar elems)))
555                 (cons (get-alignment (cadar elems))
556                   (cons (get-colspan (cadar elems))
557                         (cdr elems)))
558                 (cons (get-alignment '())
559                   (cons (get-colspan '())
560                        elems)))))
561       )
562                        ; (table [(@ attrib ...)] tr ...
563      . ,(lambda (tag row . rows)
564           (let*-values
565            (((attrs rows)
566              (if (and (pair? row) (eq? '@ (car row)))
567                  (values (cadr row) rows)
568                  (values '() (cons row rows))))
569             ((border?)
570              (cond
571               ((assq 'border attrs) =>
572                (lambda (border-attr) (not (equal? "0" (cadr border-attr)))))
573               (else #f)))
574             ((caption label table-type table-alignment)
575              (apply values
576                     (map (lambda (name)
577                            (cond
578                             ((assq name attrs) => cadr)
579                             (else #f)))
580                          '(caption key table-type align))))
581             (dummy (assert (pair? rows))) ; at least one row must be given
582             ((ncols) (length (car rows)))
583             ((tex-cols)
584              (let ((col-codes
585                     (map (lambda (_) (if border? "l|" "l")) (car rows))))
586                (if border?
587                    (apply string-append 
588                           (cons "|" col-codes))
589                    (apply string-append col-codes))))
590             )
591            (list
592              (list
593               (and (equal? table-alignment "center")
594                    "\\centering")
595               (in-LaTeX-env "tabular"
596                             (list "{" ; "@{\\extracolsep{-25pt}}"
597                                   tex-cols "}")
598                (list (and border? "\\hline\n")
599                  (map
600                   (lambda (row)
601                     (list
602                      (intersperse
603                       (map
604                        (lambda (col)
605                          (apply
606                           (lambda (alignment span . data)
607                             (if (> span 1)
608                                 (list "\\multicolumn{" span "}{" alignment "}{"
609                                       "\\minitab[" alignment "]{"
610                                       data "}}")
611                                 (list "\\minitab[" alignment "]{" data "}")))
612                           col))
613                        row)
614                       " & ")
615                      "\\\\" (and border? "\\hline") nl))
616                   rows)
617                  nl))
618;              (and caption (list "\\caption{"
619;                                 (and label
620;                                      (list "\\label{" label "}"))
621;                                 caption "}"))
622               ))
623            )))
624
625
626     (small
627      . ,(lambda (tag . elems)
628           (list "{\\small{}" elems "}")))
629
630     (strong
631      . ,(lambda (tag . elems)
632           (list "{\\rmfamily\\bfseries{}" elems "}")))
633
634     (history . ,(lambda (history items) (list)))
635     (page-specific-links . ,(lambda _ (list)))
636
637     (tex      ; raw tex expression
638       *preorder*
639       . ,(lambda (tag str) str))
640           
641     )))
642
643
644)
Note: See TracBrowser for help on using the repository browser.