Changeset 15694 in project


Ignore:
Timestamp:
09/01/09 04:25:20 (10 years ago)
Author:
Ivan Raikov
Message:

factored out rendering code from qwiki-sxml to multidoc

Location:
release/4/qwiki/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/qwiki/trunk/qwiki-sxml.scm

    r15505 r15694  
    4444
    4545(use posix srfi-1 srfi-13 data-structures regex )
    46 (use sxml-transforms doctype uri-generic)
     46(use sxml-transforms multidoc doctype uri-generic)
    4747
    4848
     
    5757;;;;
    5858
    59 (define (qwiki-make-html-header head-parms)
     59(define (make-html-header head-parms)
    6060  `(head
    6161    (title ,(or (lookup-def 'title head-parms) "qwiki"))
     
    8282
    8383(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
     84  `(
     85    (
     86     (wiki-page
    11487      . ,(lambda (tag . elems)
    115            `(pre (tt ,elems))))
    116          
    117      (type
    118       *macro*
    119       . ,(lambda (tag . terms)
    120            `(tt ,@terms)))
     88           (list
     89            xhtml-1.0-strict
     90            "<html xmlns=\"http://www.w3.org/1999/xhtml\">"
     91            elems
     92            "</html>")))
    12193
    12294     (wiki *macro* . ,(lambda (tag href . contents)
     
    12496                            ,(if (pair? contents) contents
    12597                                 href))))
    126 
    127      (url *macro* . ,(lambda (tag href . contents)
    128                        `(a (@ (class "external") (href ,href))
    129                            ,(if (pair? contents) contents
    130                                 href))))
    13198
    13299   
     
    154121                        (li (url "?action=edit" "edit"))
    155122                        (li (url "?action=history" "history")))))
    156 
    157123     ,@alist-conv-rules
    158124     )
    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   )
     125   
     126     ,@(multidoc-html-transformation-rules content)
     127  ))
    201128
    202129;;;;
     
    206133(define nl (list->string (list #\newline)))
    207134
    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 
    254135(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 
     136  `(
     137    (
    271138     (wiki-page
    272139      . ,(lambda (tag . elems)
     
    298165      )
    299166
    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 
    332167     (wiki
    333168      *macro*
     
    338173             ,(if (null? contents) href (or contents href))
    339174             (tex "}"))))
     175     ,@alist-conv-rules
     176     )
    340177
    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      )))
     178     ,@(multidoc-LaTeX-transformation-rules content)
     179     ))
    660180
    661181
  • release/4/qwiki/trunk/qwiki.meta

    r15497 r15694  
    11((synopsis "qwiki - the quick wiki")
    2  (needs wiki-parse intarweb uri-common spiffy (doctype 1.2) sxml-transforms
    3         svn-client)
     2 (needs wiki-parse intarweb uri-common spiffy (doctype 1.2)
     3 sxml-transforms multidoc svn-client) 
    44 (author "Peter Bex")
    55 (category www)
  • release/4/qwiki/trunk/qwiki.setup

    r15504 r15694  
    11;;;; -*- Hen -*-
    22
    3 (compile -s -d2 qwiki-sxml.scm -j qwiki-sxml)
    4 (compile -s -O2 qwiki-sxml.import.scm)
     3(define (dynld-name fn)         
     4  (make-pathname #f fn ##sys#load-dynamic-extension))   
    55
    6 (compile -s -O2 qwiki-svn.scm -j qwiki-svn)
    7 (compile -s -O2 qwiki-svn.import.scm)
     6(make (
     7       ((dynld-name "qwiki-sxml") ("qwiki-sxml.scm" )
     8        (compile -O -d2 -s qwiki-sxml.scm -j qwiki-sxml))
    89
    9 (compile -s -O2 qwiki.scm -j qwiki)
    10 (compile -s -O2 qwiki.import.scm)
     10       ((dynld-name "qwiki-sxml.import") ("qwiki-sxml.import.scm")
     11        (compile -O2 -s qwiki-sxml.import.scm))
    1112
    12 (compile -s -O2 qwiki-nowiki.scm -j qwiki-nowiki)
    13 (compile -s -O2 qwiki-nowiki.import.scm)
     13       ((dynld-name "qwiki-svn") ("qwiki-svn.scm" )
     14        (compile -O -d2 -s qwiki-svn.scm -j qwiki-svn))
    1415
    15 (compile -O2 qwiki-post-commit-hook.scm)
     16       ((dynld-name "qwiki-svn.import") ("qwiki-svn.import.scm")
     17        (compile -O2 -s qwiki-svn.import.scm))
     18
     19       ((dynld-name "qwiki-nowiki") ("qwiki-nowiki.scm" )
     20        (compile -O -d2 -s qwiki-nowiki.scm -j qwiki-nowiki))
     21
     22       ((dynld-name "qwiki-nowiki.import") ("qwiki-nowiki.import.scm")
     23        (compile -O2 -s qwiki-nowiki.import.scm))
     24
     25       ((dynld-name "qwiki") ("qwiki.scm" )
     26        (compile -O -d2 -s qwiki.scm -j qwiki))
     27
     28       ((dynld-name "qwiki.import") ("qwiki.import.scm")
     29        (compile -O2 -s qwiki.import.scm))
     30
     31       ((dynld-name "qwiki-post-commit-hook") ("qwiki-post-commit-hook.scm" )
     32        (compile -O -d2 qwiki-post-commit-hook.scm))
     33
     34       )
     35  (list
     36   (dynld-name "qwiki-svn")
     37   (dynld-name "qwiki-svn.import")
     38   (dynld-name "qwiki-nowiki")
     39   (dynld-name "qwiki-nowiki.import")
     40   (dynld-name "qwiki-sxml")
     41   (dynld-name "qwiki-sxml.import")
     42   (dynld-name "qwiki")
     43   (dynld-name "qwiki.import")
     44   "qwiki-post-commit-hook"
     45   )
     46  )
     47
    1648
    1749(install-extension
Note: See TracChangeset for help on using the changeset viewer.