1;;;; (sxml fold) -- transformation of sxml via fold operations 2;;;; 3;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. 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 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) 31 #:use-module (srfi srfi-1) 32 #:export (foldt 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 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 67tree 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) 83 "A variant of @ref{SRFI-1 Fold and Map, fold} that allows multi-valued 84seeds. 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 95multi-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 118pre-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 124bindings := (<binding>...) 125binding := (<tag> <bandler-pair>...) 126 | (*default* . <post-handler>) 127 | (*text* . <text-handler>) 128tag := <symbol> 129handler-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 138A function of three arguments: 139 140@table @var 141@item kids 142the kids of the current node, before traversal 143@item params 144the params of the current node 145@item layout 146the layout coming into this node 147@end table 148 149@var{pre-layout-handler} is expected to use this information to return a 150layout to pass to the kids. The default implementation returns the 151layout given in the arguments. 152 153@item post-handler 154A function of five arguments: 155@table @var 156@item tag 157the current tag being processed 158@item params 159the params of the current node 160@item layout 161the layout coming into the current node, before any kids were processed 162@item klayout 163the layout after processing all of the children 164@item kids 165the already-processed child nodes 166@end table 167 168@var{post-handler} should return two values, the layout to pass to the 169next 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 175the string 176@item params 177the current params 178@item layout 179the current layout 180@end table 181 182@var{text-handler} should return two values, the layout to pass to the 183next 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)))) 251