scm/to-xml.scm

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