module/sxml/apply-templates.scm

   1 ;;;; (sxml apply-templates) -- xslt-like transformation for sxml
   2 ;;;;
   3 ;;;;    Copyright (C) 2009 Free Software Foundation, Inc.
   4 ;;;;    Copyright 2004 by Andy Wingo <wingo at pobox dot com>.
   5 ;;;;    Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as apply-templates.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 ;; Pre-order traversal of a tree and creation of a new tree:
  25 ;;
  26 ;;@smallexample
  27 ;;      apply-templates:: tree x <templates> -> <new-tree>
  28 ;;@end smallexample
  29 ;; where
  30 ;;@smallexample
  31 ;; <templates> ::= (<template> ...)
  32 ;; <template>  ::= (<node-test> <node-test> ... <node-test> . <handler>)
  33 ;; <node-test> ::= an argument to node-typeof? above
  34 ;; <handler>   ::= <tree> -> <new-tree>
  35 ;;@end smallexample
  36 ;;
  37 ;; This procedure does a @emph{normal}, pre-order traversal of an SXML
  38 ;; tree.  It walks the tree, checking at each node against the list of
  39 ;; matching templates.
  40 ;;
  41 ;; If the match is found (which must be unique, i.e., unambiguous), the
  42 ;; corresponding handler is invoked and given the current node as an
  43 ;; argument. The result from the handler, which must be a @code{<tree>},
  44 ;; takes place of the current node in the resulting tree.
  45 ;;
  46 ;; The name of the function is not accidental: it resembles rather
  47 ;; closely an @code{apply-templates} function of XSLT.
  48 ;;
  49 ;;; Code:
  50
  51 (define-module (sxml apply-templates)
  52   #:use-module (sxml ssax)
  53   #:use-module ((sxml xpath) :hide (filter))
  54
  55   #:export (apply-templates))
  56
  57 (define (apply-templates tree templates)
  58
  59                 ; Filter the list of templates. If a template does not
  60                 ; contradict the given node (that is, its head matches
  61                 ; the type of the node), chop off the head and keep the
  62                 ; rest as the result. All contradicting templates are removed.
  63   (define (filter-templates node templates)
  64     (cond
  65      ((null? templates) templates)
  66      ((not (pair? (car templates)))  ; A good template must be a list
  67       (filter-templates node (cdr templates)))
  68      (((node-typeof? (caar templates)) node)
  69       (cons (cdar templates) (filter-templates node (cdr templates))))
  70      (else
  71       (filter-templates node (cdr templates)))))
  72
  73                 ; Here <templates> ::= [<template> | <handler>]
  74                 ; If there is a <handler> in the above list, it must
  75                 ; be only one. If found, return it; otherwise, return #f
  76   (define (find-handler templates)
  77     (and (pair? templates)
  78          (cond
  79           ((procedure? (car templates))
  80            (if (find-handler (cdr templates))
  81                (error "ambiguous template match"))
  82            (car templates))
  83           (else (find-handler (cdr templates))))))
  84
  85   (let loop ((tree tree) (active-templates '()))
  86    ;(cout "active-templates: " active-templates nl "tree: " tree nl)
  87     (if (nodeset? tree)
  88         (map-union (lambda (a-tree) (loop a-tree active-templates)) tree)
  89         (let ((still-active-templates
  90                (append
  91                 (filter-templates tree active-templates)
  92                 (filter-templates tree templates))))
  93           (cond
  94            ;((null? still-active-templates) '())
  95            ((find-handler still-active-templates) =>
  96             (lambda (handler) (handler tree)))
  97            ((not (pair? tree)) '())
  98            (else
  99             (loop (cdr tree) still-active-templates)))))))
 100
 101 ;;; arch-tag: 88cd87de-8825-4ab3-9721-cf99694fb787
 102 ;;; templates.scm ends here