X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fto-xml.scm;h=112c5305651059781d6cbb2c6e53e829b2b317d0;hb=85e78f77fdceb5b073bb2c5696c3117a5b1c220e;hp=105d93bb75a4626633fb89fe00a9630ee51cee40;hpb=b13fd24fb3933c220c97f085ce731dce425d5917;p=lilypond.git diff --git a/scm/to-xml.scm b/scm/to-xml.scm index 105d93bb75..112c530565 100644 --- a/scm/to-xml.scm +++ b/scm/to-xml.scm @@ -1,106 +1,254 @@ +;;;; This file is part of LilyPond, the GNU music typesetter. +;;;; +;;;; 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)) +" 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. + + foo = \\score { ... } + + #(as-xml foo) + + + + + + " -(define (dump-duration d port) - (display (open-tag "duration" - `((log . ,(duration-log d)) - (dots . ,(duration-dot-count d)) - (numer . ,(car (duration-factor d))) - (denom . ,(cdr (duration-factor d))) - ) - '() ) port) - (display (close-tag 'duration) port)) - -(define (dump-pitch p port) - (display (open-tag "pitch" - `((octave . ,(pitch-octave p)) - (notename . ,(pitch-notename p)) - (alteration . ,(pitch-alteration p)) - ) - '() ) port) - (display (close-tag 'pitch) port)) +(define-class () + (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) + (children #:init-value '() + #:accessor node-children + #:init-keyword #:children)) + +(define node-names + '((NoteEvent . note) + (SequentialMusic . measure) + + ;;ugh + (pitch . pitch) + (duration . duration) + (octave . octave) + (step . step))) + +(define (musicxml-node->string node) + (let ((xml-name (assoc-get (node-name node) node-names #f))) + (string-append + (if xml-name (open-tag xml-name '() '()) "") + (if (equal? (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" "")))) + +(define (xml-node->string node) + (string-append + "\n" + (open-tag (node-name node) (node-attributes node) '()) + (if (equal? (node-value node) "") + (string-concatenate (map xml-node->string (node-children node))) + (node-value node)) + "\n" + (close-tag (node-name node)))) + +(define (musicxml-duration->xml-node d) + (make + #:name 'duration + #:value (number->string (ash 1 (ly:duration-log d))))) + +(define (duration->xml-node d) + (make + #: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)))))) + +(define (pitch->xml-node p) + (make + #:name 'pitch + #:attributes `((octave . ,(ly:pitch-octave 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))) + + (make + #:name name + #:children + (apply + append + (if (ly:pitch? p) (list (pitch->xml-node p)) '()) + (if (ly:duration? d) (list (duration->xml-node d)) '()) + (if (pair? es) (map music->xml-node es) '()) + (if (ly:music? e) (list (music->xml-node e)) '()) + '())))) + +(define (dtd-header) + (string-append + " + + +")) + + +;; as computed from input/trip.ly, by +;; http://www.pault.com/pault/dtdgenerator/ + +;; must recompute with larger, more serious piece, and probably +;; manually add stuff +(define preliminary-dtd + " + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +") + ;; should use macro (define (assert x) (if x #t - (error "assertion failed"))) + (ly:error (_ "assertion failed: ~S") x))) + +(define (re-sub re to string) + (regexp-substitute/global #f re string 'pre to 'post)) + +(define (re-sub-alist string alist) + (if (null? alist) + string + (re-sub (caar alist) (cdar alist) + (re-sub-alist string (cdr alist))))) + +(define xml-entities-alist + '(("\"" . """) + ("<" . "<") + (">" . ">") + ("'" . "'") + ("&" . "&"))) (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)) - ) - - (string-append - "\n " - (symbol->string sym) - "=\"" - - (call-with-output-string (lambda (port) (display val port))) - "\"" - ))) + (let* ((sym (car 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)) + "\""))) (string-append - "<" tag - (apply string-append - (map dump-attr (filter-list candidate? attrs))) + "<" (symbol->string tag) + (string-concatenate (map dump-attr (filter candidate? attrs))) + ">")) - ">\n") - - ) (define (close-tag name) - (string-append "string name) ">\n") - ) + (string-append "string name) ">")) (define-public (music-to-xml music port) - "Dump XML-ish stuff to PORT." - (let* - ( - (name (ly-get-mus-property music 'name)) - (e (ly-get-mus-property music 'element)) - (es (ly-get-mus-property music 'elements)) - (mprops (ly-get-mutable-properties music)) - (p (ly-get-mus-property music 'pitch)) - (d (ly-get-mus-property music 'duration)) - (ignore-props '(origin elements duration pitch element)) - ) - - (display (open-tag (symbol->string name) mprops ignore-props) port) - (if (duration? d) - (dump-duration d port)) - (if (pitch? p) - (dump-pitch p port)) - (if (pair? es) - (begin - (display "" port) - (map (lambda (x) (music-to-xml x port)) es) - (display "" port) - )) - - (if (music? e) - (begin - (display "" port) - (music-to-xml e port) - (display "" port) - )) - (display (close-tag name) port) - )) - - + "Dump XML-ish stuff to @var{port}." + + ;; 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 @var{port}." + + ;; 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))