1 ;;;; to-xml.scm -- dump parse tree as xml
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2003--2008 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 (pitch->xml-node p)
95 #:attributes `((octave . ,(ly:pitch-octave p))
96 (notename . ,(ly:pitch-notename p))
97 (alteration . ,(ly:pitch-alteration p)))))
99 (define (music->xml-node music)
100 (let* ((name (ly:music-property music 'name))
101 (e (ly:music-property music 'element))
102 (es (ly:music-property music 'elements))
103 (mprops (ly:music-mutable-properties music))
104 (d (ly:music-property music 'duration))
105 (p (ly:music-property music 'pitch))
106 (ignore-props '(origin elements duration pitch element)))
113 (if (ly:pitch? p) (list (pitch->xml-node p)) '())
114 (if (ly:duration? d) (list (duration->xml-node d)) '())
115 (if (pair? es) (map music->xml-node es) '())
116 (if (ly:music? e) (list (music->xml-node e)) '())
121 "<?xml version=\"1.0\"?>
130 ;; as computed from input/trip.ly, by
131 ;; http://www.pault.com/pault/dtdgenerator/
133 ;; must recompute with larger, more serious piece, and probably
134 ;; manually add stuff
135 (define preliminary-dtd
137 <!ELEMENT duration EMPTY >
138 <!ATTLIST duration denom ( 1 | 3 | 5 ) #REQUIRED >
139 <!ATTLIST duration dots ( 0 | 1 ) #REQUIRED >
140 <!ATTLIST duration log ( 0 | 1 | 2 | 3 | 4 ) #REQUIRED >
141 <!ATTLIST duration numer ( 1 | 4 ) #REQUIRED >
143 <!ELEMENT music ( duration | music | pitch )* >
144 <!ATTLIST music articulation-type ( lheel | ltoe | marcato | rheel | rtoe | staccato | tenuto ) #IMPLIED >
145 <!ATTLIST music change-to-id NMTOKEN #IMPLIED >
146 <!ATTLIST music change-to-type NMTOKEN #IMPLIED >
147 <!ATTLIST music context-id CDATA #IMPLIED >
148 <!ATTLIST music context-type ( PianoStaff | Score | Staff | Timing | Voice ) #IMPLIED >
149 <!ATTLIST music denominator NMTOKEN #IMPLIED >
150 <!ATTLIST music direction ( 0 | 1 ) #IMPLIED >
151 <!ATTLIST music force-accidental CDATA #IMPLIED >
152 <!ATTLIST music grob-property NMTOKEN #IMPLIED >
153 <!ATTLIST music grob-value CDATA #IMPLIED >
154 <!ATTLIST music iterator-ctor CDATA #IMPLIED >
155 <!ATTLIST music label NMTOKEN #IMPLIED >
156 <!ATTLIST music last-pitch CDATA #IMPLIED >
157 <!ATTLIST music numerator NMTOKEN #IMPLIED >
158 <!ATTLIST music penalty NMTOKEN #IMPLIED >
159 <!ATTLIST music pitch-alist CDATA #IMPLIED >
160 <!ATTLIST music pop-first CDATA #IMPLIED >
161 <!ATTLIST music repeat-count NMTOKEN #IMPLIED >
162 <!ATTLIST music span-direction ( -1 | 1 ) #IMPLIED >
163 <!ATTLIST music span-type NMTOKEN #IMPLIED >
164 <!ATTLIST music symbol NMTOKEN #IMPLIED >
165 <!ATTLIST music text NMTOKEN #IMPLIED >
166 <!ATTLIST music text-type NMTOKEN #IMPLIED >
167 <!ATTLIST music type NMTOKEN #REQUIRED >
168 <!ATTLIST music value CDATA #IMPLIED >
170 <!ELEMENT pitch EMPTY >
171 <!ATTLIST pitch alteration ( 0 | 1 ) #REQUIRED >
172 <!ATTLIST pitch notename ( 0 | 1 | 2 | 3 | 4 | 5 | 6 ) #REQUIRED >
173 <!ATTLIST pitch octave ( -1 | -2 | 0 | 1 ) #REQUIRED >")
180 (ly:error (_ "assertion failed: ~S") x)))
182 (define (re-sub re to string)
183 (regexp-substitute/global #f re string 'pre to 'post))
185 (define (re-sub-alist string alist)
188 (re-sub (caar alist) (cdar alist)
189 (re-sub-alist string (cdr alist)))))
191 (define xml-entities-alist
198 (define (open-tag tag attrs exceptions)
199 (define (candidate? x)
200 (not (memq (car x) exceptions)))
202 (define (dump-attr sym-val)
203 (let* ((sym (car sym-val))
210 (let ((s (call-with-output-string (lambda (port) (display val port)))))
211 (re-sub-alist s xml-entities-alist))
215 "<" (symbol->string tag)
216 (apply string-append (map dump-attr (filter candidate? attrs)))
219 (define (close-tag name)
220 (string-append "</" (symbol->string name) ">"))
222 (define-public (music-to-xml music port)
223 "Dump XML-ish stuff to PORT."
225 ;; dtd contains # -- This confuses tex during make web.
227 ;; (display (dtd-header) port)
229 (display (open-tag 'music '((type . score)) '()) port)
230 (display (xml-node->string (music->xml-node music)) port)
231 (display (close-tag 'music) port))
233 (define-public (music-to-musicxml music port)
234 "Dump MusicXML-ish stuff to PORT."
236 ;; dtd contains # -- This confuses tex during make web.
238 ;; (display (dtd-header) port)
240 (define duration->xml-node musicxml-duration->xml-node)
242 (display (open-tag 'music '((type . score)) '()) port)
243 (display (musicxml-node->string (music->xml-node music)) port)
244 (display (close-tag 'music) port))