module/sxml/transform.scm

   1 ;;;; (sxml transform) -- pre- and post-order sxml transformation
   2 ;;;;
   3 ;;;;    Copyright (C) 2009  Free Software Foundation, Inc.
   4 ;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
   5 ;;;;    Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as SXML-tree-trans.scm.
   6 ;;;;
   7 ;;;; This library is free software; you can redistribute it and/or
   8 ;;;; modify it under the terms of the GNU Lesser General Public
   9 ;;;; License as published by the Free Software Foundation; either
  10 ;;;; version 3 of the License, or (at your option) any later version.
  11 ;;;;
  12 ;;;; This library is distributed in the hope that it will be useful,
  13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;;; Lesser General Public License for more details.
  16 ;;;;
  17 ;;;; You should have received a copy of the GNU Lesser General Public
  18 ;;;; License along with this library; if not, write to the Free Software
  19 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  20 ;;;;
  21 \f
  22 ;;; Commentary:
  23 ;;
  24 ;;@heading SXML expression tree transformers
  25 ;
  26 ;@subheading Pre-Post-order traversal of a tree and creation of a new tree
  27 ;@smallexample
  28 ;pre-post-order:: <tree> x <bindings> -> <new-tree>
  29 ;@end smallexample
  30 ; where
  31 ;@smallexample
  32 ; <bindings> ::= (<binding> ...)
  33 ; <binding> ::= (<trigger-symbol> *preorder* . <handler>) |
  34 ;               (<trigger-symbol> *macro* . <handler>) |
  35 ;               (<trigger-symbol> <new-bindings> . <handler>) |
  36 ;               (<trigger-symbol> . <handler>)
  37 ; <trigger-symbol> ::= XMLname | *text* | *default*
  38 ; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree>
  39 ;@end smallexample
  40 ;
  41 ; The pre-post-order function visits the nodes and nodelists
  42 ; pre-post-order (depth-first). For each @code{<Node>} of the form
  43 ; @code{(@var{name} <Node> ...)}, it looks up an association with the
  44 ; given @var{name} among its @var{<bindings>}. If failed,
  45 ; @code{pre-post-order} tries to locate a @code{*default*} binding. It's
  46 ; an error if the latter attempt fails as well. Having found a binding,
  47 ; the @code{pre-post-order} function first checks to see if the binding
  48 ; is of the form
  49 ;@smallexample
  50 ;       (<trigger-symbol> *preorder* . <handler>)
  51 ;@end smallexample
  52 ;
  53 ; If it is, the handler is 'applied' to the current node. Otherwise, the
  54 ; pre-post-order function first calls itself recursively for each child
  55 ; of the current node, with @var{<new-bindings>} prepended to the
  56 ; @var{<bindings>} in effect. The result of these calls is passed to the
  57 ; @var{<handler>} (along with the head of the current @var{<Node>}). To
  58 ; be more precise, the handler is _applied_ to the head of the current
  59 ; node and its processed children. The result of the handler, which
  60 ; should also be a @code{<tree>}, replaces the current @var{<Node>}. If
  61 ; the current @var{<Node>} is a text string or other atom, a special
  62 ; binding with a symbol @code{*text*} is looked up.
  63 ;
  64 ; A binding can also be of a form
  65 ;@smallexample
  66 ;       (<trigger-symbol> *macro* . <handler>)
  67 ;@end smallexample
  68 ; This is equivalent to @code{*preorder*} described above. However, the
  69 ; result is re-processed again, with the current stylesheet.
  70 ;;
  71 ;;; Code:
  72
  73 (define-module (sxml transform)
  74   #:export (SRV:send-reply
  75             foldts
  76             post-order
  77             pre-post-order
  78             replace-range))
  79
  80 ;; Upstream version:
  81 ; $Id: SXML-tree-trans.scm,v 1.8 2003/04/24 19:39:53 oleg Exp oleg $
  82
  83 ; Like let* but allowing for multiple-value bindings
  84 (define-macro (let*-values bindings . body)
  85   (if (null? bindings) (cons 'begin body)
  86       (apply
  87        (lambda (vars initializer)
  88          (let ((cont
  89                 (cons 'let*-values
  90                       (cons (cdr bindings) body))))
  91            (cond
  92             ((not (pair? vars))         ; regular let case, a single var
  93              `(let ((,vars ,initializer)) ,cont))
  94             ((null? (cdr vars))         ; single var, see the prev case
  95              `(let ((,(car vars) ,initializer)) ,cont))
  96            (else                        ; the most generic case
  97             `(call-with-values (lambda () ,initializer)
  98               (lambda ,vars ,cont))))))
  99        (car bindings))))
 100
 101 (define (SRV:send-reply . fragments)
 102   "Output the @var{fragments} to the current output port.
 103
 104 The fragments are a list of strings, characters, numbers, thunks,
 105 @code{#f}, @code{#t} -- and other fragments. The function traverses the
 106 tree depth-first, writes out strings and characters, executes thunks,
 107 and ignores @code{#f} and @code{'()}. The function returns @code{#t} if
 108 anything was written at all; otherwise the result is @code{#f} If
 109 @code{#t} occurs among the fragments, it is not written out but causes
 110 the result of @code{SRV:send-reply} to be @code{#t}."
 111   (let loop ((fragments fragments) (result #f))
 112     (cond
 113       ((null? fragments) result)
 114       ((not (car fragments)) (loop (cdr fragments) result))
 115       ((null? (car fragments)) (loop (cdr fragments) result))
 116       ((eq? #t (car fragments)) (loop (cdr fragments) #t))
 117       ((pair? (car fragments))
 118         (loop (cdr fragments) (loop (car fragments) result)))
 119       ((procedure? (car fragments))
 120         ((car fragments))
 121         (loop (cdr fragments) #t))
 122       (else
 123         (display (car fragments))
 124         (loop (cdr fragments) #t)))))
 125
 126
 127
 128 ;------------------------------------------------------------------------
 129 ;                 Traversal of an SXML tree or a grove:
 130 ;                       a <Node> or a <Nodelist>
 131 ;
 132 ; A <Node> and a <Nodelist> are mutually-recursive datatypes that
 133 ; underlie the SXML tree:
 134 ;       <Node> ::= (name . <Nodelist>) | "text string"
 135 ; An (ordered) set of nodes is just a list of the constituent nodes:
 136 ;       <Nodelist> ::= (<Node> ...)
 137 ; Nodelists, and Nodes other than text strings are both lists. A
 138 ; <Nodelist> however is either an empty list, or a list whose head is
 139 ; not a symbol (an atom in general). A symbol at the head of a node is
 140 ; either an XML name (in which case it's a tag of an XML element), or
 141 ; an administrative name such as '@'.
 142 ; See SXPath.scm and SSAX.scm for more information on SXML.
 143
 144
 145 ;; see the commentary for docs
 146 (define (pre-post-order tree bindings)
 147   (let* ((default-binding (assq '*default* bindings))
 148          (text-binding (or (assq '*text* bindings) default-binding))
 149          (text-handler                  ; Cache default and text bindings
 150            (and text-binding
 151              (if (procedure? (cdr text-binding))
 152                  (cdr text-binding) (cddr text-binding)))))
 153     (let loop ((tree tree))
 154       (cond
 155         ((null? tree) '())
 156         ((not (pair? tree))
 157           (let ((trigger '*text*))
 158             (if text-handler (text-handler trigger tree)
 159               (error "Unknown binding for " trigger " and no default"))))
 160         ((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
 161         (else                           ; tree is an SXML node
 162           (let* ((trigger (car tree))
 163                  (binding (or (assq trigger bindings) default-binding)))
 164             (cond
 165               ((not binding)
 166                 (error "Unknown binding for " trigger " and no default"))
 167               ((not (pair? (cdr binding)))  ; must be a procedure: handler
 168                 (apply (cdr binding) trigger (map loop (cdr tree))))
 169               ((eq? '*preorder* (cadr binding))
 170                 (apply (cddr binding) tree))
 171               ((eq? '*macro* (cadr binding))
 172                 (loop (apply (cddr binding) tree)))
 173               (else                         ; (cadr binding) is a local binding
 174                 (apply (cddr binding) trigger
 175                   (pre-post-order (cdr tree) (append (cadr binding) bindings)))
 176                 ))))))))
 177
 178 ; post-order is a strict subset of pre-post-order without *preorder*
 179 ; (let alone *macro*) traversals.
 180 ; Now pre-post-order is actually faster than the old post-order.
 181 ; The function post-order is deprecated and is aliased below for
 182 ; backward compatibility.
 183 (define post-order pre-post-order)
 184
 185 ;------------------------------------------------------------------------
 186 ;                       Extended tree fold
 187 ; tree = atom | (node-name tree ...)
 188 ;
 189 ; foldts fdown fup fhere seed (Leaf str) = fhere seed str
 190 ; foldts fdown fup fhere seed (Nd kids) =
 191 ;         fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids
 192
 193 ; procedure fhere: seed -> atom -> seed
 194 ; procedure fdown: seed -> node -> seed
 195 ; procedure fup: parent-seed -> last-kid-seed -> node -> seed
 196 ; foldts returns the final seed
 197
 198 (define (foldts fdown fup fhere seed tree)
 199   (cond
 200    ((null? tree) seed)
 201    ((not (pair? tree))          ; An atom
 202     (fhere seed tree))
 203    (else
 204     (let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
 205       (if (null? kids)
 206           (fup seed kid-seed tree)
 207           (loop (foldts fdown fup fhere kid-seed (car kids))
 208                 (cdr kids)))))))
 209
 210 ;------------------------------------------------------------------------
 211 ; Traverse a forest depth-first and cut/replace ranges of nodes.
 212 ;
 213 ; The nodes that define a range don't have to have the same immediate
 214 ; parent, don't have to be on the same level, and the end node of a
 215 ; range doesn't even have to exist. A replace-range procedure removes
 216 ; nodes from the beginning node of the range up to (but not including)
 217 ; the end node of the range.  In addition, the beginning node of the
 218 ; range can be replaced by a node or a list of nodes. The range of
 219 ; nodes is cut while depth-first traversing the forest. If all
 220 ; branches of the node are cut a node is cut as well.  The procedure
 221 ; can cut several non-overlapping ranges from a forest.
 222
 223 ;       replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
 224 ; where
 225 ;       type FOREST = (NODE ...)
 226 ;       type NODE = Atom | (Name . FOREST) | FOREST
 227 ;
 228 ; The range of nodes is specified by two predicates, beg-pred and end-pred.
 229 ;       beg-pred:: NODE -> #f | FOREST
 230 ;       end-pred:: NODE -> #f | FOREST
 231 ; The beg-pred predicate decides on the beginning of the range. The node
 232 ; for which the predicate yields non-#f marks the beginning of the range
 233 ; The non-#f value of the predicate replaces the node. The value can be a
 234 ; list of nodes. The replace-range procedure then traverses the tree and skips
 235 ; all the nodes, until the end-pred yields non-#f. The value of the end-pred
 236 ; replaces the end-range node. The new end node and its brothers will be
 237 ; re-scanned.
 238 ; The predicates are evaluated pre-order. We do not descend into a node that
 239 ; is marked as the beginning of the range.
 240
 241 (define (replace-range beg-pred end-pred forest)
 242
 243   ; loop forest keep? new-forest
 244   ; forest is the forest to traverse
 245   ; new-forest accumulates the nodes we will keep, in the reverse
 246   ; order
 247   ; If keep? is #t, keep the curr node if atomic. If the node is not atomic,
 248   ; traverse its children and keep those that are not in the skip range.
 249   ; If keep? is #f, skip the current node if atomic. Otherwise,
 250   ; traverse its children. If all children are skipped, skip the node
 251   ; as well.
 252
 253   (define (loop forest keep? new-forest)
 254     (if (null? forest) (values (reverse new-forest) keep?)
 255         (let ((node (car forest)))
 256           (if keep?
 257               (cond                     ; accumulate mode
 258                ((beg-pred node) =>      ; see if the node starts the skip range
 259                 (lambda (repl-branches) ; if so, skip/replace the node
 260                   (loop (cdr forest) #f
 261                         (append (reverse repl-branches) new-forest))))
 262                ((not (pair? node))      ; it's an atom, keep it
 263                 (loop (cdr forest) keep? (cons node new-forest)))
 264                (else
 265                 (let*-values
 266                  (((node?) (symbol? (car node))) ; or is it a nodelist?
 267                   ((new-kids keep?)              ; traverse its children
 268                    (loop (if node? (cdr node) node) #t '())))
 269                  (loop (cdr forest) keep?
 270                        (cons
 271                         (if node? (cons (car node) new-kids) new-kids)
 272                         new-forest)))))
 273               ; skip mode
 274               (cond
 275                ((end-pred node) =>      ; end the skip range
 276                 (lambda (repl-branches) ; repl-branches will be re-scanned
 277                   (loop (append repl-branches (cdr forest)) #t
 278                         new-forest)))
 279                ((not (pair? node))      ; it's an atom, skip it
 280                 (loop (cdr forest) keep? new-forest))
 281                (else
 282                 (let*-values
 283                  (((node?) (symbol? (car node)))  ; or is it a nodelist?
 284                   ((new-kids keep?)               ; traverse its children
 285                    (loop (if node? (cdr node) node) #f '())))
 286                  (loop (cdr forest) keep?
 287                        (if (or keep? (pair? new-kids))
 288                            (cons
 289                             (if node? (cons (car node) new-kids) new-kids)
 290                             new-forest)
 291                            new-forest)          ; if all kids are skipped
 292                        ))))))))                 ; skip the node too
 293
 294   (let*-values (((new-forest keep?) (loop forest #t '())))
 295      new-forest))
 296
 297 ;;; arch-tag: 6c814f4b-38f7-42c1-b8ef-ce3447edefc7
 298 ;;; transform.scm ends here