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