LilyPond-Ruby 0.1.1 → 0.1.2

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

@@ -0,0 +1,408 @@
+;;;; (sxml simple) -- a simple interface to the SSAX parser
+;;;;
+;;;; 	Copyright (C) 2009, 2010, 2013  Free Software Foundation, Inc.
+;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;;    Originally written by Oleg Kiselyov <oleg at pobox dot com> as SXML-to-HTML.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:
+;;
+;;A simple interface to XML parsing and serialization.
+;;
+;;; Code:
+
+(define-module (sxml simple)
+  #:use-module (sxml ssax input-parse)
+  #:use-module (sxml ssax)
+  #:use-module (sxml transform)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-13)
+  #:export (xml->sxml sxml->xml sxml->string))
+
+;; Helpers from upstream/SSAX.scm.
+;;
+
+;     ssax:reverse-collect-str LIST-OF-FRAGS -> LIST-OF-FRAGS
+; given the list of fragments (some of which are text strings)
+; reverse the list and concatenate adjacent text strings.
+; We can prove from the general case below that if LIST-OF-FRAGS
+; has zero or one element, the result of the procedure is equal?
+; to its argument. This fact justifies the shortcut evaluation below.
+(define (ssax:reverse-collect-str fragments)
+  (cond
+    ((null? fragments) '())	; a shortcut
+    ((null? (cdr fragments)) fragments) ; see the comment above
+    (else
+      (let loop ((fragments fragments) (result '()) (strs '()))
+	(cond
+	  ((null? fragments)
+	    (if (null? strs) result
+	      (cons (string-concatenate/shared strs) result)))
+	  ((string? (car fragments))
+	    (loop (cdr fragments) result (cons (car fragments) strs)))
+	  (else
+	    (loop (cdr fragments)
+	      (cons
+		(car fragments)
+		(if (null? strs) result
+		  (cons (string-concatenate/shared strs) result)))
+	      '())))))))
+
+(define (read-internal-doctype-as-string port)
+  (string-concatenate/shared
+    (let loop ()
+      (let ((fragment
+	     (next-token '() '(#\]) "reading internal DOCTYPE" port)))
+	(if (eqv? #\> (peek-next-char port))
+	    (begin
+	      (read-char port)
+	      (cons fragment '()))
+	    (cons* fragment "]" (loop)))))))
+
+;; Ideas for the future for this interface:
+;;
+;;  * Allow doctypes to provide parsed entities
+;;
+;;  * Allow validation (the ELEMENTS value from the DOCTYPE handler
+;;    below)
+;;
+;;  * Parse internal DTDs
+;;
+;;  * Parse external DTDs
+;;
+(define* (xml->sxml #:optional (string-or-port (current-input-port)) #:key
+                    (namespaces '())
+                    (declare-namespaces? #t)
+                    (trim-whitespace? #f)
+                    (entities '())
+                    (default-entity-handler #f)
+                    (doctype-handler #f))
+  "Use SSAX to parse an XML document into SXML. Takes one optional
+argument, @var{string-or-port}, which defaults to the current input
+port."
+  ;; NAMESPACES: alist of PREFIX -> URI.  Specifies the symbol prefix
+  ;; that the user wants on elements of a given namespace in the
+  ;; resulting SXML, regardless of the abbreviated namespaces defined in
+  ;; the document by xmlns attributes.  If DECLARE-NAMESPACES? is true,
+  ;; these namespaces are treated as if they were declared in the DTD.
+
+  ;; ENTITIES: alist of SYMBOL -> STRING.
+
+  ;; NAMESPACES: list of (DOC-PREFIX . (USER-PREFIX . URI)).
+  ;; A DOC-PREFIX of #f indicates that it comes from the user.
+  ;; Otherwise, prefixes are symbols.
+  (define (munge-namespaces namespaces)
+    (map (lambda (el)
+           (match el
+             ((prefix . uri-string)
+              (cons* (and declare-namespaces? prefix)
+                     prefix
+                     (ssax:uri-string->symbol uri-string)))))
+         namespaces))
+
+  (define (user-namespaces)
+    (munge-namespaces namespaces))
+
+  (define (user-entities)
+    (if (and default-entity-handler
+             (not (assq '*DEFAULT* entities)))
+        (acons '*DEFAULT* default-entity-handler entities)
+        entities))
+
+  (define (name->sxml name)
+    (match name
+      ((prefix . local-part)
+       (symbol-append prefix (string->symbol ":") local-part))
+      (_ name)))
+
+  (define (doctype-continuation seed)
+    (lambda* (#:key (entities '()) (namespaces '()))
+      (values #f
+              (append entities (user-entities))
+              (append (munge-namespaces namespaces) (user-namespaces))
+              seed)))
+
+  ;; The SEED in this parser is the SXML: initialized to '() at each new
+  ;; level by the fdown handlers; built in reverse by the fhere parsers;
+  ;; and reverse-collected by the fup handlers.
+  (define parser
+    (ssax:make-parser
+     NEW-LEVEL-SEED ; fdown
+     (lambda (elem-gi attributes namespaces expected-content seed)
+       '())
+   
+     FINISH-ELEMENT ; fup
+     (lambda (elem-gi attributes namespaces parent-seed seed)
+       (let ((seed (if trim-whitespace?
+                       (ssax:reverse-collect-str-drop-ws seed)
+                       (ssax:reverse-collect-str seed)))
+             (attrs (attlist-fold
+                     (lambda (attr accum)
+                       (cons (list (name->sxml (car attr)) (cdr attr))
+                             accum))
+                     '() attributes)))
+         (acons (name->sxml elem-gi)
+                (if (null? attrs)
+                    seed
+                    (cons (cons '@ attrs) seed))
+                parent-seed)))
+
+     CHAR-DATA-HANDLER ; fhere
+     (lambda (string1 string2 seed)
+       (if (string-null? string2)
+           (cons string1 seed)
+           (cons* string2 string1 seed)))
+
+     DOCTYPE
+     ;; -> ELEMS ENTITIES NAMESPACES SEED
+     ;;
+     ;; ELEMS is for validation and currently unused.
+     ;;
+     ;; ENTITIES is an alist of parsed entities (symbol -> string).
+     ;;
+     ;; NAMESPACES is as above.
+     ;;
+     ;; SEED builds up the content.
+     (lambda (port docname systemid internal-subset? seed)
+       (call-with-values
+           (lambda ()
+             (cond
+              (doctype-handler
+               (doctype-handler docname systemid
+                                (and internal-subset?
+                                     (read-internal-doctype-as-string port))))
+              (else
+               (when internal-subset?
+                 (ssax:skip-internal-dtd port))
+               (values))))
+         (doctype-continuation seed)))
+
+     UNDECL-ROOT
+     ;; This is like the DOCTYPE handler, but for documents that do not
+     ;; have a <!DOCTYPE!> entry.
+     (lambda (elem-gi seed)
+       (call-with-values
+           (lambda ()
+             (if doctype-handler
+                 (doctype-handler #f #f #f)
+                 (values)))
+        (doctype-continuation seed)))
+
+     PI
+     ((*DEFAULT*
+       . (lambda (port pi-tag seed)
+           (cons
+            (list '*PI* pi-tag (ssax:read-pi-body-as-string port))
+            seed))))))
+
+  (let* ((port (if (string? string-or-port)
+                   (open-input-string string-or-port)
+                   string-or-port))
+         (elements (reverse (parser port '()))))
+    `(*TOP* ,@elements)))
+
+(define check-name
+  (let ((*good-cache* (make-hash-table)))
+    (lambda (name)
+      (if (not (hashq-ref *good-cache* name))
+          (let* ((str (symbol->string name))
+                 (i (string-index str #\:))
+                 (head (or (and i (substring str 0 i)) str))
+                 (tail (and i (substring str (1+ i)))))
+            (and i (string-index (substring str (1+ i)) #\:)
+                 (error "Invalid QName: more than one colon" name))
+            (for-each
+             (lambda (s)
+               (and s
+                    (or (char-alphabetic? (string-ref s 0))
+                        (eq? (string-ref s 0) #\_)
+                        (error "Invalid name starting character" s name))
+                    (string-for-each
+                     (lambda (c)
+                       (or (char-alphabetic? c) (string-index "0123456789.-_" c)
+                           (error "Invalid name character" c s name)))
+                     s)))
+             (list head tail))
+            (hashq-set! *good-cache* name #t))))))
+
+;; The following two functions serialize tags and attributes. They are
+;; being used in the node handlers for the post-order function, see
+;; below.
+
+(define (attribute-value->xml value port)
+  (cond
+   ((pair? value)
+    (attribute-value->xml (car value) port)
+    (attribute-value->xml (cdr value) port))
+   ((null? value)
+    *unspecified*)
+   ((string? value)
+    (string->escaped-xml value port))
+   ((procedure? value)
+    (with-output-to-port port value))
+   (else
+    (string->escaped-xml
+     (call-with-output-string (lambda (port) (display value port)))
+     port))))
+
+(define (attribute->xml attr value port)
+  (check-name attr)
+  (display attr port)
+  (display "=\"" port)
+  (attribute-value->xml value port)
+  (display #\" port))
+
+(define (element->xml tag attrs body port)
+  (check-name tag)
+  (display #\< port)
+  (display tag port)
+  (if attrs
+      (let lp ((attrs attrs))
+        (if (pair? attrs)
+            (let ((attr (car attrs)))
+              (display #\space port)
+              (if (pair? attr)
+                  (attribute->xml (car attr) (cdr attr) port)
+                  (error "bad attribute" tag attr))
+              (lp (cdr attrs)))
+            (if (not (null? attrs))
+                (error "bad attributes" tag attrs)))))
+  (if (pair? body)
+      (begin
+        (display #\> port)
+        (let lp ((body body))
+          (cond
+           ((pair? body)
+            (sxml->xml (car body) port)
+            (lp (cdr body)))
+           ((null? body)
+            (display "</" port)
+            (display tag port)
+            (display ">" port))
+           (else
+            (error "bad element body" tag body)))))
+      (display " />" port)))
+
+;; FIXME: ensure name is valid
+(define (entity->xml name port)
+  (display #\& port)
+  (display name port)
+  (display #\; port))
+
+;; FIXME: ensure tag and str are valid
+(define (pi->xml tag str port)
+  (display "<?" port)
+  (display tag port)
+  (display #\space port)
+  (display str port)
+  (display "?>" port))
+
+(define* (sxml->xml tree #:optional (port (current-output-port)))
+  "Serialize the sxml tree @var{tree} as XML. The output will be written
+to the current output port, unless the optional argument @var{port} is
+present."
+  (cond
+   ((pair? tree)
+    (if (symbol? (car tree))
+        ;; An element.
+        (let ((tag (car tree)))
+          (case tag
+            ((*TOP*)
+             (sxml->xml (cdr tree) port))
+            ((*ENTITY*)
+             (if (and (list? (cdr tree)) (= (length (cdr tree)) 1))
+                 (entity->xml (cadr tree) port)
+                 (error "bad *ENTITY* args" (cdr tree))))
+            ((*PI*)
+             (if (and (list? (cdr tree)) (= (length (cdr tree)) 2))
+                 (pi->xml (cadr tree) (caddr tree) port)
+                 (error "bad *PI* args" (cdr tree))))
+            (else
+             (let* ((elems (cdr tree))
+                    (attrs (and (pair? elems) (pair? (car elems))
+                                (eq? '@ (caar elems))
+                                (cdar elems))))
+               (element->xml tag attrs (if attrs (cdr elems) elems) port)))))
+        ;; A nodelist.
+        (for-each (lambda (x) (sxml->xml x port)) tree)))
+   ((string? tree)
+    (string->escaped-xml tree port))
+   ((null? tree) *unspecified*)
+   ((not tree) *unspecified*)
+   ((eqv? tree #t) *unspecified*)
+   ((procedure? tree)
+    (with-output-to-port port tree))
+   (else
+    (string->escaped-xml
+     (call-with-output-string (lambda (port) (display tree port)))
+     port))))
+
+(define (sxml->string sxml)
+  "Detag an sxml tree @var{sxml} into a string. Does not perform any
+formatting."
+  (string-concatenate-reverse
+   (foldts
+    (lambda (seed tree)                 ; fdown
+      '())
+    (lambda (seed kid-seed tree)        ; fup
+      (append! kid-seed seed))
+    (lambda (seed tree)                 ; fhere
+      (if (string? tree) (cons tree seed) seed))
+    '()
+    sxml)))
+
+(define (make-char-quotator char-encoding)
+  (let ((bad-chars (list->char-set (map car char-encoding))))
+ 
+    ;; Check to see if str contains one of the characters in charset,
+    ;; from the position i onward. If so, return that character's index.
+    ;; otherwise, return #f
+    (define (index-cset str i charset)
+      (string-index str charset i))
+    
+    ;; The body of the function
+    (lambda (str port)
+      (let ((bad-pos (index-cset str 0 bad-chars)))
+        (if (not bad-pos)
+            (display str port)          ; str had all good chars
+            (let loop ((from 0) (to bad-pos))
+              (cond
+               ((>= from (string-length str)) *unspecified*)
+               ((not to)
+                (display (substring str from (string-length str)) port))
+               (else
+                (let ((quoted-char
+                       (cdr (assv (string-ref str to) char-encoding)))
+                      (new-to
+                       (index-cset str (+ 1 to) bad-chars)))
+                  (if (< from to)
+                      (display (substring str from to) port))
+                  (display quoted-char port)
+                  (loop (1+ to) new-to))))))))))
+
+;; Given a string, check to make sure it does not contain characters
+;; such as '<' or '&' that require encoding. Return either the original
+;; string, or a list of string fragments with special characters
+;; replaced by appropriate character entities.
+
+(define string->escaped-xml
+  (make-char-quotator
+   '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;"))))
+
+;;; arch-tag: 9c853b25-d82f-42ef-a959-ae26fdc7d1ac
+;;; simple.scm ends here
+

data/share/guile/2.2/sxml/ssax/input-parse.scm

@@ -0,0 +1,180 @@
+;;;; (sxml ssax input-parse) -- a simple lexer
+;;;;
+;;;; 	Copyright (C) 2009  Free Software Foundation, Inc.
+;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;;    Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as input-parse.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:
+;;
+;; A simple lexer.
+;;
+;; The procedures in this module surprisingly often suffice to parse an
+;; input stream. They either skip, or build and return tokens, according
+;; to inclusion or delimiting semantics. The list of characters to
+;; expect, include, or to break at may vary from one invocation of a
+;; function to another. This allows the functions to easily parse even
+;; context-sensitive languages.
+;;
+;; EOF is generally frowned on, and thrown up upon if encountered.
+;; Exceptions are mentioned specifically. The list of expected
+;; characters (characters to skip until, or break-characters) may
+;; include an EOF "character", which is to be coded as the symbol,
+;; @code{*eof*}.
+;;
+;; The input stream to parse is specified as a @dfn{port}, which is
+;; usually the last (and optional) argument. It defaults to the current
+;; input port if omitted.
+;;
+;; If the parser encounters an error, it will throw an exception to the
+;; key @code{parser-error}. The arguments will be of the form
+;; @code{(@var{port} @var{message} @var{specialising-msg}*)}.
+;;
+;; The first argument is a port, which typically points to the offending
+;; character or its neighborhood. You can then use @code{port-column}
+;; and @code{port-line} to query the current position. @var{message} is
+;; the description of the error. Other arguments supply more details
+;; about the problem.
+;;
+;;; Code:
+
+(define-module (sxml ssax input-parse)
+  #:use-module (ice-9 rdelim)
+  #:export (peek-next-char
+            assert-curr-char
+            skip-until
+            skip-while
+            next-token
+            next-token-of
+            read-text-line
+            read-string
+            find-string-from-port?))
+
+(define ascii->char integer->char)
+(define char->ascii char->integer)
+(define char-newline #\newline)
+(define char-return #\return)
+(define inc 1+)
+(define dec 1-)
+
+;; rewrite oleg's define-opt into define* style
+(define-macro (define-opt bindings body . body-rest)
+  (let* ((rev-bindings (reverse bindings))
+         (opt-bindings
+          (and (pair? rev-bindings) (pair? (car rev-bindings))
+               (eq? 'optional (caar rev-bindings))
+               (cdar rev-bindings))))
+    (if opt-bindings
+	`(define* ,(append (reverse (cons #:optional (cdr rev-bindings)))
+			  opt-bindings)
+	   ,body ,@body-rest)
+	`(define* ,bindings ,body ,@body-rest))))
+
+(define (parser-error port message . rest)
+  (apply throw 'parser-error port message rest))
+
+(include-from-path "sxml/upstream/input-parse.scm")
+
+;; This version for guile is quite speedy, due to read-delimited (which
+;; is implemented in C).
+(define-opt (next-token prefix-skipped-chars break-chars
+			(optional (comment "") (port (current-input-port))) )
+  (let ((delims (list->string (delete '*eof* break-chars))))
+    (if (eof-object? (if (null? prefix-skipped-chars)
+                         (peek-char port)
+                         (skip-while prefix-skipped-chars port)))
+        (if (memq '*eof* break-chars)
+            ""
+            (parser-error port "EOF while reading a token " comment))
+        (let ((token (read-delimited delims port 'peek)))
+          (if (and (eof-object? (peek-char port))
+                   (not (memq '*eof* break-chars)))
+              (parser-error port "EOF while reading a token " comment)
+              token)))))
+
+(define-opt (read-text-line (optional (port (current-input-port))) )
+  (read-line port))
+
+;; Written 1995, 1996 by Oleg Kiselyov (oleg@acm.org)
+;; Modified 1996, 1997, 1998, 2001 by A. Jaffer (agj@alum.mit.edu)
+;; Modified 2003 by Steve VanDevender (stevev@hexadecimal.uoregon.edu)
+;; Modified 2004 Andy Wingo <wingo at pobox dot com>
+;; This function is from SLIB's strsrch.scm, and is in the public domain.
+(define (find-string-from-port? str <input-port> . max-no-char)
+  "Looks for @var{str} in @var{<input-port>}, optionally within the
+first @var{max-no-char} characters."
+  (set! max-no-char (if (null? max-no-char) #f (car max-no-char)))
+  (letrec
+      ((no-chars-read 0)
+       (peeked? #f)
+       (my-peek-char			; Return a peeked char or #f
+        (lambda () (and (or (not (number? max-no-char))
+                            (< no-chars-read max-no-char))
+                        (let ((c (peek-char <input-port>)))
+                          (cond (peeked? c)
+                                ((eof-object? c) #f)
+                                ((procedure? max-no-char)
+                                 (set! peeked? #t)
+                                 (if (max-no-char c) #f c))
+                                ((eqv? max-no-char c) #f)
+                                (else c))))))
+       (next-char (lambda () (set! peeked? #f) (read-char <input-port>)
+                          (set! no-chars-read  (+ 1 no-chars-read))))
+       (match-1st-char                  ; of the string str
+        (lambda ()
+          (let ((c (my-peek-char)))
+            (and c
+                 (begin (next-char)
+                        (if (char=? c (string-ref str 0))
+                            (match-other-chars 1)
+                            (match-1st-char)))))))
+       ;; There has been a partial match, up to the point pos-to-match
+       ;; (for example, str[0] has been found in the stream)
+       ;; Now look to see if str[pos-to-match] for would be found, too
+       (match-other-chars
+        (lambda (pos-to-match)
+          (if (>= pos-to-match (string-length str))
+              no-chars-read             ; the entire string has matched
+              (let ((c (my-peek-char)))
+                (and c
+                     (if (not (char=? c (string-ref str pos-to-match)))
+                         (backtrack 1 pos-to-match)
+                         (begin (next-char)
+                                (match-other-chars (+ 1 pos-to-match)))))))))
+
+       ;; There had been a partial match, but then a wrong char showed up.
+       ;; Before discarding previously read (and matched) characters, we check
+       ;; to see if there was some smaller partial match. Note, characters read
+       ;; so far (which matter) are those of str[0..matched-substr-len - 1]
+       ;; In other words, we will check to see if there is such i>0 that
+       ;; substr(str,0,j) = substr(str,i,matched-substr-len)
+       ;; where j=matched-substr-len - i
+       (backtrack
+        (lambda (i matched-substr-len)
+          (let ((j (- matched-substr-len i)))
+            (if (<= j 0)
+                ;; backed off completely to the begining of str
+                (match-1st-char)
+                (let loop ((k 0))
+                  (if (>= k j)
+                      (match-other-chars j) ; there was indeed a shorter match
+                      (if (char=? (string-ref str k)
+                                  (string-ref str (+ i k)))
+                          (loop (+ 1 k))
+                          (backtrack (+ 1 i) matched-substr-len))))))))
+       )
+    (match-1st-char)))