Commit | Line | Data |
---|---|---|
47f3ce52 AW |
1 | ;;;; (sxml fold) -- transformation of sxml via fold operations |
2 | ;;;; | |
6c76da4c | 3 | ;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. |
47f3ce52 AW |
4 | ;;;; Written 2007 by Andy Wingo <wingo at pobox dot com>. |
5 | ;;;; | |
6 | ;;;; This library is free software; you can redistribute it and/or | |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
9 | ;;;; version 3 of the License, or (at your option) any later version. | |
10 | ;;;; | |
11 | ;;;; This library is distributed in the hope that it will be useful, | |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
14 | ;;;; Lesser General Public License for more details. | |
15 | ;;;; | |
16 | ;;;; You should have received a copy of the GNU Lesser General Public | |
17 | ;;;; License along with this library; if not, write to the Free Software | |
18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
19 | ;;;; | |
20 | \f | |
21 | ;;; Commentary: | |
22 | ;; | |
23 | ;; @code{(sxml fold)} defines a number of variants of the @dfn{fold} | |
24 | ;; algorithm for use in transforming SXML trees. Additionally it defines | |
25 | ;; the layout operator, @code{fold-layout}, which might be described as | |
26 | ;; a context-passing variant of SSAX's @code{pre-post-order}. | |
27 | ;; | |
28 | ;;; Code: | |
29 | ||
30 | (define-module (sxml fold) | |
6c76da4c | 31 | #:use-module (srfi srfi-1) |
47f3ce52 | 32 | #:export (foldt |
47f3ce52 AW |
33 | foldts |
34 | foldts* | |
35 | fold-values | |
36 | foldts*-values | |
37 | fold-layout)) | |
38 | ||
39 | (define (atom? x) | |
40 | (not (pair? x))) | |
41 | ||
42 | (define (foldt fup fhere tree) | |
43 | "The standard multithreaded tree fold. | |
44 | ||
45 | @var{fup} is of type [a] -> a. @var{fhere} is of type object -> a. | |
46 | " | |
47 | (if (atom? tree) | |
48 | (fhere tree) | |
49 | (fup (map (lambda (kid) | |
50 | (foldt fup fhere kid)) | |
51 | tree)))) | |
52 | ||
47f3ce52 AW |
53 | (define (foldts fdown fup fhere seed tree) |
54 | "The single-threaded tree fold originally defined in SSAX. | |
55 | @xref{sxml ssax,,(sxml ssax)}, for more information." | |
56 | (if (atom? tree) | |
57 | (fhere seed tree) | |
58 | (fup seed | |
59 | (fold (lambda (kid kseed) | |
60 | (foldts fdown fup fhere kseed kid)) | |
61 | (fdown seed tree) | |
62 | tree) | |
63 | tree))) | |
64 | ||
65 | (define (foldts* fdown fup fhere seed tree) | |
66 | "A variant of @ref{sxml fold foldts,,foldts} that allows pre-order | |
67 | tree rewrites. Originally defined in Andy Wingo's 2007 paper, | |
68 | @emph{Applications of fold to XML transformation}." | |
69 | (if (atom? tree) | |
70 | (fhere seed tree) | |
71 | (call-with-values | |
72 | (lambda () (fdown seed tree)) | |
73 | (lambda (kseed tree) | |
74 | (fup seed | |
75 | (fold (lambda (kid kseed) | |
76 | (foldts* fdown fup fhere | |
77 | kseed kid)) | |
78 | kseed | |
79 | tree) | |
80 | tree))))) | |
81 | ||
82 | (define (fold-values proc list . seeds) | |
6c76da4c | 83 | "A variant of @ref{SRFI-1 Fold and Map, fold} that allows multi-valued |
47f3ce52 AW |
84 | seeds. Note that the order of the arguments differs from that of |
85 | @code{fold}." | |
86 | (if (null? list) | |
87 | (apply values seeds) | |
88 | (call-with-values | |
89 | (lambda () (apply proc (car list) seeds)) | |
90 | (lambda seeds | |
91 | (apply fold-values proc (cdr list) seeds))))) | |
92 | ||
93 | (define (foldts*-values fdown fup fhere tree . seeds) | |
94 | "A variant of @ref{sxml fold foldts*,,foldts*} that allows | |
95 | multi-valued seeds. Originally defined in Andy Wingo's 2007 paper, | |
96 | @emph{Applications of fold to XML transformation}." | |
97 | (if (atom? tree) | |
98 | (apply fhere tree seeds) | |
99 | (call-with-values | |
100 | (lambda () (apply fdown tree seeds)) | |
101 | (lambda (tree . kseeds) | |
102 | (call-with-values | |
103 | (lambda () | |
104 | (apply fold-values | |
105 | (lambda (tree . seeds) | |
106 | (apply foldts*-values | |
107 | fdown fup fhere tree seeds)) | |
108 | tree kseeds)) | |
109 | (lambda kseeds | |
110 | (apply fup tree (append seeds kseeds)))))))) | |
111 | ||
112 | (define (assq-ref alist key default) | |
113 | (cond ((assq key alist) => cdr) | |
114 | (else default))) | |
115 | ||
116 | (define (fold-layout tree bindings params layout stylesheet) | |
117 | "A traversal combinator in the spirit of SSAX's @ref{sxml transform | |
118 | pre-post-order,,pre-post-order}. | |
119 | ||
120 | @code{fold-layout} was originally presented in Andy Wingo's 2007 paper, | |
121 | @emph{Applications of fold to XML transformation}. | |
122 | ||
123 | @example | |
124 | bindings := (<binding>...) | |
125 | binding := (<tag> <bandler-pair>...) | |
126 | | (*default* . <post-handler>) | |
127 | | (*text* . <text-handler>) | |
128 | tag := <symbol> | |
129 | handler-pair := (pre-layout . <pre-layout-handler>) | |
130 | | (post . <post-handler>) | |
131 | | (bindings . <bindings>) | |
132 | | (pre . <pre-handler>) | |
133 | | (macro . <macro-handler>) | |
134 | @end example | |
135 | ||
136 | @table @var | |
137 | @item pre-layout-handler | |
138 | A function of three arguments: | |
139 | ||
140 | @table @var | |
141 | @item kids | |
142 | the kids of the current node, before traversal | |
143 | @item params | |
144 | the params of the current node | |
145 | @item layout | |
146 | the layout coming into this node | |
147 | @end table | |
148 | ||
149 | @var{pre-layout-handler} is expected to use this information to return a | |
150 | layout to pass to the kids. The default implementation returns the | |
151 | layout given in the arguments. | |
152 | ||
153 | @item post-handler | |
154 | A function of five arguments: | |
155 | @table @var | |
156 | @item tag | |
157 | the current tag being processed | |
158 | @item params | |
159 | the params of the current node | |
160 | @item layout | |
161 | the layout coming into the current node, before any kids were processed | |
162 | @item klayout | |
163 | the layout after processing all of the children | |
164 | @item kids | |
165 | the already-processed child nodes | |
166 | @end table | |
167 | ||
168 | @var{post-handler} should return two values, the layout to pass to the | |
169 | next node and the final tree. | |
170 | ||
171 | @item text-handler | |
172 | @var{text-handler} is a function of three arguments: | |
173 | @table @var | |
174 | @item text | |
175 | the string | |
176 | @item params | |
177 | the current params | |
178 | @item layout | |
179 | the current layout | |
180 | @end table | |
181 | ||
182 | @var{text-handler} should return two values, the layout to pass to the | |
183 | next node and the value to which the string should transform. | |
184 | @end table | |
185 | " | |
186 | (define (err . args) | |
187 | (error "no binding available" args)) | |
188 | (define (fdown tree bindings pcont params layout ret) | |
189 | (define (fdown-helper new-bindings new-layout cont) | |
190 | (let ((cont-with-tag (lambda args | |
191 | (apply cont (car tree) args))) | |
192 | (bindings (if new-bindings | |
193 | (append new-bindings bindings) | |
194 | bindings)) | |
195 | (style-params (assq-ref stylesheet (car tree) '()))) | |
196 | (cond | |
197 | ((null? (cdr tree)) | |
198 | (values | |
199 | '() bindings cont-with-tag (cons style-params params) new-layout '())) | |
200 | ((and (pair? (cadr tree)) (eq? (caadr tree) '@)) | |
201 | (let ((params (cons (append (cdadr tree) style-params) params))) | |
202 | (values | |
203 | (cddr tree) bindings cont-with-tag params new-layout '()))) | |
204 | (else | |
205 | (values | |
206 | (cdr tree) bindings cont-with-tag (cons style-params params) new-layout '()))))) | |
207 | (define (no-bindings) | |
208 | (fdown-helper #f layout (assq-ref bindings '*default* err))) | |
209 | (define (macro macro-handler) | |
210 | (fdown (apply macro-handler tree) | |
211 | bindings pcont params layout ret)) | |
212 | (define (pre pre-handler) | |
213 | (values '() bindings | |
214 | (lambda (params layout old-layout kids) | |
215 | (values layout (reverse kids))) | |
216 | params layout (apply pre-handler tree))) | |
217 | (define (have-bindings tag-bindings) | |
218 | (fdown-helper | |
219 | (assq-ref tag-bindings 'bindings #f) | |
220 | ((assq-ref tag-bindings 'pre-layout | |
221 | (lambda (tag params layout) | |
222 | layout)) | |
223 | tree params layout) | |
224 | (assq-ref tag-bindings 'post | |
225 | (assq-ref bindings '*default* err)))) | |
226 | (let ((tag-bindings (assq-ref bindings (car tree) #f))) | |
227 | (cond | |
228 | ((not tag-bindings) (no-bindings)) | |
229 | ((assq-ref tag-bindings 'macro #f) => macro) | |
230 | ((assq-ref tag-bindings 'pre #f) => pre) | |
231 | (else (have-bindings tag-bindings))))) | |
232 | (define (fup tree bindings cont params layout ret | |
233 | kbindings kcont kparams klayout kret) | |
234 | (call-with-values | |
235 | (lambda () | |
236 | (kcont kparams layout klayout (reverse kret))) | |
237 | (lambda (klayout kret) | |
238 | (values bindings cont params klayout (cons kret ret))))) | |
239 | (define (fhere tree bindings cont params layout ret) | |
240 | (call-with-values | |
241 | (lambda () | |
242 | ((assq-ref bindings '*text* err) tree params layout)) | |
243 | (lambda (tlayout tret) | |
244 | (values bindings cont params tlayout (cons tret ret))))) | |
245 | (call-with-values | |
246 | (lambda () | |
247 | (foldts*-values | |
248 | fdown fup fhere tree bindings #f (cons params '()) layout '())) | |
249 | (lambda (bindings cont params layout ret) | |
250 | (values (car ret) layout)))) |