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