module/sxml/fold.scm

   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 \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)
  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
  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)
  83   "A variant of @ref{SRFI-1 Fold and Map, fold} that allows multi-valued
  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))))