summaryrefslogtreecommitdiff
path: root/module/sxml/fold.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/sxml/fold.scm')
-rw-r--r--module/sxml/fold.scm250
1 files changed, 250 insertions, 0 deletions
diff --git a/module/sxml/fold.scm b/module/sxml/fold.scm
new file mode 100644
index 000000000..0d2a5bc04
--- /dev/null
+++ b/module/sxml/fold.scm
@@ -0,0 +1,250 @@
+;;;; (sxml fold) -- transformation of sxml via fold operations
+;;;;
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Written 2007 by Andy Wingo <wingo at pobox dot com>.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+;;; 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)
+ #:use-module (srfi srfi-1)
+ #:export (foldt
+ 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 (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{SRFI-1 Fold and Map, 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))))