Fix typo in convert-ly.
[lilypond.git] / scm / to-xml.scm
blob09acee7a65f2e9c1036bb18363d3e5276247c8f2
1 ;;;; to-xml.scm -- dump parse tree as xml
2 ;;;;
3 ;;;;  source file of the GNU LilyPond music typesetter
4 ;;;; 
5 ;;;; (c) 2003--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
6 ;;;;                 Jan Nieuwenhuizen <janneke@gnu.org>
8 (define-module (scm to-xml))
10 (use-modules (ice-9 regex)
11              (srfi srfi-1)
12              (lily)
13              (oop goops))
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
21 is then separated.
24    foo = \\score { ... }
26    #(as-xml foo)
28    <score>
29      <music></music>
30      <layoutoutput>
31      </layoutoutput>
32    </score>
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))
45 (define node-names
46   '((NoteEvent . note)
47     (SequentialMusic . measure)
49     ;;ugh
50     (pitch . pitch)
51     (duration . duration)
52     (octave . octave)
53     (step . step)))
55 (define (musicxml-node->string node)
56   (let ((xml-name (assoc-get (node-name node) node-names #f)))
57     (string-append
58      (if xml-name (open-tag xml-name '() '()) "")
59      (if (equal? (node-value node) "")
60          (string-append
61           (if xml-name "\n" "")
62           (apply string-append (map musicxml-node->string (node-children node))))
63          (node-value node))
64      (if xml-name (close-tag xml-name) "")
65      (if xml-name "\n" ""))))
67 (define (xml-node->string node)
68   (string-append
69    "\n"
70    (open-tag (node-name node) (node-attributes node) '())
71    (if (equal? (node-value node) "")
72        (string-append
73         (apply string-append (map xml-node->string (node-children node))))
74        (node-value node))
75    "\n"
76    (close-tag (node-name node))))
78 (define (musicxml-duration->xml-node d)
79   (make <xml-node>
80     #:name 'duration
81     #:value (number->string (ash 1 (ly:duration-log d)))))
83 (define (duration->xml-node d)
84   (make <xml-node>
85     #:name 'duration
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)
93   (make <xml-node>
94     #:name 'pitch
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)))
107     
108     (make <xml-node>
109       #:name name
110       #:children
111       (apply
112        append
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)) '())
117        '()))))
119 (define (dtd-header)
120   (string-append
121    "<?xml version=\"1.0\"?>
122 <!DOCTYPE MUSIC ["
123    preliminary-dtd
124    "
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
136   "
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 >")
176 ;; should use macro
177 (define (assert x)
178   (if x
179       #t
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)
186   (if (null? alist)
187       string
188       (re-sub (caar alist) (cdar alist)
189               (re-sub-alist string (cdr alist)))))
191 (define xml-entities-alist
192   '(("\"" . "&quot;")
193     ("<" . "&lt;")
194     (">" . "&gt;")
195     ("'" . "&apos;")
196     ("&" . "&amp;")))
198 (define (open-tag tag attrs exceptions)
199   (define (candidate? x)
200     (not (memq (car x) exceptions)))
201   
202   (define (dump-attr sym-val)
203     (let* ((sym (car sym-val))
204            (val (cdr sym-val)))
205       
206       (string-append
207        "\n   "
208        (symbol->string sym)
209        "=\""
210        (let ((s (call-with-output-string (lambda (port) (display val port)))))
211          (re-sub-alist s xml-entities-alist))
212        "\"")))
214   (string-append
215    "<" (symbol->string tag)
216    (apply string-append (map dump-attr (filter candidate? attrs)))
217    ">"))
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.
226   ;;
227   ;;  (display (dtd-header) port)
228   
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.
237   ;;
238   ;;  (display (dtd-header) port)
240   (define duration->xml-node musicxml-duration->xml-node)
241   
242   (display (open-tag 'music '((type . score)) '()) port)
243   (display (musicxml-node->string (music->xml-node music)) port)
244   (display (close-tag 'music) port))