extract meta data from lilypond compilation
* write that as yaml file next to the other outputs * extract lyrics
This commit is contained in:
@@ -20,7 +20,8 @@
|
||||
"scm" file-name-separator-string filename
|
||||
)))))
|
||||
(scm-load "resolve_inherits.scm")
|
||||
(scm-load "yaml_parser.scm")))
|
||||
(scm-load "yaml_parser.scm")
|
||||
(scm-load "yaml_writer.scm")))
|
||||
|
||||
#(define (song-includes-data-path filename)
|
||||
(string-join
|
||||
@@ -39,6 +40,7 @@
|
||||
\include "title_with_category_images.ily"
|
||||
\include "chord_settings.ily"
|
||||
\include "chordpro.ily"
|
||||
\include "data_extractor.ily"
|
||||
\include "transposition.ily"
|
||||
\include "markup_tag_groups_hack.ily"
|
||||
\include "verses_with_chords.ily"
|
||||
|
||||
@@ -0,0 +1,413 @@
|
||||
%%% Extrahiert Informationen aus einem ly:music-Objekt und liefert eine alist
|
||||
%%% mit String-Werten zurueck (z.B. ((time . "4/4") (key . "d minor"))).
|
||||
%%% Benoetigt LilyPond >= 2.26.
|
||||
|
||||
%% note-name->lily-string liegt im Modul (lily display-lily).
|
||||
#(use-modules (lily display-lily))
|
||||
|
||||
#(begin
|
||||
|
||||
;; --- Taktangabe --------------------------------------------------------
|
||||
|
||||
;; Numerator einer Taktangabe kann eine Zahl oder eine Liste sein.
|
||||
(define (numerator->string num)
|
||||
(if (list? num)
|
||||
(string-join (map number->string num) "+")
|
||||
(number->string num)))
|
||||
|
||||
;; Ein einzelner Bruch ist ein Paar (numerator . denominator), der
|
||||
;; Numerator eine Zahl oder eine Liste (z.B. 3+3/8).
|
||||
(define (fraction->string frac)
|
||||
(string-append (numerator->string (car frac)) "/"
|
||||
(number->string (cdr frac))))
|
||||
|
||||
;; Liefert die Taktangabe als String (z.B. "4/4", "3+3/8" oder
|
||||
;; "3+3/8 + 2/8") oder #f. time-signature ist ein Bruch oder bei
|
||||
;; zusammengesetzten Taktarten (\timeAbbrev, \compoundMeter) eine
|
||||
;; Liste von Bruechen.
|
||||
(define (time-music->string m)
|
||||
(let ((ts (ly:music-property m 'time-signature)))
|
||||
(and (pair? ts)
|
||||
(if (number? (cdr ts))
|
||||
(fraction->string ts)
|
||||
(string-join (map fraction->string ts) " + ")))))
|
||||
|
||||
;; --- Tempo ---------------------------------------------------------------
|
||||
|
||||
;; Liefert die Tempoangabe als String (z.B. "4 = 130", "4. = 60-70",
|
||||
;; "Allegro" oder "Allegro (4 = 130)") oder #f.
|
||||
(define (tempo-music->string m)
|
||||
(let* ((unit (ly:music-property m 'tempo-unit))
|
||||
(count (ly:music-property m 'metronome-count))
|
||||
(text (ly:music-property m 'text))
|
||||
(unit-s (and (ly:duration? unit)
|
||||
(string-append
|
||||
(number->string (expt 2 (ly:duration-log unit)))
|
||||
(make-string (ly:duration-dot-count unit) #\.))))
|
||||
(count-s (cond ((number? count) (number->string count))
|
||||
((pair? count) (ly:format "~a-~a" (car count) (cdr count)))
|
||||
(else #f)))
|
||||
(metronome-s (and unit-s count-s (string-append unit-s " = " count-s)))
|
||||
(text-s (and (markup? text) (markup->string text))))
|
||||
(cond
|
||||
((and text-s metronome-s) (string-append text-s " (" metronome-s ")"))
|
||||
(metronome-s metronome-s)
|
||||
(text-s text-s)
|
||||
(else #f))))
|
||||
|
||||
;; --- Tonart ------------------------------------------------------------
|
||||
|
||||
;; Liefert die Tonart als String (z.B. "d minor" oder "c major") oder #f.
|
||||
;; Vorgehen wie in LilyPonds eigenem \displayMusic (define-music-display-
|
||||
;; methods.scm): pitch-alist nach c zuruecktransponieren und mit den
|
||||
;; bekannten Modus-Definitionen vergleichen. note-name->lily-string liefert
|
||||
;; den Grundton in der aktuell eingestellten Notensprache.
|
||||
(define (key-music->string m)
|
||||
(let ((tonic (ly:music-property m 'tonic))
|
||||
(alist (ly:music-property m 'pitch-alist)))
|
||||
(and (ly:pitch? tonic) (pair? alist)
|
||||
(let* ((c-alist (ly:transpose-key-alist alist (- tonic)))
|
||||
(mode (any (lambda (mode)
|
||||
(and (equal? (ly:parser-lookup mode) c-alist)
|
||||
(symbol->string mode)))
|
||||
'(major minor))))
|
||||
(and mode
|
||||
(string-append (symbol->string (note-name->lily-string tonic))
|
||||
" " mode))))))
|
||||
|
||||
;; --- Header-Metadaten ----------------------------------------------------
|
||||
|
||||
;; Header-Felder, die eigentlich Layoutsachen sind (gehoerten nach paper)
|
||||
;; und deshalb nicht mit exportiert werden.
|
||||
(define ignored-header-fields
|
||||
'(titlesize titletopspace tagline between-poet-and-composer-markup))
|
||||
|
||||
;; categories ist im Header ein String mit Leerzeichen ("trist satz")
|
||||
;; und wird als Liste von Woertern exportiert.
|
||||
(define (header-value key value)
|
||||
(if (and (eq? key 'categories) (string? value))
|
||||
(string-tokenize value)
|
||||
value))
|
||||
|
||||
;; Nimmt einen Bookpart entgegen (wie HEADER aus pool_bottom.ily) und
|
||||
;; liefert dessen Header-Felder als alist, z.B.
|
||||
;; ((title . "Ako umram") (authors . (("..." text melody))) ...).
|
||||
;; Die Werte bleiben unveraendert, wie sie im \header definiert wurden
|
||||
;; (Strings, Listen, Markups ...).
|
||||
(define (bookpart->header-alist bookpart)
|
||||
(let ((header (ly:book-header bookpart)))
|
||||
(if (module? header)
|
||||
(sort
|
||||
(filter-map (lambda (entry)
|
||||
(and (variable-bound? (cdr entry))
|
||||
(not (memq (car entry) ignored-header-fields))
|
||||
(cons (car entry)
|
||||
(header-value (car entry)
|
||||
(variable-ref (cdr entry))))))
|
||||
(module-map cons header))
|
||||
(lambda (a b)
|
||||
(string<? (symbol->string (car a))
|
||||
(symbol->string (car b)))))
|
||||
'())))
|
||||
|
||||
;; --- Lyrics --------------------------------------------------------------
|
||||
|
||||
;; Silbentext (String oder Markup) als String. Eine Tilde verbindet als
|
||||
;; Lyric-Bindebogen zwei Woerter auf einer Note und wird zum Leerzeichen.
|
||||
(define (syllable->string text)
|
||||
(let ((s (cond ((string? text) text)
|
||||
((markup? text) (markup->string text))
|
||||
(else ""))))
|
||||
(string-map (lambda (c) (if (char=? c #\~) #\space c)) s)))
|
||||
|
||||
;; Stanza-Beschriftung, wie sie gedruckt wuerde; vgl. handle-stanza-numbers
|
||||
;; bzw. refMarkupFormatter/bridgeMarkupFormatter in
|
||||
;; basic_format_and_style_settings.ily. text ist ein direkt per
|
||||
;; \set stanza = "..." gesetzter Wert und gewinnt.
|
||||
(define (stanza-label type numbers text)
|
||||
(define (joined-numbers)
|
||||
(string-join (map (lambda (n) (ly:format "~a" n)) numbers) ", "))
|
||||
(define (formatted plain with-numbers)
|
||||
(if (null? numbers)
|
||||
(ly:parser-lookup plain)
|
||||
(ly:format (ly:parser-lookup with-numbers) (joined-numbers))))
|
||||
(cond
|
||||
(text text)
|
||||
((eq? type 'ref) (formatted 'refString 'refStringWithNumbers))
|
||||
((eq? type 'bridge) (formatted 'bridgeString 'bridgeStringWithNumbers))
|
||||
((pair? numbers)
|
||||
(string-join
|
||||
(map (lambda (n) (format #f (ly:parser-lookup 'stanzaFormat) n)) numbers)
|
||||
", "))
|
||||
(else "")))
|
||||
|
||||
;; Wandelt ein Lyrics-Music-Objekt (eine Zeile aus \addlyrics bzw. das
|
||||
;; Argument von \chordlyrics) in eine Liste von Eintraegen der Form
|
||||
;; (marked? nummern . ((stanza . "1.") (type . verse) (text . "Auf die ...")))
|
||||
;; Silben werden an HyphenEvents wieder zu Woertern zusammengesetzt.
|
||||
;; Strophengrenzen ergeben sich aus den StanzaNumber-Overrides von
|
||||
;; #(stanza n), \ref und \bridge sowie aus \set stanza = "...".
|
||||
;; marked? ist #f fuer Fortsetzungsfragmente: Abschnitte ohne Marker oder
|
||||
;; mit dem Zeilenumbruch-Marker \set stanza = "-" (right-/leftHyphen).
|
||||
;; \set stanza mit Markup-Wert (Wiederholungszeichen, "D.S." usw.) ist
|
||||
;; reine Dekoration mitten im Vers und beginnt keine neue Strophe.
|
||||
(define (lyric-line->stanzas lyrics)
|
||||
(let ((stanzas '()) ; fertige Eintraege, rueckwaerts
|
||||
(words '()) ; fertige Woerter der aktuellen Strophe, rueckwaerts
|
||||
(word "") ; offene Silbenkette
|
||||
(type #f) ; 'verse / 'ref / 'bridge
|
||||
(numbers '()) ; Strophennummern
|
||||
(set-label #f)) ; direkt gesetztes \set stanza = "..."
|
||||
(define (flush-word!)
|
||||
(unless (string-null? word)
|
||||
(set! words (cons word words))
|
||||
(set! word "")))
|
||||
(define (flush-stanza!)
|
||||
(flush-word!)
|
||||
(when (or type set-label (pair? words))
|
||||
(set! stanzas
|
||||
(cons (cons* (if (or type (and set-label (not (string=? set-label "-")))) #t #f)
|
||||
numbers
|
||||
(list (cons 'stanza (stanza-label type numbers set-label))
|
||||
(cons 'type (or type 'verse))
|
||||
(cons 'text (string-join (reverse words) " "))))
|
||||
stanzas))
|
||||
(set! words '())
|
||||
(set! type #f)
|
||||
(set! numbers '())
|
||||
(set! set-label #f)))
|
||||
;; Ein neuer Marker beendet die laufende Strophe, sobald schon Text da ist.
|
||||
(define (marker!)
|
||||
(when (or (pair? words) (not (string-null? word)))
|
||||
(flush-stanza!)))
|
||||
(define (handle-lyric-event m)
|
||||
(let ((s (syllable->string (ly:music-property m 'text)))
|
||||
(hyphen? (any (lambda (a)
|
||||
(eq? (ly:music-property a 'name) 'HyphenEvent))
|
||||
(ly:music-property m 'articulations '()))))
|
||||
(if (string-null? (string-trim-both s))
|
||||
(flush-word!) ; "_"-Skip kommt als " " an und beendet nur das Wort
|
||||
(begin
|
||||
(set! word (string-append word s))
|
||||
(unless hyphen? (flush-word!))))))
|
||||
(define (handle-override m)
|
||||
(when (eq? (ly:music-property m 'symbol) 'StanzaNumber)
|
||||
(let ((path (ly:music-property m 'grob-property-path))
|
||||
(value (ly:music-property m 'grob-value)))
|
||||
(cond
|
||||
((equal? path '(details custom-stanza-type))
|
||||
(marker!)
|
||||
(set! type value))
|
||||
((equal? path '(details custom-stanza-numbers))
|
||||
(marker!)
|
||||
(set! numbers (if (list? value) value (list value))))))))
|
||||
(define (handle-set m)
|
||||
(let ((value (ly:music-property m 'value)))
|
||||
;; Nur String-Werte; Markups (Wiederholungszeichen etc.) sind
|
||||
;; Dekoration mitten im Vers und keine Strophengrenze.
|
||||
(when (and (eq? (ly:music-property m 'symbol) 'stanza)
|
||||
(string? value))
|
||||
(marker!)
|
||||
(set! set-label value))))
|
||||
(define (walk m)
|
||||
(case (ly:music-property m 'name)
|
||||
((LyricEvent) (handle-lyric-event m))
|
||||
((OverrideProperty) (handle-override m))
|
||||
((PropertySet) (handle-set m))
|
||||
(else
|
||||
(let ((element (ly:music-property m 'element)))
|
||||
(if (ly:music? element) (walk element))
|
||||
(for-each (lambda (e) (if (ly:music? e) (walk e)))
|
||||
(ly:music-property m 'elements))))))
|
||||
(walk lyrics)
|
||||
(flush-stanza!)
|
||||
(merge-reprinted (reverse stanzas))))
|
||||
|
||||
;; Beim Zeilenumbruch im Notenbild wird die Strophennummer manchmal erneut
|
||||
;; gedruckt (z.B. \firstVerseB #(stanza 1) \firstVerseC). Ein Marker
|
||||
;; direkt nach einer Strophe mit gleicher Kennung oder deren
|
||||
;; Nummern-Obermenge (#(stanza 2 3) nach Strophe 2) setzt diese fort,
|
||||
;; statt eine neue Strophe zu beginnen.
|
||||
(define (merge-reprinted entries)
|
||||
(let loop ((remaining entries) (acc '()))
|
||||
(if (null? remaining)
|
||||
(reverse acc)
|
||||
(let ((entry (car remaining)))
|
||||
(if (and (pair? acc)
|
||||
(car entry) ; aktueller Eintrag markiert
|
||||
(car (car acc)) ; vorheriger Eintrag markiert
|
||||
(let* ((prev (car acc))
|
||||
(prev-alist (cddr prev))
|
||||
(alist (cddr entry))
|
||||
(prev-numbers (cadr prev))
|
||||
(prev-label (assq-ref prev-alist 'stanza)))
|
||||
(or (and (not (string-null? prev-label))
|
||||
(string=? prev-label (assq-ref alist 'stanza)))
|
||||
(and (eq? (assq-ref prev-alist 'type)
|
||||
(assq-ref alist 'type))
|
||||
(pair? prev-numbers)
|
||||
(every (lambda (n) (member n (cadr entry)))
|
||||
prev-numbers)))))
|
||||
(begin
|
||||
(append-fragment-text! (cddr (car acc)) (cddr entry))
|
||||
(loop (cdr remaining) acc))
|
||||
(loop (cdr remaining) (cons entry acc)))))))
|
||||
|
||||
;; Haengt den Text eines Fortsetzungsfragments an eine Strophe an.
|
||||
(define (append-fragment-text! target fragment)
|
||||
(let ((target-cell (assq 'text target))
|
||||
(fragment-text (assq-ref fragment 'text)))
|
||||
(unless (string-null? fragment-text)
|
||||
(set-cdr! target-cell
|
||||
(if (string-null? (cdr target-cell))
|
||||
fragment-text
|
||||
(string-append (cdr target-cell) " " fragment-text))))))
|
||||
|
||||
;; Fuegt die Strophen-Eintraege mehrerer Lyric-Zeilen (Ergebnisse von
|
||||
;; lyric-line->stanzas) zu einer flachen Strophenliste zusammen. Manche
|
||||
;; Lieder verteilen eine Strophe auf mehrere Zeilen unter den Noten
|
||||
;; (Fragmente mit \set stanza = "-" bzw. ohne Marker): Fortsetzungen
|
||||
;; werden innerhalb einer Zeile an die vorhergehende markierte Strophe
|
||||
;; angehaengt; Zeilen ganz ohne markierte Strophen positionsweise an die
|
||||
;; markierten Strophen der letzten Zeile, die welche hatte.
|
||||
(define (merge-lyric-lines lines)
|
||||
(let ((result '()) ; fertige Strophen-alists, rueckwaerts
|
||||
(last-marked '())) ; markierte alists der letzten markierten Zeile
|
||||
(for-each
|
||||
(lambda (line)
|
||||
(let ((line-marked (filter-map (lambda (e) (and (car e) (cddr e))) line)))
|
||||
(if (and (null? line-marked) (pair? last-marked))
|
||||
;; Zeile nur aus Fortsetzungen: k-tes Fragment an k-te
|
||||
;; markierte Strophe der Vorzeile, Ueberzaehlige an deren letzte.
|
||||
(let loop ((entries line) (targets last-marked))
|
||||
(when (pair? entries)
|
||||
(append-fragment-text! (car targets) (cddar entries))
|
||||
(loop (cdr entries)
|
||||
(if (null? (cdr targets)) targets (cdr targets)))))
|
||||
;; Zeile mit markierten Strophen (oder erste Zeile ueberhaupt):
|
||||
;; Fortsetzungen an die vorhergehende Strophe der Zeile.
|
||||
(begin
|
||||
(let loop ((entries line)
|
||||
(prev (if (pair? last-marked) (last last-marked) #f)))
|
||||
(when (pair? entries)
|
||||
(let ((marked? (caar entries))
|
||||
(stanza-alist (cddar entries)))
|
||||
(if (or marked? (not prev))
|
||||
(begin
|
||||
(set! result (cons stanza-alist result))
|
||||
(loop (cdr entries) stanza-alist))
|
||||
(begin
|
||||
(append-fragment-text! prev stanza-alist)
|
||||
(loop (cdr entries) prev))))))
|
||||
(when (pair? line-marked)
|
||||
(set! last-marked line-marked))))))
|
||||
lines)
|
||||
(reverse result)))
|
||||
|
||||
;; Liefert die Lyrics-Zeilen (Music) der ersten Stimme mit Lyrics.
|
||||
;; \addlyrics und \lyricsto erzeugen LyricCombineMusic mit dem Namen der
|
||||
;; zugehoerigen Stimme in associated-context; Zeilen weiterer Stimmen
|
||||
;; (z.B. Zweitstimmen-Text) werden ignoriert.
|
||||
(define (first-voice-lyrics music)
|
||||
(let* ((combines (extract-named-music music 'LyricCombineMusic))
|
||||
(first-ctx (and (pair? combines)
|
||||
(ly:music-property (car combines) 'associated-context))))
|
||||
(map (lambda (c) (ly:music-property c 'element))
|
||||
(filter (lambda (c)
|
||||
(equal? (ly:music-property c 'associated-context) first-ctx))
|
||||
combines))))
|
||||
|
||||
;; Ist thing ein Markup-Aufruf des Kommandos mit diesem Namen?
|
||||
(define (markup-command? thing name)
|
||||
(and (pair? thing)
|
||||
(procedure? (car thing))
|
||||
(eq? (procedure-name (car thing)) name)))
|
||||
|
||||
;; Sammelt die Lyrics-Music-Argumente aller \chordlyrics/\nochordlyrics aus
|
||||
;; den TEXT_PAGES-Markuplisten. \keep-with-tag/\remove-with-tag werden dabei
|
||||
;; wie bei der Markup-Interpretation auf die Music angewendet.
|
||||
(define (text-pages-lyric-musics text-pages)
|
||||
(define (as-list tags) (if (list? tags) tags (list tags)))
|
||||
(define (apply-tag-filters music keep-sets remove-tags)
|
||||
(let ((filtered (fold
|
||||
(lambda (tags m)
|
||||
(music-filter (tags-keep-predicate tags) m))
|
||||
(ly:music-deep-copy music)
|
||||
keep-sets)))
|
||||
(if (pair? remove-tags)
|
||||
(music-filter (tags-remove-predicate remove-tags) filtered)
|
||||
filtered)))
|
||||
(define (collect thing keep-sets remove-tags)
|
||||
(cond
|
||||
((or (markup-command? thing 'chordlyrics-markup)
|
||||
(markup-command? thing 'nochordlyrics-markup))
|
||||
(list (apply-tag-filters (cadr thing) keep-sets remove-tags)))
|
||||
((markup-command? thing 'keep-with-tag-markup)
|
||||
(collect (caddr thing)
|
||||
(cons (as-list (cadr thing)) keep-sets)
|
||||
remove-tags))
|
||||
((markup-command? thing 'remove-with-tag-markup)
|
||||
(collect (caddr thing)
|
||||
keep-sets
|
||||
(append (as-list (cadr thing)) remove-tags)))
|
||||
((pair? thing)
|
||||
(append (collect (car thing) keep-sets remove-tags)
|
||||
(collect (cdr thing) keep-sets remove-tags)))
|
||||
(else '())))
|
||||
(append-map (lambda (page) (collect page '() '())) text-pages))
|
||||
|
||||
;; Fuegt Musik- und Textseiten-Strophen zusammen: gleiche stanza-Kennungen
|
||||
;; nur einmal, wobei die Fassung aus den Textseiten die unter den Noten
|
||||
;; ersetzt (dort steht meist die vollstaendige Fassung).
|
||||
(define (merge-stanza-lists music-stanzas text-stanzas)
|
||||
(let loop ((merged music-stanzas) (remaining text-stanzas))
|
||||
(if (null? remaining)
|
||||
merged
|
||||
(let* ((entry (car remaining))
|
||||
(key (assq-ref entry 'stanza))
|
||||
(found (and (not (string-null? key))
|
||||
(not (string=? key "-"))
|
||||
(find (lambda (e) (equal? (assq-ref e 'stanza) key))
|
||||
merged))))
|
||||
(loop (if found
|
||||
(map (lambda (e) (if (eq? e found) entry e)) merged)
|
||||
(append merged (list entry)))
|
||||
(cdr remaining))))))
|
||||
|
||||
;; Extrahiert alle Strophen/Refrain/Bridge-Texte eines Liedes: die Strophen
|
||||
;; unter den Noten aus music (nur erste Stimme), die Textstrophen aus den
|
||||
;; \chordlyrics der text-pages.
|
||||
(define (extract-lyrics music text-pages)
|
||||
(merge-stanza-lists
|
||||
(merge-lyric-lines (map lyric-line->stanzas (first-voice-lyrics music)))
|
||||
(append-map (lambda (m) (merge-lyric-lines (list (lyric-line->stanzas m))))
|
||||
(text-pages-lyric-musics text-pages))))
|
||||
|
||||
;; --- Hauptfunktion -----------------------------------------------------
|
||||
|
||||
;; Liefert das erste Music-Objekt mit gegebenem Namen (oder #f).
|
||||
(define (first-named-music music music-name)
|
||||
(let ((matches (extract-named-music music music-name)))
|
||||
(and (pair? matches) (car matches))))
|
||||
|
||||
;; Nimmt ly:music entgegen und liefert eine alist mit String-Werten.
|
||||
(define (music->data-alist music)
|
||||
(let* ((time-m (first-named-music
|
||||
music '(TimeSignatureMusic ReferenceTimeSignatureMusic)))
|
||||
(key-m (first-named-music music 'KeyChangeEvent))
|
||||
(tempo-m (first-named-music music 'TempoChangeEvent))
|
||||
(time-s (and time-m (time-music->string time-m)))
|
||||
(key-s (and key-m (key-music->string key-m)))
|
||||
(tempo-s (and tempo-m (tempo-music->string tempo-m))))
|
||||
(append
|
||||
(if time-s (list (cons 'time time-s)) '())
|
||||
(if key-s (list (cons 'key key-s)) '())
|
||||
(if tempo-s (list (cons 'tempo tempo-s)) '()))))
|
||||
|
||||
(define (extract-song-data header music text-pages)
|
||||
(let ((header-alist (bookpart->header-alist header))
|
||||
(music-alist (music->data-alist music))
|
||||
(lyrics-list (extract-lyrics music text-pages)))
|
||||
(append header-alist
|
||||
(list (cons 'musical music-alist)
|
||||
(cons 'lyrics lyrics-list))))))
|
||||
@@ -1,154 +1,259 @@
|
||||
(use-modules (ice-9 rdelim) (ice-9 regex) (ice-9 pretty-print) (srfi srfi-1))
|
||||
(use-modules (ice-9 rdelim) (ice-9 regex) (ice-9 receive) (srfi srfi-1))
|
||||
|
||||
;; YAML-Parser: liest eine Teilmenge von YAML (Block-Syntax, keine
|
||||
;; Flow-Collections, keine Block-Skalare) in verschachtelte
|
||||
;; alist/list-Strukturen. Gegenstück zu yaml_writer.scm.
|
||||
;;
|
||||
;; Ergebnisformat:
|
||||
;; - Mapping -> alist mit String-Keys, Reihenfolge wie in der Datei
|
||||
;; - Liste -> Liste (auch als "- key: value"-Inline-Mappings)
|
||||
;; - Skalare -> String, Zahl, #t/#f, '() (null / {} / [])
|
||||
;;
|
||||
;; Skalar-Interpretation:
|
||||
;; - unquoted und 'single-quoted' Werte werden interpretiert
|
||||
;; (Zahl, true/false/null). Das Interpretieren von single-quoted
|
||||
;; Werten ist Kompatibilitätsverhalten zum alten Parser:
|
||||
;; authors.yml notiert Zahlen als '1898'.
|
||||
;; - "double-quoted" Werte bleiben immer Strings; \\, \" und \n
|
||||
;; werden entescaped (so schreibt sie der yaml_writer).
|
||||
;; - Kommentare (#) werden nur außerhalb von Quotes entfernt und nur,
|
||||
;; wenn ihnen ein Leerzeichen oder der Zeilenanfang vorausgeht.
|
||||
|
||||
;; Hauptparsingfunktion
|
||||
(define (yml-file->scm filename)
|
||||
|
||||
;; Utility: Zeile einlesen
|
||||
(define (read-lines filename)
|
||||
;; --- Zeilen einlesen ------------------------------------------------
|
||||
|
||||
;; Anzahl führender Leerzeichen
|
||||
(define (line-indent line)
|
||||
(let loop ((i 0))
|
||||
(if (and (< i (string-length line))
|
||||
(char=? (string-ref line i) #\space))
|
||||
(loop (+ i 1))
|
||||
i)))
|
||||
|
||||
;; Liefert Items (indent . inhalt); Leerzeilen, reine Kommentarzeilen
|
||||
;; und Dokumentmarker (--- / ...) werden übersprungen.
|
||||
(define (read-items filename)
|
||||
(call-with-input-file filename
|
||||
(lambda (port)
|
||||
(let loop ((lines '()))
|
||||
(let loop ((items '()))
|
||||
(let ((line (read-line port)))
|
||||
(if (eof-object? line)
|
||||
(reverse lines)
|
||||
(let ((clean (string-trim line)))
|
||||
(if (or (string=? clean "---") (string-null? clean))
|
||||
(loop lines) ;; Ignoriere "---" oder leere Zeile
|
||||
(loop (cons line lines))))))))))
|
||||
(reverse items)
|
||||
(let* ((line (if (string-suffix? "\r" line)
|
||||
(string-drop-right line 1)
|
||||
line))
|
||||
(content (string-trim-both line)))
|
||||
(if (or (string-null? content)
|
||||
(string-prefix? "#" content)
|
||||
(string=? content "---")
|
||||
(string=? content "..."))
|
||||
(loop items)
|
||||
(loop (cons (cons (line-indent line) content)
|
||||
items))))))))))
|
||||
|
||||
;; Einrückung bestimmen (Anzahl Leerzeichen am Anfang)
|
||||
(define (line-indent line)
|
||||
(let ((match (string-match "^ *" line)))
|
||||
(if match
|
||||
(match:end match) ; Anzahl der Leerzeichen = Position nach Leerzeichen
|
||||
0))) ; Falls kein Match → 0
|
||||
(define (item-indent item) (car item))
|
||||
(define (item-content item) (cdr item))
|
||||
|
||||
;; Kommentar entfernen
|
||||
(define (strip-comment line)
|
||||
(let ((m (string-match "#.*" line)))
|
||||
(if m
|
||||
(string-trim-right (string-take line (match:start m)))
|
||||
line)))
|
||||
;; --- Skalare ----------------------------------------------------------
|
||||
|
||||
;; Hilfsfunktion: Whitespace entfernen
|
||||
(define (clean-line line)
|
||||
(string-trim (strip-comment line)))
|
||||
;; Position des schließenden Double-Quotes ab start (oder #f);
|
||||
;; Backslash escaped das Folgezeichen.
|
||||
(define (closing-double-quote s start)
|
||||
(let loop ((i start))
|
||||
(cond ((>= i (string-length s)) #f)
|
||||
((char=? (string-ref s i) #\\) (loop (+ i 2)))
|
||||
((char=? (string-ref s i) #\") i)
|
||||
(else (loop (+ i 1))))))
|
||||
|
||||
;; Ist Zeile leer (nach Entfernen von Kommentar & Whitespace)?
|
||||
(define (blank-or-comment? line)
|
||||
(string-null? (clean-line line)))
|
||||
;; Position des schließenden Single-Quotes ab start (oder #f);
|
||||
;; '' ist ein escaptes Quote.
|
||||
(define (closing-single-quote s start)
|
||||
(let loop ((i start))
|
||||
(cond ((>= i (string-length s)) #f)
|
||||
((char=? (string-ref s i) #\')
|
||||
(if (and (< (+ i 1) (string-length s))
|
||||
(char=? (string-ref s (+ i 1)) #\'))
|
||||
(loop (+ i 2))
|
||||
i))
|
||||
(else (loop (+ i 1))))))
|
||||
|
||||
;; Skalare Werte interpretieren
|
||||
(define (parse-scalar str)
|
||||
(define (strip-quotes s)
|
||||
;; \\ -> \, \" -> ", \n -> Zeilenumbruch
|
||||
(define (unescape-double s)
|
||||
(let loop ((chars (string->list s)) (acc '()))
|
||||
(cond ((null? chars) (list->string (reverse acc)))
|
||||
((and (char=? (car chars) #\\) (pair? (cdr chars)))
|
||||
(loop (cddr chars)
|
||||
(cons (if (char=? (cadr chars) #\n)
|
||||
#\newline
|
||||
(cadr chars))
|
||||
acc)))
|
||||
(else (loop (cdr chars) (cons (car chars) acc))))))
|
||||
|
||||
;; '' -> '
|
||||
(define (unescape-single s)
|
||||
(regexp-substitute/global #f "''" s 'pre "'" 'post))
|
||||
|
||||
;; Kommentar in einem unquoted Wert entfernen:
|
||||
;; # zählt nur am Anfang oder nach Leerzeichen
|
||||
(define (strip-plain-comment s)
|
||||
(let loop ((i 0))
|
||||
(cond ((>= i (string-length s)) s)
|
||||
((and (char=? (string-ref s i) #\#)
|
||||
(or (zero? i)
|
||||
(char-whitespace? (string-ref s (- i 1)))))
|
||||
(string-take s i))
|
||||
(else (loop (+ i 1))))))
|
||||
|
||||
;; Unquoted/single-quoted Werte interpretieren
|
||||
(define (interpret-plain s)
|
||||
(cond
|
||||
((and (string-prefix? "\"" s) (string-suffix? "\"" s))
|
||||
(string-drop-right (string-drop s 1) 1))
|
||||
((and (string-prefix? "'" s) (string-suffix? "'" s))
|
||||
(string-drop-right (string-drop s 1) 1))
|
||||
(else s)))
|
||||
(let ((s (strip-quotes (string-trim str))))
|
||||
(cond
|
||||
((string=? s "{}") '()) ;; leere Map
|
||||
((string=? s "[]") '()) ;; leere Liste
|
||||
((string-match "^[0-9]+$" s) (string->number s))
|
||||
((member s '("{}" "[]" "null")) '())
|
||||
((string=? s "true") #t)
|
||||
((string=? s "false") #f)
|
||||
((string=? s "null") '())
|
||||
(else s))))
|
||||
((string-match "^-?[0-9]+(\\.[0-9]+)?$" s) (string->number s))
|
||||
(else s)))
|
||||
|
||||
|
||||
;; Hilfsfunktion: Zeilen mit gleicher oder höherer Einrückung sammeln
|
||||
(define (take-indented lines min-indent)
|
||||
(let loop ((ls lines) (acc '()))
|
||||
(if (null? ls)
|
||||
(reverse acc)
|
||||
(let ((line (car ls)))
|
||||
(if (or (blank-or-comment? line)
|
||||
(>= (line-indent line) min-indent))
|
||||
(loop (cdr ls) (cons line acc))
|
||||
(reverse acc))))))
|
||||
|
||||
;; Hilfsfunktion: N Zeilen überspringen
|
||||
(define (drop lst n)
|
||||
(let loop ((l lst) (i n))
|
||||
(if (or (zero? i) (null? l))
|
||||
l
|
||||
(loop (cdr l) (- i 1)))))
|
||||
|
||||
;; Listenparsing: Liest Zeilen mit `-` als Listeneinträge
|
||||
(define (parse-list lines current-indent)
|
||||
(let loop ((ls lines) (result '()))
|
||||
(if (null? ls)
|
||||
(reverse result)
|
||||
(let* ((line (clean-line (car ls))))
|
||||
(if (string-match "^-" line)
|
||||
(let* ((indent (line-indent (car ls)))
|
||||
(item-str (string-trim (string-drop line 1)))
|
||||
(next-lines (cdr ls)))
|
||||
(if (or (null? next-lines)
|
||||
(> (line-indent (car next-lines)) indent))
|
||||
;; Verschachtelter Inhalt
|
||||
(let* ((sub (take-indented next-lines (+ indent 2)))
|
||||
(parsed (if (null? sub)
|
||||
(parse-scalar item-str)
|
||||
(parse-lines sub (+ indent 2))))
|
||||
(remaining (drop next-lines (length sub))))
|
||||
(loop remaining (cons parsed result)))
|
||||
;; Einfacher Skalar
|
||||
(loop next-lines (cons (parse-scalar item-str) result))))
|
||||
;; Nicht mehr Teil der Liste
|
||||
(reverse result))))))
|
||||
|
||||
;; Hauptparser für Key-Value oder Listen
|
||||
(define (parse-lines lines current-indent)
|
||||
(let loop ((ls lines) (result '()))
|
||||
(if (null? ls)
|
||||
(reverse result)
|
||||
(let* ((raw-line (car ls))
|
||||
(line (clean-line raw-line)))
|
||||
;; Skalar parsen; Rest hinter einem schließenden Quote wird ignoriert
|
||||
;; (darf nur ein Kommentar sein)
|
||||
(define (parse-scalar str)
|
||||
(let ((s (string-trim-both str)))
|
||||
(cond
|
||||
;; Kommentar oder leere Zeile
|
||||
((blank-or-comment? raw-line)
|
||||
(loop (cdr ls) result))
|
||||
|
||||
;; Liste
|
||||
((string-match "^- " line)
|
||||
(let ((list-lines (take-indented ls current-indent)))
|
||||
(let ((parsed-list (parse-list list-lines current-indent)))
|
||||
(loop (drop ls (length list-lines))
|
||||
(cons parsed-list result)))))
|
||||
|
||||
;; Key: Value
|
||||
((string-match "^[^:]+:" line)
|
||||
(let* ((kv (string-split line #\:))
|
||||
(key (string-trim (car kv)))
|
||||
(value-str (string-trim (string-join (cdr kv) ":")))
|
||||
(next-lines (cdr ls)))
|
||||
(if (string-null? value-str)
|
||||
;; Wert auf nachfolgender Einrückungsebene
|
||||
(let* ((sub (take-indented next-lines (+ current-indent 2)))
|
||||
(parsed (parse-lines sub (+ current-indent 2)))
|
||||
(remaining (drop next-lines (length sub))))
|
||||
(loop remaining
|
||||
(cons (cons key parsed) result)))
|
||||
;; Einfacher Key:Value
|
||||
(loop next-lines
|
||||
(cons (cons key (parse-scalar value-str)) result)))))
|
||||
|
||||
;; Fehlerhafte Zeile
|
||||
((string-null? s) "")
|
||||
((char=? (string-ref s 0) #\")
|
||||
(let ((end (closing-double-quote s 1)))
|
||||
(if end
|
||||
(unescape-double (substring s 1 end))
|
||||
(string-trim-right (strip-plain-comment s)))))
|
||||
((char=? (string-ref s 0) #\')
|
||||
(let ((end (closing-single-quote s 1)))
|
||||
(if end
|
||||
(interpret-plain (unescape-single (substring s 1 end)))
|
||||
(string-trim-right (strip-plain-comment s)))))
|
||||
(else
|
||||
;; Vermeide Fehlermeldung für Leerzeilen oder leere Objekte
|
||||
(if (or (string-null? (string-trim line))
|
||||
(member line '("{}" "[]")))
|
||||
(loop (cdr ls) result)
|
||||
(interpret-plain (string-trim-right (strip-plain-comment s)))))))
|
||||
|
||||
;; --- Struktur ----------------------------------------------------------
|
||||
|
||||
;; Erste Key-Trennstelle: ":" am Zeilenende oder gefolgt von Leerzeichen.
|
||||
;; Beginnt die Zeile mit einem gequoteten Key (oder Skalar), zaehlt ein
|
||||
;; ":" innerhalb der Quotes nicht als Trennstelle.
|
||||
(define (key-split-index s)
|
||||
(let ((start (if (string-null? s)
|
||||
0
|
||||
(case (string-ref s 0)
|
||||
((#\") (let ((end (closing-double-quote s 1)))
|
||||
(if end (+ end 1) 0)))
|
||||
((#\') (let ((end (closing-single-quote s 1)))
|
||||
(if end (+ end 1) 0)))
|
||||
(else 0)))))
|
||||
(let loop ((i start))
|
||||
(cond ((>= i (string-length s)) #f)
|
||||
((and (char=? (string-ref s i) #\:)
|
||||
(or (= i (- (string-length s) 1))
|
||||
(char=? (string-ref s (+ i 1)) #\space)))
|
||||
i)
|
||||
(else (loop (+ i 1)))))))
|
||||
|
||||
;; Key interpretieren: gequotete Keys werden entquotet (Strings bleiben
|
||||
;; Strings), unquoted Keys bleiben unveraendert
|
||||
(define (parse-key s)
|
||||
(let ((k (string-trim-both s)))
|
||||
(cond
|
||||
((string-null? k) k)
|
||||
((char=? (string-ref k 0) #\")
|
||||
(let ((end (closing-double-quote k 1)))
|
||||
(if end (unescape-double (substring k 1 end)) k)))
|
||||
((char=? (string-ref k 0) #\')
|
||||
(let ((end (closing-single-quote k 1)))
|
||||
(if end (unescape-single (substring k 1 end)) k)))
|
||||
(else k))))
|
||||
|
||||
(define (dash-line? content)
|
||||
(or (string=? content "-") (string-prefix? "- " content)))
|
||||
|
||||
;; Wert-String hinter "key:" bzw. "-": reiner Kommentar zählt als leer
|
||||
(define (effective-value str)
|
||||
(let ((s (string-trim-both str)))
|
||||
(if (string-prefix? "#" s) "" s)))
|
||||
|
||||
;; Einen Block von Items parsen; das erste Item bestimmt die Blockart
|
||||
(define (parse-block items)
|
||||
(cond
|
||||
((null? items) '())
|
||||
((dash-line? (item-content (car items))) (parse-list items))
|
||||
;; einzelne Zeile ohne Key: Skalar (z.B. eine Datei, die nur {} enthält)
|
||||
((and (null? (cdr items))
|
||||
(not (key-split-index (item-content (car items)))))
|
||||
(parse-scalar (item-content (car items))))
|
||||
(else (parse-map items))))
|
||||
|
||||
;; Mapping: alle Items auf map-indent sind Keys, tiefer eingerückte
|
||||
;; Items gehören zum jeweils vorangehenden Key
|
||||
(define (parse-map items)
|
||||
(let ((map-indent (item-indent (car items))))
|
||||
(let loop ((items items) (result '()))
|
||||
(if (null? items)
|
||||
(reverse result)
|
||||
(let* ((content (item-content (car items)))
|
||||
(split (key-split-index content)))
|
||||
(if (not split)
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"Syntaxfehler: Ungültige Zeile: ~a\n" raw-line)
|
||||
(loop (cdr ls) result))))
|
||||
)))))
|
||||
"YAML-Syntaxfehler: Ungültige Zeile: ~a\n" content)
|
||||
(loop (cdr items) result))
|
||||
(let ((key (parse-key (string-take content split)))
|
||||
(value-str (effective-value
|
||||
(string-drop content (+ split 1)))))
|
||||
(if (string-null? value-str)
|
||||
;; Wert steht im eingerückten Block darunter
|
||||
(receive (children rest)
|
||||
(span (lambda (it) (> (item-indent it) map-indent))
|
||||
(cdr items))
|
||||
(loop rest
|
||||
(cons (cons key (parse-block children))
|
||||
result)))
|
||||
(loop (cdr items)
|
||||
(cons (cons key (parse-scalar value-str))
|
||||
result))))))))))
|
||||
|
||||
(let ((lines (read-lines filename)))
|
||||
(parse-lines lines 0)))
|
||||
;; Liste: "- wert", "- key: value" (Inline-Mapping) oder "-" mit
|
||||
;; eingerücktem Block darunter
|
||||
(define (parse-list items)
|
||||
(let ((list-indent (item-indent (car items))))
|
||||
(let loop ((items items) (result '()))
|
||||
(if (null? items)
|
||||
(reverse result)
|
||||
(let ((content (item-content (car items))))
|
||||
(if (not (dash-line? content))
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"YAML-Syntaxfehler: Ungültiges Listenelement: ~a\n"
|
||||
content)
|
||||
(loop (cdr items) result))
|
||||
(receive (children rest)
|
||||
(span (lambda (it) (> (item-indent it) list-indent))
|
||||
(cdr items))
|
||||
(let* ((after-dash (string-drop content 1))
|
||||
(inline (effective-value after-dash)))
|
||||
(cond
|
||||
((and (string-null? inline) (null? children))
|
||||
(loop rest (cons '() result)))
|
||||
((string-null? inline)
|
||||
(loop rest (cons (parse-block children) result)))
|
||||
(else
|
||||
;; Inline-Inhalt: als synthetisches Item mit der
|
||||
;; Spalte des Inhalts vor die Kinder stellen, so
|
||||
;; funktioniert auch "- key: value" mit weiteren
|
||||
;; Keys auf den Folgezeilen
|
||||
(let* ((offset (- (string-length content)
|
||||
(string-length
|
||||
(string-trim after-dash))))
|
||||
(synth (cons (+ list-indent offset) inline)))
|
||||
(loop rest
|
||||
(cons (parse-block (cons synth children))
|
||||
result)))))))))))))
|
||||
|
||||
(parse-block (read-items filename)))
|
||||
|
||||
(define (parse-yml-file filename) (resolve-inherits (yml-file->scm filename)))
|
||||
|
||||
@@ -0,0 +1,162 @@
|
||||
(use-modules (ice-9 regex) (srfi srfi-1))
|
||||
|
||||
;; YAML-Writer: Gegenstück zu yaml_parser.scm.
|
||||
;; Schreibt verschachtelte alist/list-Strukturen als YAML, so dass
|
||||
;; yml-file->scm sie wieder einlesen kann.
|
||||
;;
|
||||
;; Datenmodell (wie vom Parser erzeugt):
|
||||
;; - Mapping: Liste von Paaren (key . value), key als String oder Symbol
|
||||
;; - Liste: Liste von beliebigen Werten
|
||||
;; - Skalare: String, Zahl, #t/#f, '() (leer/null, wird als [] geschrieben)
|
||||
;;
|
||||
;; Andere Werte werden vorab automatisch umgewandelt: Markups zu Strings,
|
||||
;; alles Unbekannte über ~a formatiert (siehe yml-sanitize).
|
||||
|
||||
;; Steuert, ob layout_bottom.ily die Header-Daten des Liedes als
|
||||
;; YAML-Datei exportiert; aktivierbar per (set! yaml-export-enabled #t)
|
||||
;; oder durch Definieren der Variable vor dem Laden der Includes.
|
||||
(define yaml-export-enabled
|
||||
(if (defined? 'yaml-export-enabled) yaml-export-enabled #f))
|
||||
|
||||
;; Beliebige Werte in YAML-taugliche Daten umwandeln.
|
||||
;; (Benötigt die LilyPond-Umgebung für markup? und markup->string.)
|
||||
(define (yml-sanitize v)
|
||||
(cond
|
||||
((or (string? v) (number? v) (boolean? v) (symbol? v) (null? v)) v)
|
||||
((markup? v) (markup->string v))
|
||||
((list? v) (map yml-sanitize v))
|
||||
((pair? v) (cons (yml-sanitize (car v)) (yml-sanitize (cdr v))))
|
||||
(else (format #f "~a" v))))
|
||||
|
||||
(define (scm->yml-string data)
|
||||
|
||||
;; Ist data ein Mapping (alist)? Nicht-leere Liste, deren Elemente
|
||||
;; alle Paare mit String- oder Symbol-Key sind.
|
||||
;; Achtung: eine Liste von Listen, deren erste Elemente Strings sind,
|
||||
;; ist davon nicht unterscheidbar und wird als Mapping interpretiert.
|
||||
(define (mapping? data)
|
||||
(and (pair? data)
|
||||
(list? data)
|
||||
(every (lambda (entry)
|
||||
(and (pair? entry)
|
||||
(or (string? (car entry))
|
||||
(symbol? (car entry)))))
|
||||
data)))
|
||||
|
||||
(define (scalar? v)
|
||||
(or (string? v) (symbol? v) (number? v) (boolean? v) (null? v)))
|
||||
|
||||
(define (key->string k)
|
||||
(if (symbol? k) (symbol->string k) k))
|
||||
|
||||
;; Muss der String gequotet werden, damit er beim Einlesen wieder
|
||||
;; als derselbe String erkannt wird?
|
||||
(define (needs-quotes? s)
|
||||
(or (string-null? s)
|
||||
(member s '("true" "false" "null" "{}" "[]"))
|
||||
(string->number s) ;; zahlartig ("1981", "1.", "-5") würde zur Zahl
|
||||
(string-index s #\#) ;; würde als Kommentar abgeschnitten
|
||||
(string-index s #\:) ;; würde als Key: Value gelesen
|
||||
(string-index s #\newline) ;; mehrzeilig
|
||||
(string-index s #\")
|
||||
(string-prefix? "-" s) ;; würde als Listenelement gelesen
|
||||
(string-prefix? "'" s)
|
||||
(not (string=? s (string-trim-both s))))) ;; führende/folgende Leerzeichen
|
||||
|
||||
;; Doppelt gequoteter YAML-String; Backslash, Anführungszeichen und
|
||||
;; Zeilenumbrüche werden escaped, damit alles auf einer Zeile bleibt.
|
||||
(define (quote-string s)
|
||||
(string-append
|
||||
"\""
|
||||
(string-concatenate
|
||||
(map (lambda (c)
|
||||
(cond
|
||||
((char=? c #\\) "\\\\")
|
||||
((char=? c #\") "\\\"")
|
||||
((char=? c #\newline) "\\n")
|
||||
(else (string c))))
|
||||
(string->list s)))
|
||||
"\""))
|
||||
|
||||
(define (scalar->string v)
|
||||
(cond
|
||||
((eq? v #t) "true")
|
||||
((eq? v #f) "false")
|
||||
((null? v) "[]")
|
||||
((number? v) (number->string v))
|
||||
((symbol? v) (scalar->string (symbol->string v)))
|
||||
((string? v) (if (needs-quotes? v) (quote-string v) v))
|
||||
(else (error "scm->yml-string: nicht unterstützter Wert" v))))
|
||||
|
||||
(define (indent-string n) (make-string n #\space))
|
||||
|
||||
;; Key ggf. quoten (leere oder zahlartige Keys, Sonderzeichen)
|
||||
(define (key->yml-string k)
|
||||
(let ((s (key->string k)))
|
||||
(if (needs-quotes? s) (quote-string s) s)))
|
||||
|
||||
;; Doppelte Keys sind in YAML nicht erlaubt: Werte gleicher Keys werden
|
||||
;; zu einer Liste zusammengefasst, z.B. authors mit (voice 2) (voice 3)
|
||||
;; -> voice: [2, 3].
|
||||
(define (merge-duplicate-keys data)
|
||||
(define (value->list v)
|
||||
(if (and (list? v) (not (mapping? v))) v (list v)))
|
||||
(let loop ((entries data) (result '()))
|
||||
(if (null? entries)
|
||||
(reverse result)
|
||||
(let* ((entry (car entries))
|
||||
(existing (find (lambda (e) (equal? (car e) (car entry)))
|
||||
result)))
|
||||
(if existing
|
||||
(begin
|
||||
(set-cdr! existing (append (value->list (cdr existing))
|
||||
(value->list (cdr entry))))
|
||||
(loop (cdr entries) result))
|
||||
(loop (cdr entries)
|
||||
(cons (cons (car entry) (cdr entry)) result)))))))
|
||||
|
||||
;; Mapping schreiben: "key: skalar" oder "key:" mit eingerücktem Inhalt
|
||||
(define (write-mapping data indent port)
|
||||
(for-each
|
||||
(lambda (entry)
|
||||
(let ((key (key->yml-string (car entry)))
|
||||
(value (cdr entry)))
|
||||
(if (scalar? value)
|
||||
(format port "~a~a: ~a\n"
|
||||
(indent-string indent) key (scalar->string value))
|
||||
(begin
|
||||
(format port "~a~a:\n" (indent-string indent) key)
|
||||
(write-node value (+ indent 2) port)))))
|
||||
(merge-duplicate-keys data)))
|
||||
|
||||
;; Liste schreiben: "- skalar" oder "-" mit eingerücktem Inhalt
|
||||
;; (Verschachtelter Inhalt darf NICHT auf der "-"-Zeile beginnen,
|
||||
;; weil parse-list den Inhalt der "-"-Zeile verwirft, sobald
|
||||
;; eingerückte Folgezeilen existieren.)
|
||||
(define (write-list data indent port)
|
||||
(for-each
|
||||
(lambda (item)
|
||||
(if (scalar? item)
|
||||
(format port "~a- ~a\n"
|
||||
(indent-string indent) (scalar->string item))
|
||||
(begin
|
||||
(format port "~a-\n" (indent-string indent))
|
||||
(write-node item (+ indent 2) port))))
|
||||
data))
|
||||
|
||||
(define (write-node data indent port)
|
||||
(cond
|
||||
((mapping? data) (write-mapping data indent port))
|
||||
((and (list? data) (not (null? data))) (write-list data indent port))
|
||||
(else (format port "~a~a\n" (indent-string indent) (scalar->string data)))))
|
||||
|
||||
(call-with-output-string
|
||||
(lambda (port) (write-node (yml-sanitize data) 0 port))))
|
||||
|
||||
;; Daten als YAML-Datei schreiben
|
||||
(define (scm->yml-file filename data)
|
||||
(call-with-output-file filename
|
||||
(lambda (port)
|
||||
(display "---\n" port)
|
||||
(display (scm->yml-string data) port))))
|
||||
|
||||
@@ -65,6 +65,26 @@ additionalPageNumbers =
|
||||
display-pages-list
|
||||
)
|
||||
|
||||
% Fuer Zusatzseiten: Label der ersten Seite des zusammenhaengenden
|
||||
% Zusatzseiten-Blocks, zu dem label gehoert (bestimmt den Buchstaben-Suffix a, b, ...).
|
||||
#(define (earliest-additional-label label)
|
||||
(let find-earliest-additional-label
|
||||
((rest-additional-page-switch-label-list (member (cons label #t) additional-page-switch-label-list)))
|
||||
(if (cdadr rest-additional-page-switch-label-list)
|
||||
(find-earliest-additional-label (cdr rest-additional-page-switch-label-list))
|
||||
(caar rest-additional-page-switch-label-list))))
|
||||
|
||||
% Sichtbare Seitenzahl der Seite mit diesem Label: normalerweise eine Zahl,
|
||||
% auf Zusatzseiten ein String mit Buchstaben-Suffix (z.B. "12a"); gleiche
|
||||
% Logik wie custom-page-number unten.
|
||||
#(define (visible-page-value layout label)
|
||||
(let ((display-page (assq-ref (build-display-pages-list layout) label)))
|
||||
(if (assq-ref additional-page-switch-label-list label)
|
||||
(ly:format "~a~a" display-page
|
||||
(string (integer->char (+ 97 (- (real-page-number layout label)
|
||||
(real-page-number layout (earliest-additional-label label)))))))
|
||||
display-page)))
|
||||
|
||||
% TODO:
|
||||
% Eigentlich können wir das direkt in oddFooderMarkup und evenFooterMarkup aufrufen
|
||||
% vermutlich sogar ohne den delay kram. Wir sollten außerdem einfach nur die property
|
||||
@@ -97,12 +117,7 @@ width may require additional tweaking.)"
|
||||
(if (assq-ref additional-page-switch-label-list label)
|
||||
(make-concat-markup (list (number-format number-type display-page)
|
||||
(make-char-markup (+ 97 (- real-current-page (real-page-number layout
|
||||
(let find-earliest-additional-label
|
||||
((rest-additional-page-switch-label-list (member (cons label #t) additional-page-switch-label-list)))
|
||||
(if (cdadr rest-additional-page-switch-label-list)
|
||||
(find-earliest-additional-label (cdr rest-additional-page-switch-label-list))
|
||||
(caar rest-additional-page-switch-label-list)))
|
||||
))))))
|
||||
(earliest-additional-label label)))))))
|
||||
(number-format number-type (+ display-page (- real-current-page (real-page-number layout label))))
|
||||
))
|
||||
(page-stencil (interpret-markup layout props page-markup))
|
||||
@@ -118,6 +133,31 @@ width may require additional tweaking.)"
|
||||
(make-filled-box-stencil x-ext y-ext))))
|
||||
|
||||
|
||||
%% Schreibt die Daten aller Lieder des Buchs (extract-song-data, siehe
|
||||
%% data_extractor.ily) als YAML-Datei: oberster Key contents, darunter eine
|
||||
%% Liste mit den Lied-Daten, jeweils angereichert um den Key page mit der
|
||||
%% sichtbaren Seitenzahl des Liedanfangs. Einbinden wie \write-toc-csv in
|
||||
%% einem Markup des Buchs; wie dort passiert das Schreiben ueber ein
|
||||
%% delayed stencil, weil die Label->Seiten-Tabelle erst beim Ausgeben des
|
||||
%% Buchs feststeht.
|
||||
#(define-markup-command (write-book-yaml layout props filename) (string?)
|
||||
(ly:make-stencil
|
||||
`(delay-stencil-evaluation
|
||||
,(delay
|
||||
(begin
|
||||
(scm->yml-file filename
|
||||
(list (cons 'contents
|
||||
(map (lambda (song)
|
||||
(let ((songvars (cdr song)))
|
||||
(cons (cons 'page (visible-page-value layout (assq-ref songvars 'label)))
|
||||
(extract-song-data (assq-ref songvars 'header)
|
||||
(assq-ref songvars 'music)
|
||||
(assq-ref songvars 'text-pages)))))
|
||||
(reverse (alist-delete 'markupPage
|
||||
(alist-delete 'imagePage
|
||||
(alist-delete 'emptyPage song-list))))))))
|
||||
empty-stencil)))))
|
||||
|
||||
includeSong =
|
||||
#(define-void-function (filename) (string?)
|
||||
#{
|
||||
|
||||
@@ -72,6 +72,13 @@ TEXT = \markuplist {
|
||||
(if paper (set! $defaultpaper paper))
|
||||
)
|
||||
|
||||
;; Meta-Daten des Liedes als YAML neben die Ausgabedatei schreiben
|
||||
;; (<ly:parser-output-name>.yml, landet wie das PDF relativ zum Arbeitsverzeichnis)
|
||||
(when (and (defined? 'yaml-export-enabled) yaml-export-enabled)
|
||||
(scm->yml-file
|
||||
(string-append (ly:parser-output-name) ".yml")
|
||||
(extract-song-data HEADER MUSIC TEXT_PAGES)))
|
||||
|
||||
;; ChordPro export: Store filename and extract metadata from basicSongInfo FIRST
|
||||
(when (and (defined? 'chordpro-export-enabled) chordpro-export-enabled)
|
||||
;; Use ly:parser-output-name which returns the output basename
|
||||
|
||||
Reference in New Issue
Block a user