guile-for-guile-emacs/module/sxml/fold.scm

;;;; (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))))