lilypond-common-includes/private_includes/base/scm/yaml_parser.scm

(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.

(define (yml-file->scm 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 ((items '()))
          (let ((line (read-line port)))
            (if (eof-object? line)
                (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))))))))))

  (define (item-indent item) (car item))
  (define (item-content item) (cdr item))

  ;; --- Skalare ----------------------------------------------------------

  ;; 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))))))

  ;; 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))))))

  ;; \\ -> \, \" -> ", \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
     ((member s '("{}" "[]" "null")) '())
     ((string=? s "true") #t)
     ((string=? s "false") #f)
     ((string-match "^-?[0-9]+(\\.[0-9]+)?$" s) (string->number s))
     (else s)))

  ;; 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
       ((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
        (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)
                            "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))))))))))

  ;; 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)))