LilyPond-Ruby 0.1.1 → 0.1.2

data/share/guile/2.2/sxml/apply-templates.scm

@@ -0,0 +1,102 @@
+;;;; (sxml apply-templates) -- xslt-like transformation for sxml
+;;;;
+;;;; 	Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;    Copyright 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;;    Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as apply-templates.scm.
+;;;; 
+;;;; 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:
+;;
+;; Pre-order traversal of a tree and creation of a new tree:
+;;
+;;@smallexample
+;;	apply-templates:: tree x <templates> -> <new-tree>
+;;@end smallexample
+;; where
+;;@smallexample
+;; <templates> ::= (<template> ...)
+;; <template>  ::= (<node-test> <node-test> ... <node-test> . <handler>)
+;; <node-test> ::= an argument to node-typeof? above
+;; <handler>   ::= <tree> -> <new-tree>
+;;@end smallexample
+;;
+;; This procedure does a @emph{normal}, pre-order traversal of an SXML
+;; tree.  It walks the tree, checking at each node against the list of
+;; matching templates.
+;;
+;; If the match is found (which must be unique, i.e., unambiguous), the
+;; corresponding handler is invoked and given the current node as an
+;; argument. The result from the handler, which must be a @code{<tree>},
+;; takes place of the current node in the resulting tree.
+;; 
+;; The name of the function is not accidental: it resembles rather
+;; closely an @code{apply-templates} function of XSLT.
+;;
+;;; Code:
+
+(define-module (sxml apply-templates)
+  #:use-module (sxml ssax)
+  #:use-module ((sxml xpath) :hide (filter))
+                         
+  #:export (apply-templates))
+
+(define (apply-templates tree templates)
+
+		; Filter the list of templates. If a template does not
+		; contradict the given node (that is, its head matches
+		; the type of the node), chop off the head and keep the
+		; rest as the result. All contradicting templates are removed.
+  (define (filter-templates node templates)
+    (cond
+     ((null? templates) templates)
+     ((not (pair? (car templates)))  ; A good template must be a list
+      (filter-templates node (cdr templates)))
+     (((node-typeof? (caar templates)) node)
+      (cons (cdar templates) (filter-templates node (cdr templates))))
+     (else
+      (filter-templates node (cdr templates)))))
+
+		; Here <templates> ::= [<template> | <handler>]
+		; If there is a <handler> in the above list, it must
+		; be only one. If found, return it; otherwise, return #f
+  (define (find-handler templates)
+    (and (pair? templates)
+	 (cond
+	  ((procedure? (car templates))
+	   (if (find-handler (cdr templates))
+	       (error "ambiguous template match"))
+	   (car templates))
+	  (else (find-handler (cdr templates))))))
+
+  (let loop ((tree tree) (active-templates '()))
+   ;(cout "active-templates: " active-templates nl "tree: " tree nl)
+    (if (nodeset? tree)
+	(map-union (lambda (a-tree) (loop a-tree active-templates)) tree)
+	(let ((still-active-templates 
+	       (append 
+		(filter-templates tree active-templates)
+		(filter-templates tree templates))))
+	  (cond 
+	   ;((null? still-active-templates) '())
+	   ((find-handler still-active-templates) =>
+	    (lambda (handler) (handler tree)))
+	   ((not (pair? tree)) '())
+	   (else
+	    (loop (cdr tree) still-active-templates)))))))
+
+;;; arch-tag: 88cd87de-8825-4ab3-9721-cf99694fb787
+;;; templates.scm ends here

data/share/guile/2.2/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))))

data/share/guile/2.2/sxml/match.scm

@@ -0,0 +1,75 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;
+;;; 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 program.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (sxml match)
+  #:export (sxml-match
+            sxml-match-let
+            sxml-match-let*)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 control))
+
+
+;;; Commentary:
+;;;
+;;; This module provides an SXML pattern matcher, written by Jim Bender.  This
+;;; allows application code to match on SXML nodes and attributes without having
+;;; to deal with the details of s-expression matching, without worrying about
+;;; the order of attributes, etc.
+;;;
+;;; It is fully documented in the Guile Reference Manual.
+;;;
+;;; Code:
+
+
+
+;;;
+;;; PLT compatibility layer.
+;;;
+
+(define-syntax-rule (syntax-object->datum stx)
+  (syntax->datum stx))
+
+(define-syntax-rule (void)
+  *unspecified*)
+
+(define (raise-syntax-error x msg obj sub)
+  (throw 'sxml-match-error x msg obj sub))
+
+(define-syntax module
+  (syntax-rules (provide require)
+    ((_ name lang (provide p_ ...) (require r_ ...)
+        body ...)
+     (begin body ...))))
+
+
+;;;
+;;; Include upstream source file.
+;;;
+
+;; This file was taken from
+;; <http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/> on
+;; 2010-05-24.  It was written by Jim Bender <benderjg2@aol.com> and released
+;; under the MIT/X11 license
+;; <http://www.gnu.org/licenses/license-list.html#X11License>.
+;;
+;; Modified the `sxml-match1' macro to allow multiple-value returns (upstream
+;; was notified.)
+
+(include-from-path "sxml/sxml-match.ss")
+
+;;; match.scm ends here