scm/to-xml.scm

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