1 ;;;; (sxml transform) -- pre- and post-order sxml transformation
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.
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.
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.
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
24 ;;@heading SXML expression tree transformers
26 ;@subheading Pre-Post-order traversal of a tree and creation of a new tree
28 ;pre-post-order:: <tree> x <bindings> -> <new-tree>
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>
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
50 ; (<trigger-symbol> *preorder* . <handler>)
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.
64 ; A binding can also be of a form
66 ; (<trigger-symbol> *macro* . <handler>)
68 ; This is equivalent to @code{*preorder*} described above. However, the
69 ; result is re-processed again, with the current stylesheet.
73 (define-module (sxml transform)
74 #:export (SRV:send-reply
81 ; $Id: SXML-tree-trans.scm,v 1.8 2003/04/24 19:39:53 oleg Exp oleg $
83 ; Like let* but allowing for multiple-value bindings
84 (define-macro (let*-values bindings . body)
85 (if (null? bindings) (cons 'begin body)
87 (lambda (vars initializer)
90 (cons (cdr bindings) body))))
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))))))
101 (define (SRV:send-reply . fragments)
102 "Output the @var{fragments} to the current output port.
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))
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))
121 (loop (cdr fragments) #t))
123 (display (car fragments))
124 (loop (cdr fragments) #t)))))
128 ;------------------------------------------------------------------------
129 ; Traversal of an SXML tree or a grove:
130 ; a <Node> or a <Nodelist>
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.
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
151 (if (procedure? (cdr text-binding))
152 (cdr text-binding) (cddr text-binding)))))
153 (let loop ((tree 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)))
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)))
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)
185 ;------------------------------------------------------------------------
187 ; tree = atom | (node-name tree ...)
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
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
198 (define (foldts fdown fup fhere seed tree)
201 ((not (pair? tree)) ; An atom
204 (let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
206 (fup seed kid-seed tree)
207 (loop (foldts fdown fup fhere kid-seed (car kids))
210 ;------------------------------------------------------------------------
211 ; Traverse a forest depth-first and cut/replace ranges of nodes.
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.
223 ; replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
225 ; type FOREST = (NODE ...)
226 ; type NODE = Atom | (Name . FOREST) | FOREST
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
238 ; The predicates are evaluated pre-order. We do not descend into a node that
239 ; is marked as the beginning of the range.
241 (define (replace-range beg-pred end-pred forest)
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
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
253 (define (loop forest keep? new-forest)
254 (if (null? forest) (values (reverse new-forest) keep?)
255 (let ((node (car forest)))
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)))
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?
271 (if node? (cons (car node) new-kids) new-kids)
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
279 ((not (pair? node)) ; it's an atom, skip it
280 (loop (cdr forest) keep? new-forest))
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))
289 (if node? (cons (car node) new-kids) new-kids)
291 new-forest) ; if all kids are skipped
292 )))))))) ; skip the node too
294 (let*-values (((new-forest keep?) (loop forest #t '())))
297 ;;; arch-tag: 6c814f4b-38f7-42c1-b8ef-ce3447edefc7
298 ;;; transform.scm ends here