X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fto-xml.scm;h=112c5305651059781d6cbb2c6e53e829b2b317d0;hb=HEAD;hp=437cc03b4af6becca1f2574b31430d67f0a99c7f;hpb=f9214bac21e9926dc3248416f58190c98c4167a9;p=lilypond.git diff --git a/scm/to-xml.scm b/scm/to-xml.scm index 437cc03b4a..112c530565 100644 --- a/scm/to-xml.scm +++ b/scm/to-xml.scm @@ -1,21 +1,32 @@ -;;;; to-xml.scm -- dump parse tree as xml +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 2003--2006 Han-Wen Nienhuys +;;;; Copyright (C) 2003--2015 Han-Wen Nienhuys ;;;; Jan Nieuwenhuizen +;;;; +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; LilyPond 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 General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . (define-module (scm to-xml)) (use-modules (ice-9 regex) - (srfi srfi-1) - (lily) - (oop goops)) + (srfi srfi-1) + (lily) + (oop goops)) " Todo: this is a quick hack; it makes more sense to define a GOOPS class of a documentnode (similar to how -; the documentation is generated.) +the documentation is generated.) That is much cleaner: building the document, and dumping it to output is then separated. @@ -36,11 +47,11 @@ is then separated. (name #:init-value "" #:accessor node-name #:init-keyword #:name) (value #:init-value "" #:accessor node-value #:init-keyword #:value) (attributes #:init-value '() - #:accessor node-attributes - #:init-keyword #:attributes) + #:accessor node-attributes + #:init-keyword #:attributes) (children #:init-value '() - #:accessor node-children - #:init-keyword #:children)) + #:accessor node-children + #:init-keyword #:children)) (define node-names '((NoteEvent . note) @@ -57,10 +68,10 @@ is then separated. (string-append (if xml-name (open-tag xml-name '() '()) "") (if (equal? (node-value node) "") - (string-append - (if xml-name "\n" "") - (apply string-append (map musicxml-node->string (node-children node)))) - (node-value node)) + (string-append + (if xml-name "\n" "") + (string-concatenate (map musicxml-node->string (node-children node)))) + (node-value node)) (if xml-name (close-tag xml-name) "") (if xml-name "\n" "")))) @@ -69,8 +80,7 @@ is then separated. "\n" (open-tag (node-name node) (node-attributes node) '()) (if (equal? (node-value node) "") - (string-append - (apply string-append (map xml-node->string (node-children node)))) + (string-concatenate (map xml-node->string (node-children node))) (node-value node)) "\n" (close-tag (node-name node)))) @@ -85,26 +95,26 @@ is then separated. #:name 'duration ;; #:value (number->string (ash 1 (ly:duration-log d))))) #:attributes `((log . ,(ly:duration-log d)) - (dots . ,(ly:duration-dot-count d)) - (numer . ,(car (ly:duration-factor d))) - (denom . ,(cdr (ly:duration-factor d)))))) + (dots . ,(ly:duration-dot-count d)) + (numer . ,(car (ly:duration-factor d))) + (denom . ,(cdr (ly:duration-factor d)))))) (define (pitch->xml-node p) (make #:name 'pitch #:attributes `((octave . ,(ly:pitch-octave p)) - (notename . ,(ly:pitch-notename p)) - (alteration . ,(ly:pitch-alteration p))))) + (notename . ,(ly:pitch-notename p)) + (alteration . ,(ly:pitch-alteration p))))) (define (music->xml-node music) (let* ((name (ly:music-property music 'name)) - (e (ly:music-property music 'element)) - (es (ly:music-property music 'elements)) - (mprops (ly:music-mutable-properties music)) - (d (ly:music-property music 'duration)) - (p (ly:music-property music 'pitch)) - (ignore-props '(origin elements duration pitch element))) - + (e (ly:music-property music 'element)) + (es (ly:music-property music 'elements)) + (mprops (ly:music-mutable-properties music)) + (d (ly:music-property music 'duration)) + (p (ly:music-property music 'pitch)) + (ignore-props '(origin elements duration pitch element))) + (make #:name name #:children @@ -186,7 +196,7 @@ is then separated. (if (null? alist) string (re-sub (caar alist) (cdar alist) - (re-sub-alist string (cdr alist))))) + (re-sub-alist string (cdr alist))))) (define xml-entities-alist '(("\"" . """) @@ -198,48 +208,47 @@ is then separated. (define (open-tag tag attrs exceptions) (define (candidate? x) (not (memq (car x) exceptions))) - + (define (dump-attr sym-val) (let* ((sym (car sym-val)) - (val (cdr sym-val))) - + (val (cdr sym-val))) + (string-append "\n " (symbol->string sym) "=\"" (let ((s (call-with-output-string (lambda (port) (display val port))))) - (re-sub-alist s xml-entities-alist)) + (re-sub-alist s xml-entities-alist)) "\""))) (string-append "<" (symbol->string tag) - (apply string-append (map dump-attr (filter candidate? attrs))) + (string-concatenate (map dump-attr (filter candidate? attrs))) ">")) (define (close-tag name) (string-append "string name) ">")) (define-public (music-to-xml music port) - "Dump XML-ish stuff to PORT." + "Dump XML-ish stuff to @var{port}." - ;; dtd contains # -- This confuses tex during make web. + ;; dtd contains # -- This confuses tex during make doc. ;; ;; (display (dtd-header) port) - + (display (open-tag 'music '((type . score)) '()) port) (display (xml-node->string (music->xml-node music)) port) (display (close-tag 'music) port)) (define-public (music-to-musicxml music port) - "Dump MusicXML-ish stuff to PORT." + "Dump MusicXML-ish stuff to @var{port}." - ;; dtd contains # -- This confuses tex during make web. + ;; dtd contains # -- This confuses tex during make doc. ;; ;; (display (dtd-header) port) (define duration->xml-node musicxml-duration->xml-node) - + (display (open-tag 'music '((type . score)) '()) port) (display (musicxml-node->string (music->xml-node music)) port) (display (close-tag 'music) port)) -