Commit | Line | Data |
---|---|---|
47f3ce52 AW |
1 | ;;;; (sxml transform) -- pre- and post-order sxml transformation |
2 | ;;;; | |
3 | ;;;; Copyright (C) 2009 Free Software Foundation, Inc. | |
4 | ;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>. | |
5 | ;;;; Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as SXML-tree-trans.scm. | |
6 | ;;;; | |
7 | ;;;; This library is free software; you can redistribute it and/or | |
8 | ;;;; modify it under the terms of the GNU Lesser General Public | |
9 | ;;;; License as published by the Free Software Foundation; either | |
10 | ;;;; version 3 of the License, or (at your option) any later version. | |
11 | ;;;; | |
12 | ;;;; This library is distributed in the hope that it will be useful, | |
13 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
15 | ;;;; Lesser General Public License for more details. | |
16 | ;;;; | |
17 | ;;;; You should have received a copy of the GNU Lesser General Public | |
18 | ;;;; License along with this library; if not, write to the Free Software | |
19 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
20 | ;;;; | |
21 | \f | |
22 | ;;; Commentary: | |
23 | ;; | |
24 | ;;@heading SXML expression tree transformers | |
25 | ; | |
26 | ;@subheading Pre-Post-order traversal of a tree and creation of a new tree | |
27 | ;@smallexample | |
28 | ;pre-post-order:: <tree> x <bindings> -> <new-tree> | |
29 | ;@end smallexample | |
30 | ; where | |
31 | ;@smallexample | |
32 | ; <bindings> ::= (<binding> ...) | |
33 | ; <binding> ::= (<trigger-symbol> *preorder* . <handler>) | | |
34 | ; (<trigger-symbol> *macro* . <handler>) | | |
35 | ; (<trigger-symbol> <new-bindings> . <handler>) | | |
36 | ; (<trigger-symbol> . <handler>) | |
37 | ; <trigger-symbol> ::= XMLname | *text* | *default* | |
38 | ; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree> | |
39 | ;@end smallexample | |
40 | ; | |
41 | ; The pre-post-order function visits the nodes and nodelists | |
42 | ; pre-post-order (depth-first). For each @code{<Node>} of the form | |
43 | ; @code{(@var{name} <Node> ...)}, it looks up an association with the | |
44 | ; given @var{name} among its @var{<bindings>}. If failed, | |
45 | ; @code{pre-post-order} tries to locate a @code{*default*} binding. It's | |
46 | ; an error if the latter attempt fails as well. Having found a binding, | |
47 | ; the @code{pre-post-order} function first checks to see if the binding | |
48 | ; is of the form | |
49 | ;@smallexample | |
50 | ; (<trigger-symbol> *preorder* . <handler>) | |
51 | ;@end smallexample | |
52 | ; | |
53 | ; If it is, the handler is 'applied' to the current node. Otherwise, the | |
54 | ; pre-post-order function first calls itself recursively for each child | |
55 | ; of the current node, with @var{<new-bindings>} prepended to the | |
56 | ; @var{<bindings>} in effect. The result of these calls is passed to the | |
57 | ; @var{<handler>} (along with the head of the current @var{<Node>}). To | |
58 | ; be more precise, the handler is _applied_ to the head of the current | |
59 | ; node and its processed children. The result of the handler, which | |
60 | ; should also be a @code{<tree>}, replaces the current @var{<Node>}. If | |
61 | ; the current @var{<Node>} is a text string or other atom, a special | |
62 | ; binding with a symbol @code{*text*} is looked up. | |
63 | ; | |
64 | ; A binding can also be of a form | |
65 | ;@smallexample | |
66 | ; (<trigger-symbol> *macro* . <handler>) | |
67 | ;@end smallexample | |
68 | ; This is equivalent to @code{*preorder*} described above. However, the | |
69 | ; result is re-processed again, with the current stylesheet. | |
70 | ;; | |
71 | ;;; Code: | |
72 | ||
73 | (define-module (sxml transform) | |
74 | #:export (SRV:send-reply | |
75 | foldts | |
76 | post-order | |
77 | pre-post-order | |
78 | replace-range)) | |
79 | ||
80 | ;; Upstream version: | |
81 | ; $Id: SXML-tree-trans.scm,v 1.8 2003/04/24 19:39:53 oleg Exp oleg $ | |
82 | ||
83 | ; Like let* but allowing for multiple-value bindings | |
84 | (define-macro (let*-values bindings . body) | |
85 | (if (null? bindings) (cons 'begin body) | |
86 | (apply | |
87 | (lambda (vars initializer) | |
88 | (let ((cont | |
89 | (cons 'let*-values | |
90 | (cons (cdr bindings) body)))) | |
91 | (cond | |
92 | ((not (pair? vars)) ; regular let case, a single var | |
93 | `(let ((,vars ,initializer)) ,cont)) | |
94 | ((null? (cdr vars)) ; single var, see the prev case | |
95 | `(let ((,(car vars) ,initializer)) ,cont)) | |
96 | (else ; the most generic case | |
97 | `(call-with-values (lambda () ,initializer) | |
98 | (lambda ,vars ,cont)))))) | |
99 | (car bindings)))) | |
100 | ||
101 | (define (SRV:send-reply . fragments) | |
102 | "Output the @var{fragments} to the current output port. | |
103 | ||
104 | The fragments are a list of strings, characters, numbers, thunks, | |
105 | @code{#f}, @code{#t} -- and other fragments. The function traverses the | |
106 | tree depth-first, writes out strings and characters, executes thunks, | |
107 | and ignores @code{#f} and @code{'()}. The function returns @code{#t} if | |
108 | anything was written at all; otherwise the result is @code{#f} If | |
109 | @code{#t} occurs among the fragments, it is not written out but causes | |
110 | the result of @code{SRV:send-reply} to be @code{#t}." | |
111 | (let loop ((fragments fragments) (result #f)) | |
112 | (cond | |
113 | ((null? fragments) result) | |
114 | ((not (car fragments)) (loop (cdr fragments) result)) | |
115 | ((null? (car fragments)) (loop (cdr fragments) result)) | |
116 | ((eq? #t (car fragments)) (loop (cdr fragments) #t)) | |
117 | ((pair? (car fragments)) | |
118 | (loop (cdr fragments) (loop (car fragments) result))) | |
119 | ((procedure? (car fragments)) | |
120 | ((car fragments)) | |
121 | (loop (cdr fragments) #t)) | |
122 | (else | |
123 | (display (car fragments)) | |
124 | (loop (cdr fragments) #t))))) | |
125 | ||
126 | ||
127 | ||
128 | ;------------------------------------------------------------------------ | |
129 | ; Traversal of an SXML tree or a grove: | |
130 | ; a <Node> or a <Nodelist> | |
131 | ; | |
132 | ; A <Node> and a <Nodelist> are mutually-recursive datatypes that | |
133 | ; underlie the SXML tree: | |
134 | ; <Node> ::= (name . <Nodelist>) | "text string" | |
135 | ; An (ordered) set of nodes is just a list of the constituent nodes: | |
136 | ; <Nodelist> ::= (<Node> ...) | |
137 | ; Nodelists, and Nodes other than text strings are both lists. A | |
138 | ; <Nodelist> however is either an empty list, or a list whose head is | |
139 | ; not a symbol (an atom in general). A symbol at the head of a node is | |
140 | ; either an XML name (in which case it's a tag of an XML element), or | |
141 | ; an administrative name such as '@'. | |
142 | ; See SXPath.scm and SSAX.scm for more information on SXML. | |
143 | ||
144 | ||
145 | ;; see the commentary for docs | |
146 | (define (pre-post-order tree bindings) | |
147 | (let* ((default-binding (assq '*default* bindings)) | |
148 | (text-binding (or (assq '*text* bindings) default-binding)) | |
149 | (text-handler ; Cache default and text bindings | |
150 | (and text-binding | |
151 | (if (procedure? (cdr text-binding)) | |
152 | (cdr text-binding) (cddr text-binding))))) | |
153 | (let loop ((tree tree)) | |
154 | (cond | |
155 | ((null? tree) '()) | |
156 | ((not (pair? tree)) | |
157 | (let ((trigger '*text*)) | |
158 | (if text-handler (text-handler trigger tree) | |
159 | (error "Unknown binding for " trigger " and no default")))) | |
160 | ((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist | |
161 | (else ; tree is an SXML node | |
162 | (let* ((trigger (car tree)) | |
163 | (binding (or (assq trigger bindings) default-binding))) | |
164 | (cond | |
165 | ((not binding) | |
166 | (error "Unknown binding for " trigger " and no default")) | |
167 | ((not (pair? (cdr binding))) ; must be a procedure: handler | |
168 | (apply (cdr binding) trigger (map loop (cdr tree)))) | |
169 | ((eq? '*preorder* (cadr binding)) | |
170 | (apply (cddr binding) tree)) | |
171 | ((eq? '*macro* (cadr binding)) | |
172 | (loop (apply (cddr binding) tree))) | |
173 | (else ; (cadr binding) is a local binding | |
174 | (apply (cddr binding) trigger | |
175 | (pre-post-order (cdr tree) (append (cadr binding) bindings))) | |
176 | )))))))) | |
177 | ||
178 | ; post-order is a strict subset of pre-post-order without *preorder* | |
179 | ; (let alone *macro*) traversals. | |
180 | ; Now pre-post-order is actually faster than the old post-order. | |
181 | ; The function post-order is deprecated and is aliased below for | |
182 | ; backward compatibility. | |
183 | (define post-order pre-post-order) | |
184 | ||
185 | ;------------------------------------------------------------------------ | |
186 | ; Extended tree fold | |
187 | ; tree = atom | (node-name tree ...) | |
188 | ; | |
189 | ; foldts fdown fup fhere seed (Leaf str) = fhere seed str | |
190 | ; foldts fdown fup fhere seed (Nd kids) = | |
191 | ; fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids | |
192 | ||
193 | ; procedure fhere: seed -> atom -> seed | |
194 | ; procedure fdown: seed -> node -> seed | |
195 | ; procedure fup: parent-seed -> last-kid-seed -> node -> seed | |
196 | ; foldts returns the final seed | |
197 | ||
198 | (define (foldts fdown fup fhere seed tree) | |
199 | (cond | |
200 | ((null? tree) seed) | |
201 | ((not (pair? tree)) ; An atom | |
202 | (fhere seed tree)) | |
203 | (else | |
204 | (let loop ((kid-seed (fdown seed tree)) (kids (cdr tree))) | |
205 | (if (null? kids) | |
206 | (fup seed kid-seed tree) | |
207 | (loop (foldts fdown fup fhere kid-seed (car kids)) | |
208 | (cdr kids))))))) | |
209 | ||
210 | ;------------------------------------------------------------------------ | |
211 | ; Traverse a forest depth-first and cut/replace ranges of nodes. | |
212 | ; | |
213 | ; The nodes that define a range don't have to have the same immediate | |
214 | ; parent, don't have to be on the same level, and the end node of a | |
215 | ; range doesn't even have to exist. A replace-range procedure removes | |
216 | ; nodes from the beginning node of the range up to (but not including) | |
217 | ; the end node of the range. In addition, the beginning node of the | |
218 | ; range can be replaced by a node or a list of nodes. The range of | |
219 | ; nodes is cut while depth-first traversing the forest. If all | |
220 | ; branches of the node are cut a node is cut as well. The procedure | |
221 | ; can cut several non-overlapping ranges from a forest. | |
222 | ||
223 | ; replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST | |
224 | ; where | |
225 | ; type FOREST = (NODE ...) | |
226 | ; type NODE = Atom | (Name . FOREST) | FOREST | |
227 | ; | |
228 | ; The range of nodes is specified by two predicates, beg-pred and end-pred. | |
229 | ; beg-pred:: NODE -> #f | FOREST | |
230 | ; end-pred:: NODE -> #f | FOREST | |
231 | ; The beg-pred predicate decides on the beginning of the range. The node | |
232 | ; for which the predicate yields non-#f marks the beginning of the range | |
233 | ; The non-#f value of the predicate replaces the node. The value can be a | |
234 | ; list of nodes. The replace-range procedure then traverses the tree and skips | |
235 | ; all the nodes, until the end-pred yields non-#f. The value of the end-pred | |
236 | ; replaces the end-range node. The new end node and its brothers will be | |
237 | ; re-scanned. | |
238 | ; The predicates are evaluated pre-order. We do not descend into a node that | |
239 | ; is marked as the beginning of the range. | |
240 | ||
241 | (define (replace-range beg-pred end-pred forest) | |
242 | ||
243 | ; loop forest keep? new-forest | |
244 | ; forest is the forest to traverse | |
245 | ; new-forest accumulates the nodes we will keep, in the reverse | |
246 | ; order | |
247 | ; If keep? is #t, keep the curr node if atomic. If the node is not atomic, | |
248 | ; traverse its children and keep those that are not in the skip range. | |
249 | ; If keep? is #f, skip the current node if atomic. Otherwise, | |
250 | ; traverse its children. If all children are skipped, skip the node | |
251 | ; as well. | |
252 | ||
253 | (define (loop forest keep? new-forest) | |
254 | (if (null? forest) (values (reverse new-forest) keep?) | |
255 | (let ((node (car forest))) | |
256 | (if keep? | |
257 | (cond ; accumulate mode | |
258 | ((beg-pred node) => ; see if the node starts the skip range | |
259 | (lambda (repl-branches) ; if so, skip/replace the node | |
260 | (loop (cdr forest) #f | |
261 | (append (reverse repl-branches) new-forest)))) | |
262 | ((not (pair? node)) ; it's an atom, keep it | |
263 | (loop (cdr forest) keep? (cons node new-forest))) | |
264 | (else | |
265 | (let*-values | |
266 | (((node?) (symbol? (car node))) ; or is it a nodelist? | |
267 | ((new-kids keep?) ; traverse its children | |
268 | (loop (if node? (cdr node) node) #t '()))) | |
269 | (loop (cdr forest) keep? | |
270 | (cons | |
271 | (if node? (cons (car node) new-kids) new-kids) | |
272 | new-forest))))) | |
273 | ; skip mode | |
274 | (cond | |
275 | ((end-pred node) => ; end the skip range | |
276 | (lambda (repl-branches) ; repl-branches will be re-scanned | |
277 | (loop (append repl-branches (cdr forest)) #t | |
278 | new-forest))) | |
279 | ((not (pair? node)) ; it's an atom, skip it | |
280 | (loop (cdr forest) keep? new-forest)) | |
281 | (else | |
282 | (let*-values | |
283 | (((node?) (symbol? (car node))) ; or is it a nodelist? | |
284 | ((new-kids keep?) ; traverse its children | |
285 | (loop (if node? (cdr node) node) #f '()))) | |
286 | (loop (cdr forest) keep? | |
287 | (if (or keep? (pair? new-kids)) | |
288 | (cons | |
289 | (if node? (cons (car node) new-kids) new-kids) | |
290 | new-forest) | |
291 | new-forest) ; if all kids are skipped | |
292 | )))))))) ; skip the node too | |
293 | ||
294 | (let*-values (((new-forest keep?) (loop forest #t '()))) | |
295 | new-forest)) | |
296 | ||
297 | ;;; arch-tag: 6c814f4b-38f7-42c1-b8ef-ce3447edefc7 | |
298 | ;;; transform.scm ends here |