source: project/stream-wiki/trunk/extensions/tags.scm @ 4922

Last change on this file since 4922 was 4922, checked in by azul, 12 years ago

Better names to avoid clash.

File size: 4.8 KB
Line 
1; This extension implements support for basic tags.
2;
3; See *extensions* at the end for a list of all them.
4
5(require-extension syntax-case stream-ext html-stream format-modular)
6
7(define-syntax environment
8  (syntax-rules ()
9    ((environment original ((name expr) ...))
10     (lambda (op)
11       (case op
12         ((name) expr)
13         ...
14         (else (original op)))))
15    ((environment ((name expr) ...))
16     (environment (lambda (op)
17                    (warning "unbound variable (dynamic environment)" op)
18                    (if #f #f))
19                  ((name expr) ...)))))
20
21(define-syntax environment-get
22  (syntax-rules ()
23    ((environment-get env sym) (env 'sym))))
24
25(define-syntax let-from-environment
26  (syntax-rules ()
27    ((let-from-environment env (sym ...) body ...)
28     (let ((sym (environment-get env sym)) ...) body ...))))
29
30(define-syntax environment-capture
31  (syntax-rules ()
32    ((environment-capture env (sym ...))
33     (environment env ((sym sym) ...)))
34    ((environment-capture (sym ...))
35     (environment ((sym sym) ...)))))
36
37; Deprecated:
38(define (unsupported name env)
39  (let-from-environment env (output-format)
40    (string->stream (format #f "[[~A is unsupported for ~A]]~%" name output-format))))
41
42; Deprecated:
43(define (tag-span-case name latex texi odf)
44  `(,name
45     (code-span
46       ,(lambda (env)
47          (let-from-environment env (output-format)
48            ((case output-format
49               ((html) html-tag)
50               ((latex) latex)
51               ((odf) odf)
52               ((texi) texi))
53             name
54             env))))))
55
56; Deprecated:
57(define (html-tag name env)
58  (stream-append
59    (stream-cons #\< (symbol->stream name))
60    (stream-cons #\>
61      (let-from-environment env (text parse)
62        (parse text)))
63    (stream-cons* #\< #\/ (symbol->stream name))
64    (stream #\>)))
65
66(define (tag-span-driver name func)
67  `(,name (code-span ,func)))
68
69(define (tag-break-driver name func)
70  `(,name (code-break
71            ,(lambda (env)
72               (let-from-environment env (driver)
73                 ((func driver)))))))
74
75(define (tag-parse-recursively driver-function env)
76  (let-from-environment env (driver parse text)
77    ((driver-function driver)
78     (parse text))))
79
80(define (tag-parse-recursively-paragraph driver-function props env)
81  (let-from-environment env (driver parse-paragraph text)
82    ((driver-function driver)
83     (parse-paragraph text props))))
84
85(define (tag-parse-recursively-header depth env)
86  (let-from-environment env (driver parse-paragraph text)
87    ((driver-header driver) (parse-paragraph text '()) depth text)))
88
89(define (tag-a-break env)
90  (format (current-error-port) "Call break~%")
91  (tag-a-span (environment env ((text stream-null)))))
92
93(define (tag-a-span env)
94  (format (current-error-port) "Call span~%")
95  (let-from-environment env (params text parse-paragraph driver)
96    (let ((path-param (assoc 'name params)))
97      ((if path-param
98         (cut (driver-anchor driver) (cdr path-param) <...>)
99         identity)
100       (parse-paragraph text '())))))
101
102(define *extensions*
103  (list
104
105    (tag-span-driver 'pre
106      (cut tag-parse-recursively-paragraph driver-literal '((literal #t)) <>))
107
108    (tag-span-driver 'tt
109      (cut tag-parse-recursively-paragraph driver-literal-line '((literal #t)) <>))
110
111    (tag-span-driver 'code
112      (cut tag-parse-recursively-paragraph driver-literal-line '((literal #t)) <>))
113
114    (tag-span-driver 'strong
115      (cut tag-parse-recursively-paragraph driver-strong '((strong #t)) <>))
116
117    (tag-span-driver 'em
118      (cut tag-parse-recursively-paragraph driver-em '((em #t)) <>))
119
120    (tag-span-driver 'blockquote
121      (cut tag-parse-recursively driver-blockquote <>))
122
123    (tag-span-driver 'center
124      (cut tag-parse-recursively driver-center <>))
125
126    (tag-span-driver 'small
127      (cut tag-parse-recursively driver-small <>))
128
129    (tag-span-driver 'big
130      (cut tag-parse-recursively driver-big <>))
131
132    (tag-span-driver 'strike
133      (cut tag-parse-recursively driver-strike <>))
134
135    (tag-span-driver 'h1
136      (cut tag-parse-recursively-header 1 <>))
137    (tag-span-driver 'h2
138      (cut tag-parse-recursively-header 1 <>))
139    (tag-span-driver 'h3
140      (cut tag-parse-recursively-header 1 <>))
141    (tag-span-driver 'h4
142      (cut tag-parse-recursively-header 1 <>))
143    (tag-span-driver 'h5
144      (cut tag-parse-recursively-header 1 <>))
145    (tag-span-driver 'h6
146      (cut tag-parse-recursively-header 1 <>))
147
148    `(a (code-break ,tag-a-break)
149        (code-span ,tag-a-span))
150
151    (tag-break-driver 'br driver-line-break)
152    (tag-break-driver 'hr driver-horizontal-line)
153
154    (tag-span-case 'table unsupported unsupported unsupported)
155    (tag-span-case 'tr unsupported unsupported unsupported)
156    (tag-span-case 'td unsupported unsupported unsupported)
157    (tag-span-case 'th unsupported unsupported unsupported)))
Note: See TracBrowser for help on using the repository browser.