source: project/release/3/hart/trunk/hart-support.scm @ 8227

Last change on this file since 8227 was 8227, checked in by graham, 12 years ago

bugfix, tag attributes are now evaluated once, not twice

File size: 5.4 KB
Line 
1(use srfi-1 regex vector-lib)
2
3(declare (export hart-parse hart-html-escape
4                 hart-vector-for-each*))
5
6;; todo: general optimizations; extensible keyword syntax.
7
8;;;parser support
9
10;; *hart-emitted* is a parameter holding a list, that collects the output
11;; of the parser. This could have been done with an accumulator, but I
12;; found this was simple to work with. It's not very portable as
13;; written, though, since parameters are non-standard.
14
15(define *hart-emitted* (make-parameter '()))
16
17(define (hart-emit obj)
18  (*hart-emitted* (cons obj (*hart-emitted*))))
19
20(define (print-for-strings lst #!optional (acc '()))
21  ;; Given an emitted list, for each string-literal S in the list,
22  ;; replace it with (print* S).
23  (cond ((null? lst) (reverse acc))
24        ((string? (car lst))
25         (print-for-strings (cdr lst)
26                            (cons (list 'print* (car lst))
27                                  acc)))
28        (#t (print-for-strings (cdr lst)
29                               (cons (car lst) acc)))))
30
31;;; the parser
32
33(define (hart-parse . forms)
34  (parameterize ((*hart-emitted* '()))
35    (for-each hart-parse-form forms)
36    (cons 'begin
37          (print-for-strings (conc-strings (reverse (*hart-emitted*)))))))
38
39(define (hart-parse-form form)
40  (match form
41         ('() (noop))
42         ((? number?)
43           (hart-emit (hart-html-escape form)))
44         ((? string?)
45           (hart-emit (hart-html-escape form)))
46         ((? symbol? x)
47           (hart-emit-single-tag x))
48         (((? keyword? x) . rest)
49          (hart-parse-keyword-form form))
50         (((? symbol? x) . rest)
51          (hart-parse-xml-form form))
52         ))
53
54(define (hart-parse-xml-form form)
55  (match form
56         ((tag) (hart-emit-single-tag tag))
57         ((tag ('@ . attrs))
58          (hart-emit-single-tag tag attrs))
59         ((tag ('@ . attrs) . body)
60          (hart-emit-opening-tag tag attrs)
61          (map (lambda (form) (hart-parse-form form)) body)
62          (hart-emit-closing-tag tag))
63         ((tag . body)
64          (hart-emit-opening-tag tag '())
65          (map (lambda (form) (hart-parse-form form)) body)
66          (hart-emit-closing-tag tag))
67         ))
68
69
70;; Hart keyword syntax
71;; Fixme -- I really want to make this user-extensible.
72
73(define (hart-parse-keyword-form form)
74  (let ((keyword->symbol (compose string->symbol
75                                  keyword->string)))
76    (match-let (((kwd . body) form))
77      (case kwd
78        ((when: unless: let: let*: letrec:)
79         (hart-emit `(,(keyword->symbol kwd) ,(car body)
80                 ,@(map hart-parse (cdr body)))))
81        ((begin:)
82         (hart-emit `(,@(apply hart-parse body))))
83        ((if:)
84         (hart-emit `(if ,(first body)
85                    ,(hart-parse (second body))
86                    ,(hart-parse (third body)))))
87        ((raw:)         
88         (hart-emit `(print* ,@body)))
89        ((t: text:)         
90         (hart-emit `(apply print* (map hart-html-escape
91                                   (list ,@body)))))
92        ((fmt:)         
93         (hart-emit `(print* (hart-html-escape (format ,@body)))))
94        ((for:)
95         (match-let (((kwd (iter lst) . body) form))
96           (hart-emit `(hart-for (,iter ,lst)
97                    ,@(map hart-parse body)))))
98        ((scheme:)
99          (hart-emit `(begin ,@body)))
100        ((for-select:)
101         (match-let (((kwd select-form . body) form))
102           (hart-emit `(for-select ,@select-form
103                                   ,@ (map hart-parse body)))))
104        (else (error "unknown keyword" kwd))))))
105
106
107;;; emitting tags and attributes
108
109(define (hart-emit-tag tag single? attrs)
110  (if (null? attrs)
111      (hart-emit (format "<~a" tag))
112      (begin
113        (hart-emit (format "<~a" tag))
114        (hart-for ((key value) attrs)
115                  (if ((disjoin string? number?) value)
116                      (hart-emit (format " ~a=\"~a\"" key (hart-html-escape value)))
117                      (hart-emit (let ((val (gensym)))
118                                   `(let ((,val ,value))
119                                     (when ,val
120                                       (print* ,(format " ~a=\"" key)
121                                               (hart-html-escape ,val)
122                                               "\"")))))))
123        ))
124  (hart-emit (if single? "/>" ">")))
125
126(define (hart-emit-single-tag tag #!optional (attrs '()))
127  (hart-emit-tag tag #t attrs))
128
129(define (hart-emit-opening-tag tag #!optional (attrs '()))
130  (hart-emit-tag tag #f attrs))
131
132(define (hart-emit-closing-tag tag)
133  (hart-emit (format "</~a>" tag)))
134
135
136;;;strings and escaping
137
138(define hart-html-escape
139  (compose (foreign-lambda c-string* "hart_html_escape" c-string)
140           ->string))
141
142(define (empty-string? s) (= (string-length s) 0))
143
144(define (conc-strings lst #!optional (acc '()))
145  "Join consecutive string literals in the list (via conc)."
146  (if (null? lst)
147      acc
148      (receive (strings rest)
149          (span string? lst)
150        (receive (nonstrings rest2)
151            (span (complement string?) rest)
152          (let ((str (fold-right conc "" strings)))
153            (conc-strings rest2
154                          (append acc
155                                  (if (empty-string? str)
156                                      nonstrings
157                                      (cons str nonstrings)))))))))
158
159;;; other
160
161(define (hart-vector-for-each* fn vec)
162  ;; used by the "for" syntax
163  (let ((func (lambda (i x) (fn x))))
164    (vector-for-each func vec)))
Note: See TracBrowser for help on using the repository browser.