scm/to-xml.scm

   1 (use-modules (ice-9 regex))
   2 "
   3
   4
   5 Todo: this is a quick hack; it makes more sense to define a GOOPS
   6 class of a documentnode (similar to how
   7 ; the documentation is generated.)
   8
   9 That is much cleaner: building the document, and dumping it to output
  10 is then separated.
  11
  12
  13    foo = \score { ... }
  14
  15    #(as-xml foo)
  16
  17    <score>
  18      <music></music>
  19      <paperoutput>
  20      </paperoutput>
  21    </score>
  22
  23
  24
  25 "
  26
  27
  28 (define (dtd-header)
  29   (string-append
  30    "<?xml version=\"1.0\"?>
  31 <!DOCTYPE MUSIC ["
  32    preliminary-dtd
  33    "
  34 ]>
  35
  36 "))
  37
  38
  39 ;; as computed from input/trip.ly, by
  40 ;; http://www.pault.com/pault/dtdgenerator/
  41
  42 ;; must recompute with larger, more serious piece, and probably
  43 ;; manually add stuff
  44 (define preliminary-dtd
  45   "
  46 <!ELEMENT duration EMPTY >
  47 <!ATTLIST duration denom ( 1 | 3 | 5 ) #REQUIRED >
  48 <!ATTLIST duration dots ( 0 | 1 ) #REQUIRED >
  49 <!ATTLIST duration log ( 0 | 1 | 2 | 3 | 4 ) #REQUIRED >
  50 <!ATTLIST duration numer ( 1 | 4 ) #REQUIRED >
  51
  52 <!ELEMENT music ( duration | music | pitch )* >
  53 <!ATTLIST music articulation-type ( lheel | ltoe | marcato | rheel | rtoe | staccato | tenuto ) #IMPLIED >
  54 <!ATTLIST music change-to-id NMTOKEN #IMPLIED >
  55 <!ATTLIST music change-to-type NMTOKEN #IMPLIED >
  56 <!ATTLIST music context-id CDATA #IMPLIED >
  57 <!ATTLIST music context-type ( PianoStaff | Score | Staff | Timing | Voice ) #IMPLIED >
  58 <!ATTLIST music denominator NMTOKEN #IMPLIED >
  59 <!ATTLIST music direction ( 0 | 1 ) #IMPLIED >
  60 <!ATTLIST music force-accidental CDATA #IMPLIED >
  61 <!ATTLIST music grob-property NMTOKEN #IMPLIED >
  62 <!ATTLIST music grob-value CDATA #IMPLIED >
  63 <!ATTLIST music iterator-ctor CDATA #IMPLIED >
  64 <!ATTLIST music label NMTOKEN #IMPLIED >
  65 <!ATTLIST music last-pitch CDATA #IMPLIED >
  66 <!ATTLIST music numerator NMTOKEN #IMPLIED >
  67 <!ATTLIST music penalty NMTOKEN #IMPLIED >
  68 <!ATTLIST music pitch-alist CDATA #IMPLIED >
  69 <!ATTLIST music pop-first CDATA #IMPLIED >
  70 <!ATTLIST music repeat-count NMTOKEN #IMPLIED >
  71 <!ATTLIST music span-direction ( -1 | 1 ) #IMPLIED >
  72 <!ATTLIST music span-type NMTOKEN #IMPLIED >
  73 <!ATTLIST music symbol NMTOKEN #IMPLIED >
  74 <!ATTLIST music text NMTOKEN #IMPLIED >
  75 <!ATTLIST music text-type NMTOKEN #IMPLIED >
  76 <!ATTLIST music type NMTOKEN #REQUIRED >
  77 <!ATTLIST music value CDATA #IMPLIED >
  78
  79 <!ELEMENT pitch EMPTY >
  80 <!ATTLIST pitch alteration ( 0 | 1 ) #REQUIRED >
  81 <!ATTLIST pitch notename ( 0 | 1 | 2 | 3 | 4 | 5 | 6 ) #REQUIRED >
  82 <!ATTLIST pitch octave ( -1 | -2 | 0 | 1 ) #REQUIRED >")
  83
  84
  85
  86
  87 (define (dump-duration d port)
  88  (display (open-tag 'duration
  89             `((log . ,(duration-log d))
  90               (dots . ,(duration-dot-count d))
  91               (numer . ,(car (duration-factor d)))
  92               (denom . ,(cdr (duration-factor d)))
  93               )
  94             '() ) port)
  95  (display  (close-tag 'duration) port))
  96
  97 (define (dump-pitch p port)
  98  (display (open-tag 'pitch
  99             `((octave . ,(pitch-octave p))
 100               (notename . ,(pitch-notename p))
 101               (alteration . ,(pitch-alteration p))
 102               )
 103             '() ) port)
 104  (display  (close-tag 'pitch) port))
 105
 106 ;; should use macro
 107 (define (assert x)
 108   (if x
 109       #t
 110       (error "assertion failed")))
 111
 112 (define (re-sub re to string)
 113   (regexp-substitute/global #f re string 'pre to 'post))
 114
 115 (define (re-sub-alist string alist)
 116   (if (null? alist)
 117       string
 118       (re-sub (caar alist) (cdar alist)
 119               (re-sub-alist string (cdr alist)))))
 120
 121 (define xml-entities-alist
 122   '(("\"" . "&quot;")
 123     ("<" . "&lt;")
 124     (">" . "&gt;")
 125     ("'" . "&apos;")
 126     ("&" . "&amp;")))
 127
 128 (define (open-tag tag attrs exceptions)
 129   (define (candidate? x)
 130     (not (memq (car x) exceptions)))
 131
 132   (define (dump-attr sym-val)
 133     (let*
 134         (
 135         (sym (car sym-val))
 136         (val (cdr sym-val))
 137         )
 138
 139     (string-append
 140      "\n   "
 141     (symbol->string sym)
 142     "=\""
 143
 144     (let ((s (call-with-output-string (lambda (port) (display val port)))))
 145       (re-sub-alist s xml-entities-alist))
 146
 147     "\""
 148     )))
 149
 150   (string-append
 151    "<" (symbol->string tag)
 152    (apply string-append
 153           (map dump-attr (filter-list candidate? attrs)))
 154
 155    ">\n")
 156
 157   )
 158 (define (close-tag name)
 159   (string-append "</" (symbol->string name) ">\n")
 160   )
 161
 162 (define (music-to-xml-helper music port)
 163    (let*
 164        (
 165         (name (ly-get-mus-property music 'name))
 166         (e (ly-get-mus-property music 'element))
 167         (es (ly-get-mus-property music 'elements))
 168         (mprops (ly-get-mutable-properties music))
 169         (p (ly-get-mus-property music 'pitch))
 170         (d (ly-get-mus-property music 'duration))
 171         (ignore-props '(origin elements duration pitch element))
 172         )
 173
 174      ;; As almost everything is music; <SequentialMusic> is
 175      ;; probably better than <music type="SequentialMusic">?
 176
 177      (display (open-tag 'music (cons `(type . ,name) mprops) ignore-props)
 178               port)
 179      (if (duration? d)
 180          (dump-duration d port))
 181      (if (pitch? p)
 182          (dump-pitch p port))
 183      (if (pair? es)
 184          (map (lambda (x) (music-to-xml-helper x port)) es)
 185          )
 186
 187      (if (music? e)
 188          (begin
 189            (music-to-xml-helper e port)))
 190      (display (close-tag 'music) port)
 191    ))
 192
 193
 194 (define-public (music-to-xml music port)
 195   "Dump XML-ish stuff to PORT."
 196   (display (dtd-header) port)
 197   (display (open-tag 'music '((type . score)) '()) port)
 198   (music-to-xml-helper music port)
 199   (display (close-tag 'music) port))