X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fto-xml.scm;h=112c5305651059781d6cbb2c6e53e829b2b317d0;hb=90e4d7057f3857da049dfda3d130017d4719bd6b;hp=a733078a244fa7a4df62095ba85f9a6f10756b09;hpb=18d2d1de39d19eb6239168c01474fee8ba536507;p=lilypond.git diff --git a/scm/to-xml.scm b/scm/to-xml.scm index a733078a24..112c530565 100644 --- a/scm/to-xml.scm +++ b/scm/to-xml.scm @@ -1,6 +1,147 @@ +;;;; 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)) -# as computed from input/trip.ly, by -# http://www.pault.com/pault/dtdgenerator/ +" +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.) + +That is much cleaner: building the document, and dumping it to output +is then separated. + + + foo = \\score { ... } + + #(as-xml foo) + + + + + + +" + +(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 " @@ -42,123 +183,72 @@ ") - -(use-modules (ice-9 regex)) -" - - -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.) - -That is much cleaner: building the document, and dumping it to output -is then separated. - -" - -(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)) - ;; 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) - "=\"" - - - (let ((s (call-with-output-string (lambda (port) (display val port))))) - ;; ugh - (re-sub - "\"" """ - (re-sub - "<" "<" - (re-sub - ">" ">" - (re-sub - "'" "'" - (re-sub - "&" "&" s)))))) - - "\"" - ))) + (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 "<" (symbol->string tag) - (apply string-append - (map dump-attr (filter-list candidate? attrs))) + (string-concatenate (map dump-attr (filter candidate? attrs))) + ">")) - ">\n") - - ) (define (close-tag name) - (string-append "string name) ">\n") - ) - -(define (music-to-xml-helper music 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 'music (cons `(type . ,name) mprops) ignore-props) - port) - (if (duration? d) - (dump-duration d port)) - (if (pitch? p) - (dump-pitch p port)) - (if (pair? es) - (begin - (map (lambda (x) (music-to-xml-helper x port)) es))) - (if (music? e) - (begin - (music-to-xml-helper e port))) - (display (close-tag 'music) port) - )) - - + (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 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) - (music-to-xml-helper music port) + (display (musicxml-node->string (music->xml-node music)) port) (display (close-tag 'music) port))