1 ;;;; to-xml.scm -- dump parse tree as xml
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2003--2004 Han-Wen Nienhuys <hanwen@cs.uu.nl>
6 ;;;; Jan Nieuwenhuizen <janneke@gnu.org>
8 (use-modules (ice-9 regex)
13 Todo: this is a quick hack; it makes more sense to define a GOOPS
14 class of a documentnode (similar to how
15 ; the documentation is generated.)
17 That is much cleaner: building the document, and dumping it to output
32 (define-class <xml-node> ()
33 (name #:init-value "" #:accessor node-name #:init-keyword #:name)
34 (value #:init-value "" #:accessor node-value #:init-keyword #:value)
35 (attributes #:init-value '()
36 #:accessor node-attributes
37 #:init-keyword #:attributes)
38 (children #:init-value '()
39 #:accessor node-children
40 #:init-keyword #:children))
44 (SequentialMusic . measure)
53 (define (assoc-get-default key alist default)
54 "Return value if KEY in ALIST, else DEFAULT."
55 (let ((entry (assoc key alist)))
56 (if entry (cdr entry) default)))
58 (define (musicxml-node->string node)
59 (let ((xml-name (assoc-get-default (node-name node) node-names #f)))
61 (if xml-name (open-tag xml-name '() '()) "")
62 (if (equal? (node-value node) "")
65 (apply string-append (map musicxml-node->string (node-children node))))
67 (if xml-name (close-tag xml-name) "")
68 (if xml-name "\n" ""))))
70 (define (xml-node->string node)
73 (open-tag (node-name node) (node-attributes node) '())
74 (if (equal? (node-value node) "")
76 (apply string-append (map xml-node->string (node-children node))))
79 (close-tag (node-name node))))
81 (define (musicxml-duration->xml-node d)
84 #:value (number->string (ash 1 (ly:duration-log d)))))
86 (define (duration->xml-node d)
89 ;; #:value (number->string (ash 1 (ly:duration-log d)))))
90 #:attributes `((log . ,(ly:duration-log d))
91 (dots . ,(ly:duration-dot-count d))
92 (numer . ,(car (ly:duration-factor d)))
93 (denom . ,(cdr (ly:duration-factor d))))))
95 (define (musicxml-pitch->xml-node p)
102 #:value (list-ref '("C" "D" "E" "F" "G" "A" "B")
103 (ly:pitch-notename p)))
106 #:value (number->string (ly:pitch-octave p))))))
108 (define (pitch->xml-node p)
111 #:attributes `((octave . ,(ly:pitch-octave p))
112 (notename . ,(ly:pitch-notename p))
113 (alteration . ,(ly:pitch-alteration p)))))
115 (define (music->xml-node music)
116 (let* ((name (ly:music-property music 'name))
117 (e (ly:music-property music 'element))
118 (es (ly:music-property music 'elements))
119 (mprops (ly:mutable-music-properties music))
120 (d (ly:music-property music 'duration))
121 (p (ly:music-property music 'pitch))
122 (ignore-props '(origin elements duration pitch element)))
129 (if (ly:pitch? p) (list (pitch->xml-node p)) '())
130 (if (ly:duration? d) (list (duration->xml-node d)) '())
131 (if (pair? es) (map music->xml-node es) '())
132 (if (ly:music? e) (list (music->xml-node e)) '())
137 "<?xml version=\"1.0\"?>
146 ;; as computed from input/trip.ly, by
147 ;; http://www.pault.com/pault/dtdgenerator/
149 ;; must recompute with larger, more serious piece, and probably
150 ;; manually add stuff
151 (define preliminary-dtd
153 <!ELEMENT duration EMPTY >
154 <!ATTLIST duration denom ( 1 | 3 | 5 ) #REQUIRED >
155 <!ATTLIST duration dots ( 0 | 1 ) #REQUIRED >
156 <!ATTLIST duration log ( 0 | 1 | 2 | 3 | 4 ) #REQUIRED >
157 <!ATTLIST duration numer ( 1 | 4 ) #REQUIRED >
159 <!ELEMENT music ( duration | music | pitch )* >
160 <!ATTLIST music articulation-type ( lheel | ltoe | marcato | rheel | rtoe | staccato | tenuto ) #IMPLIED >
161 <!ATTLIST music change-to-id NMTOKEN #IMPLIED >
162 <!ATTLIST music change-to-type NMTOKEN #IMPLIED >
163 <!ATTLIST music context-id CDATA #IMPLIED >
164 <!ATTLIST music context-type ( PianoStaff | Score | Staff | Timing | Voice ) #IMPLIED >
165 <!ATTLIST music denominator NMTOKEN #IMPLIED >
166 <!ATTLIST music direction ( 0 | 1 ) #IMPLIED >
167 <!ATTLIST music force-accidental CDATA #IMPLIED >
168 <!ATTLIST music grob-property NMTOKEN #IMPLIED >
169 <!ATTLIST music grob-value CDATA #IMPLIED >
170 <!ATTLIST music iterator-ctor CDATA #IMPLIED >
171 <!ATTLIST music label NMTOKEN #IMPLIED >
172 <!ATTLIST music last-pitch CDATA #IMPLIED >
173 <!ATTLIST music numerator NMTOKEN #IMPLIED >
174 <!ATTLIST music penalty NMTOKEN #IMPLIED >
175 <!ATTLIST music pitch-alist CDATA #IMPLIED >
176 <!ATTLIST music pop-first CDATA #IMPLIED >
177 <!ATTLIST music repeat-count NMTOKEN #IMPLIED >
178 <!ATTLIST music span-direction ( -1 | 1 ) #IMPLIED >
179 <!ATTLIST music span-type NMTOKEN #IMPLIED >
180 <!ATTLIST music symbol NMTOKEN #IMPLIED >
181 <!ATTLIST music text NMTOKEN #IMPLIED >
182 <!ATTLIST music text-type NMTOKEN #IMPLIED >
183 <!ATTLIST music type NMTOKEN #REQUIRED >
184 <!ATTLIST music value CDATA #IMPLIED >
186 <!ELEMENT pitch EMPTY >
187 <!ATTLIST pitch alteration ( 0 | 1 ) #REQUIRED >
188 <!ATTLIST pitch notename ( 0 | 1 | 2 | 3 | 4 | 5 | 6 ) #REQUIRED >
189 <!ATTLIST pitch octave ( -1 | -2 | 0 | 1 ) #REQUIRED >")
196 (error "assertion failed")))
198 (define (re-sub re to string)
199 (regexp-substitute/global #f re string 'pre to 'post))
201 (define (re-sub-alist string alist)
204 (re-sub (caar alist) (cdar alist)
205 (re-sub-alist string (cdr alist)))))
207 (define xml-entities-alist
214 (define (open-tag tag attrs exceptions)
215 (define (candidate? x)
216 (not (memq (car x) exceptions)))
218 (define (dump-attr sym-val)
229 (let ((s (call-with-output-string (lambda (port) (display val port)))))
230 (re-sub-alist s xml-entities-alist))
235 "<" (symbol->string tag)
236 (apply string-append (map dump-attr (filter candidate? attrs)))
239 (define (close-tag name)
240 (string-append "</" (symbol->string name) ">"))
242 (define-public (music-to-xml music port)
243 "Dump XML-ish stuff to PORT."
245 ;; dtd contains # -- This confuses tex during make web.
247 ;; (display (dtd-header) port)
249 (display (open-tag 'music '((type . score)) '()) port)
250 (display (xml-node->string (music->xml-node music)) port)
251 (display (close-tag 'music) port))
253 (define-public (music-to-musicxml music port)
254 "Dump MusicXML-ish stuff to PORT."
256 ;; dtd contains # -- This confuses tex during make web.
258 ;; (display (dtd-header) port)
260 (define pitch->xml-node musicxml-pitch->xml-node)
261 (define duration->xml-node musicxml-duration->xml-node)
263 (display (open-tag 'music '((type . score)) '()) port)
264 (display (musicxml-node->string (music->xml-node music)) port)
265 (display (close-tag 'music) port))