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

(use-modules (ice-9 rdelim) (ice-9 regex) (ice-9 pretty-print) (srfi srfi-1))

;; Hauptparsingfunktion
(define (yml-file->scm filename)

  ;; Utility: Zeile einlesen
  (define (read-lines filename)
    (call-with-input-file filename
      (lambda (port)
        (let loop ((lines '()))
          (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))))))))))

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

  ;; Kommentar entfernen
  (define (strip-comment line)
    (let ((m (string-match "#.*" line)))
      (if m
          (string-trim-right (string-take line (match:start m)))
          line)))

  ;; Hilfsfunktion: Whitespace entfernen
  (define (clean-line line)
    (string-trim (strip-comment line)))

  ;; Ist Zeile leer (nach Entfernen von Kommentar & Whitespace)?
  (define (blank-or-comment? line)
    (string-null? (clean-line line)))

  ;; Skalare Werte interpretieren
  (define (parse-scalar str)
    (define (strip-quotes 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))
       ((string=? s "true") #t)
       ((string=? s "false") #f)
       ((string=? s "null") '())
       (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)))
            (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
             (else
               ;; Vermeide Fehlermeldung für Leerzeilen oder leere Objekte
               (if (or (string-null? (string-trim line))
                       (member line '("{}" "[]")))
                   (loop (cdr ls) result)
                   (begin
                     (format (current-error-port)
                             "Syntaxfehler: Ungültige Zeile: ~a\n" raw-line)
                     (loop (cdr ls) result))))
             )))))

  (let ((lines (read-lines filename)))
    (parse-lines lines 0)))

(define (parse-yml-file filename) (resolve-inherits (yml-file->scm filename)))