scm/to-xml.scm

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