1 ;;;; to-xml.scm -- dump parse tree as xml
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2003--2006 Han-Wen Nienhuys <hanwen@xs4all.nl>
6 ;;;; Jan Nieuwenhuizen <janneke@gnu.org>
8 (define-module (scm to-xml))
10 (use-modules (ice-9 regex)
16 Todo: this is a quick hack; it makes more sense to define a GOOPS
17 class of a documentnode (similar to how
18 ; the documentation is generated.)
20 That is much cleaner: building the document, and dumping it to output
35 (define-class <xml-node> ()
36 (name #:init-value "" #:accessor node-name #:init-keyword #:name)
37 (value #:init-value "" #:accessor node-value #:init-keyword #:value)
38 (attributes #:init-value '()
39 #:accessor node-attributes
40 #:init-keyword #:attributes)
41 (children #:init-value '()
42 #:accessor node-children
43 #:init-keyword #:children))
47 (SequentialMusic . measure)
55 (define (musicxml-node->string node)
56 (let ((xml-name (assoc-get (node-name node) node-names #f)))
58 (if xml-name (open-tag xml-name '() '()) "")
59 (if (equal? (node-value node) "")
62 (apply string-append (map musicxml-node->string (node-children node))))
64 (if xml-name (close-tag xml-name) "")
65 (if xml-name "\n" ""))))
67 (define (xml-node->string node)
70 (open-tag (node-name node) (node-attributes node) '())
71 (if (equal? (node-value node) "")
73 (apply string-append (map xml-node->string (node-children node))))
76 (close-tag (node-name node))))
78 (define (musicxml-duration->xml-node d)
81 #:value (number->string (ash 1 (ly:duration-log d)))))
83 (define (duration->xml-node d)
86 ;; #:value (number->string (ash 1 (ly:duration-log d)))))
87 #:attributes `((log . ,(ly:duration-log d))
88 (dots . ,(ly:duration-dot-count d))
89 (numer . ,(car (ly:duration-factor d)))
90 (denom . ,(cdr (ly:duration-factor d))))))
92 (define (musicxml-pitch->xml-node p)
99 #:value (list-ref '("C" "D" "E" "F" "G" "A" "B")
100 (ly:pitch-notename p)))
103 #:value (number->string (ly:pitch-octave p))))))
105 (define (pitch->xml-node p)
108 #:attributes `((octave . ,(ly:pitch-octave p))
109 (notename . ,(ly:pitch-notename p))
110 (alteration . ,(ly:pitch-alteration p)))))
112 (define (music->xml-node music)
113 (let* ((name (ly:music-property music 'name))
114 (e (ly:music-property music 'element))
115 (es (ly:music-property music 'elements))
116 (mprops (ly:music-mutable-properties music))
117 (d (ly:music-property music 'duration))
118 (p (ly:music-property music 'pitch))
119 (ignore-props '(origin elements duration pitch element)))
126 (if (ly:pitch? p) (list (pitch->xml-node p)) '())
127 (if (ly:duration? d) (list (duration->xml-node d)) '())
128 (if (pair? es) (map music->xml-node es) '())
129 (if (ly:music? e) (list (music->xml-node e)) '())
134 "<?xml version=\"1.0\"?>
143 ;; as computed from input/trip.ly, by
144 ;; http://www.pault.com/pault/dtdgenerator/
146 ;; must recompute with larger, more serious piece, and probably
147 ;; manually add stuff
148 (define preliminary-dtd
150 <!ELEMENT duration EMPTY >
151 <!ATTLIST duration denom ( 1 | 3 | 5 ) #REQUIRED >
152 <!ATTLIST duration dots ( 0 | 1 ) #REQUIRED >
153 <!ATTLIST duration log ( 0 | 1 | 2 | 3 | 4 ) #REQUIRED >
154 <!ATTLIST duration numer ( 1 | 4 ) #REQUIRED >
156 <!ELEMENT music ( duration | music | pitch )* >
157 <!ATTLIST music articulation-type ( lheel | ltoe | marcato | rheel | rtoe | staccato | tenuto ) #IMPLIED >
158 <!ATTLIST music change-to-id NMTOKEN #IMPLIED >
159 <!ATTLIST music change-to-type NMTOKEN #IMPLIED >
160 <!ATTLIST music context-id CDATA #IMPLIED >
161 <!ATTLIST music context-type ( PianoStaff | Score | Staff | Timing | Voice ) #IMPLIED >
162 <!ATTLIST music denominator NMTOKEN #IMPLIED >
163 <!ATTLIST music direction ( 0 | 1 ) #IMPLIED >
164 <!ATTLIST music force-accidental CDATA #IMPLIED >
165 <!ATTLIST music grob-property NMTOKEN #IMPLIED >
166 <!ATTLIST music grob-value CDATA #IMPLIED >
167 <!ATTLIST music iterator-ctor CDATA #IMPLIED >
168 <!ATTLIST music label NMTOKEN #IMPLIED >
169 <!ATTLIST music last-pitch CDATA #IMPLIED >
170 <!ATTLIST music numerator NMTOKEN #IMPLIED >
171 <!ATTLIST music penalty NMTOKEN #IMPLIED >
172 <!ATTLIST music pitch-alist CDATA #IMPLIED >
173 <!ATTLIST music pop-first CDATA #IMPLIED >
174 <!ATTLIST music repeat-count NMTOKEN #IMPLIED >
175 <!ATTLIST music span-direction ( -1 | 1 ) #IMPLIED >
176 <!ATTLIST music span-type NMTOKEN #IMPLIED >
177 <!ATTLIST music symbol NMTOKEN #IMPLIED >
178 <!ATTLIST music text NMTOKEN #IMPLIED >
179 <!ATTLIST music text-type NMTOKEN #IMPLIED >
180 <!ATTLIST music type NMTOKEN #REQUIRED >
181 <!ATTLIST music value CDATA #IMPLIED >
183 <!ELEMENT pitch EMPTY >
184 <!ATTLIST pitch alteration ( 0 | 1 ) #REQUIRED >
185 <!ATTLIST pitch notename ( 0 | 1 | 2 | 3 | 4 | 5 | 6 ) #REQUIRED >
186 <!ATTLIST pitch octave ( -1 | -2 | 0 | 1 ) #REQUIRED >")
193 (ly:error (_ "assertion failed: ~S") x)))
195 (define (re-sub re to string)
196 (regexp-substitute/global #f re string 'pre to 'post))
198 (define (re-sub-alist string alist)
201 (re-sub (caar alist) (cdar alist)
202 (re-sub-alist string (cdr alist)))))
204 (define xml-entities-alist
211 (define (open-tag tag attrs exceptions)
212 (define (candidate? x)
213 (not (memq (car x) exceptions)))
215 (define (dump-attr sym-val)
216 (let* ((sym (car sym-val))
223 (let ((s (call-with-output-string (lambda (port) (display val port)))))
224 (re-sub-alist s xml-entities-alist))
228 "<" (symbol->string tag)
229 (apply string-append (map dump-attr (filter candidate? attrs)))
232 (define (close-tag name)
233 (string-append "</" (symbol->string name) ">"))
235 (define-public (music-to-xml music port)
236 "Dump XML-ish stuff to PORT."
238 ;; dtd contains # -- This confuses tex during make web.
240 ;; (display (dtd-header) port)
242 (display (open-tag 'music '((type . score)) '()) port)
243 (display (xml-node->string (music->xml-node music)) port)
244 (display (close-tag 'music) port))
246 (define-public (music-to-musicxml music port)
247 "Dump MusicXML-ish stuff to PORT."
249 ;; dtd contains # -- This confuses tex during make web.
251 ;; (display (dtd-header) port)
253 (define pitch->xml-node musicxml-pitch->xml-node)
254 (define duration->xml-node musicxml-duration->xml-node)
256 (display (open-tag 'music '((type . score)) '()) port)
257 (display (musicxml-node->string (music->xml-node music)) port)
258 (display (close-tag 'music) port))