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

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

changed hart printing, no longer flushes on every print action.

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