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