From fbef0d38611f8e990235ad7b8bbdb8f901533443 Mon Sep 17 00:00:00 2001 From: Hilton Chain Date: Sun, 25 May 2025 01:47:29 +0800 Subject: [PATCH] utils: Update serializers from RDE. * modules/rosenthal/utils/serializers/ini.scm: New file. * modules/rosenthal/utils/serializers/utils.scm: New file. * modules/rosenthal/utils/serializers/yaml.scm: New file. * modules/rosenthal/utils/home-services-utils.scm: Delete file. * modules/rosenthal/services/child-error.scm (home-wakapi-shepherd-service): Use the new serializer. * modules/rosenthal/services/web.scm (misskey-oci-containers): Likewise. --- modules/rosenthal/services/child-error.scm | 4 +- modules/rosenthal/services/web.scm | 4 +- .../rosenthal/utils/home-services-utils.scm | 441 ------------------ modules/rosenthal/utils/serializers/ini.scm | 154 ++++++ modules/rosenthal/utils/serializers/utils.scm | 36 ++ modules/rosenthal/utils/serializers/yaml.scm | 153 ++++++ 6 files changed, 347 insertions(+), 445 deletions(-) delete mode 100644 modules/rosenthal/utils/home-services-utils.scm create mode 100644 modules/rosenthal/utils/serializers/ini.scm create mode 100644 modules/rosenthal/utils/serializers/utils.scm create mode 100644 modules/rosenthal/utils/serializers/yaml.scm diff --git a/modules/rosenthal/services/child-error.scm b/modules/rosenthal/services/child-error.scm index e006d66..520aaa6 100644 --- a/modules/rosenthal/services/child-error.scm +++ b/modules/rosenthal/services/child-error.scm @@ -17,7 +17,7 @@ #:use-module (gnu system shadow) #:use-module (rosenthal packages binaries) #:use-module (rosenthal packages networking) - #:use-module (rosenthal utils home-services-utils) + #:use-module (rosenthal utils serializers yaml) #:export (clash-configuration clash-service-type @@ -345,7 +345,7 @@ headers. This can expose sensitive information in your logs.") (wakapi config) (let ((config-file (mixed-text-file "wakapi.yaml" - #~(string-append #$@(serialize-yaml-config config) "\n")))) + #~(string-append #$@(yaml-serialize config) "\n")))) (list (shepherd-service (documentation "Run wakapi.") (provision '(wakapi)) diff --git a/modules/rosenthal/services/web.scm b/modules/rosenthal/services/web.scm index 92baac7..bdfaffc 100644 --- a/modules/rosenthal/services/web.scm +++ b/modules/rosenthal/services/web.scm @@ -19,7 +19,7 @@ #:use-module (gnu services shepherd) #:use-module (gnu system privilege) #:use-module (gnu system shadow) - #:use-module (rosenthal utils home-services-utils) + #:use-module (rosenthal utils serializers yaml) #:export (caddy-configuration caddy-service-type @@ -411,7 +411,7 @@ (let ((config-file (mixed-text-file "misskey.yaml" - #~(string-append #$@(serialize-yaml-config config) "\n")))) + #~(string-append #$@(yaml-serialize config) "\n")))) (list (oci-container-configuration (user "misskey") (group "docker") diff --git a/modules/rosenthal/utils/home-services-utils.scm b/modules/rosenthal/utils/home-services-utils.scm deleted file mode 100644 index 57fc97b..0000000 --- a/modules/rosenthal/utils/home-services-utils.scm +++ /dev/null @@ -1,441 +0,0 @@ -;; SPDX-FileCopyrightText: 2021 Xinglu Chen -;; SPDX-FileCopyrightText: 2021 Andrew Tropin -;; -;; SPDX-License-Identifier: GPL-3.0-or-later - -(define-module (rosenthal utils home-services-utils) - #:use-module (gnu services configuration) - #:use-module (gnu home services utils) - #:use-module (guix ui) - #:use-module (guix diagnostics) - #:use-module (guix gexp) - #:use-module (guix monads) - #:use-module (guix i18n) - #:use-module (guix profiles) - #:use-module (guix packages) - #:use-module (guix build-system trivial) - #:use-module (guix deprecation) - - #:use-module (ice-9 curried-definitions) - #:use-module (ice-9 match) - #:use-module (ice-9 string-fun) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-171) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-43) - - #:re-export (filter-configuration-fields - - list-of - - list-of-strings? - alist? - text-config? - serialize-text-config - generic-serialize-alist-entry - generic-serialize-alist - - maybe-object->string - object->snake-case-string - object->camel-case-string) - - #:export (slurp-file-gexp - - alist-entry->mixed-text - boolean->yes-or-no - boolean->true-or-false - list->human-readable-list - - ini-config? - generic-serialize-ini-config - generic-serialize-git-ini-config - - yaml-config? - serialize-yaml-config - - string-or-gexp? - serialize-string-or-gexp - - gexp-text-config? - serialize-gexp-text-config - - rest - maybe-list - optional - wrap-package - - define-enum - enum-name - enum-value)) - - -;;; -;;; User's utils. -;;; - -(define* (slurp-file-gexp file #:key (encoding "UTF-8")) - "Returns a gexp, which reads all the content of the FILE and returns -it as a string. FILE must be a file-like object." - (when (not (file-like? file)) - (raise (formatted-message - (G_ "~a is not a file-like object.") - file))) - #~(call-with-input-file #$file - (@ (ice-9 textual-ports) get-string-all) - #:encoding #$encoding)) - -(define-deprecated/alias slurp-file-gexp slurp-file-like) - - -;;; -;;; Configuration related helpers. -;;; - -(define* ((alist-entry->mixed-text prefix sep #:optional (suffix "\n")) - alist-entry) - "Create a list from ALIST-ENTRY, which can be used with -@code{mixed-text-file} for example to create key-value configuration -file or shell script. - -PREFIX is the string to prefix the key-value pair with. For example, -@code{\"export\"} will return @code{'(\"export\" KEY SEP VALUE)}, -where KEY is the first element of ALIST-ENTRY, and VALUE is the second -element of ALIST-ENTRY. - -SEP is the separator between the key and the value. - -SUFFIX is the optional argument, default to newline. - -Different things will happen depending on the value of VALUE: -@itemize @bullet -@item If VALUE is #f, ignore everything in the entry and just return -an empty list. - -@item If VALUE is #t or not provided (empty list), ignore the VALUE -and SEP and just return a list of PREFIX and KEY followed by a -SUFFIX. - -@item If VALUE is a flat list, it will get added to the resulting -list. If not flat the exception will be raised. - -@item If VALUE is not a list (string, file-like object, etc), return a -list of PREFIX, KEY, SEP and VALUE followed by a SUFFIX. - -The following code -@lisp -((alist-entry->mixed-text \"export \" \"=\") '(\"EDITOR\" . \"emacsclient\")) -((alist-entry->mixed-text \"export \" \"=\") '(\"EDITOR\" . #t)) -((alist-entry->mixed-text \"export \" \"=\") '(\"EDITOR\")) -((alist-entry->mixed-text \"export \" \"=\") '(\"EDITOR\" . #f)) -((alist-entry->mixed-text \"export \" \"=\") '(\"EDITOR\" . (\"emacsclient\" \"vim\"))) -@end lisp - -would yield - -@example -(\"export \" \"EDITOR\" \"=\" \"emacsclient\" \"\n\") -(\"export \" \"EDITOR\" \"\n\") -(\"export \" \"EDITOR\" \"\n\") -() -(\"export \" \"EDITOR\" \"=\" \"emacsclient\" \"vim\" \"\n\") -@end example" - (define (not-alist-entry-error) - (raise (formatted-message - (G_ "~a has to be an association list entry") - alist-entry))) - (match alist-entry - ((key . value) - (let* ((values (cond - ((eq? value #f) - #f) - ((or (eq? value #t) (null? value)) - '("")) - ((list? value) - (if (any list? value) - (raise (formatted-message - (G_ "~a is not a flat list") - value)) - value)) - (else - (list value)))) - (sep (if (eq? values '("")) - "" - sep))) - (if values - `(,prefix ,key ,sep ,@values ,suffix) - '()))) - (_ (not-alist-entry-error)))) - -(define* (boolean->yes-or-no bool #:optional (capitalize? #f)) - "Convert a boolean BOOL to \"yes\" or \"no\". -Setting CAPITALIZE? to @code{#t} will capitalize the word, it is set to -@code{#f} by default." - (let ((word (if (eq? bool #t) "yes" "no"))) - (if capitalize? - (string-capitalize word) - word))) - -(define* (boolean->true-or-false bool #:optional (capitalize? #f)) - "Convert a boolean BOOL to \"true\" or \"false\". -Setting CAPITALIZE? to @code{#t} will capitalize the word, it is set to -@code{#f} by default." - (let ((word (if bool "true" "false"))) - (if capitalize? - (string-capitalize word) - word))) - -;; TODO: Remove once upstreamed -(define* (list->human-readable-list lst - #:key - (cumulative? #f) - (proc identity)) - "Turn a list LST into a sequence of terms readable by humans. -If CUMULATIVE? is @code{#t}, use ``and'', otherwise use ``or'' before -the last term. - -PROC is a procedure to apply to each of the elements of a list before -turning them into a single human readable string. - -@example -(list->human-readable-list '(1 4 9) #:cumulative? #t #:proc sqrt) -@result{} \"1, 2, and 3\" -@end example - -yields:" - (let* ((word (if cumulative? "and " "or ")) - (init (append (drop-right lst 1)))) - (format #f "~a" (string-append - (string-join - (map (compose maybe-object->string proc) init) - ", " 'suffix) - word - (maybe-object->string (proc (last lst))))))) - - - -;;; -;;; Serializers. -;;; - -(define ini-config? list?) -(define (generic-serialize-ini-config-section section proc) - "Format a section from SECTION for an INI configuration. -Apply the procedure PROC on SECTION after it has been converted to a string" - (format #f "[~a]\n" (proc section))) - -(define default-ini-format-section - (match-lambda - ((section subsection) - (string-append (maybe-object->string section) " " - (maybe-object->string subsection))) - (section - (maybe-object->string section)))) - -(define* (generic-serialize-ini-config - #:key - (combine-ini string-join) - (combine-alist string-append) - (combine-section-alist string-append) - (format-section default-ini-format-section) - serialize-field - fields) - "Create an INI configuration from nested lists FIELDS. This uses -@code{generic-serialize-ini-config-section} and @{generic-serialize-alist} to -serialize the section and the association lists, respectively. - -@example -(generic-serialize-ini-config - #:serialize-field (lambda (a b) (format #f \"~a = ~a\n\" a b)) - #:format-section (compose string-capitalize symbol->string) - #:fields '((application ((key . value))))) -@end example - -@result{} \"[Application]\nkey = value\n\"" - (combine-ini - (map (match-lambda - ((section alist) - (combine-section-alist - (generic-serialize-ini-config-section section format-section) - (generic-serialize-alist combine-alist serialize-field alist)))) - fields) - "\n")) - -(define* (generic-serialize-git-ini-config - #:key - (combine-ini string-join) - (combine-alist string-append) - (combine-section-alist string-append) - (format-section default-ini-format-section) - serialize-field - fields) - "Like @code{generic-serialize-ini-config}, but the section can also -have a @dfn{subsection}. FORMAT-SECTION will take a list of two -elements: the section and the subsection." - (combine-ini - (map (match-lambda - ((section subsection alist) - (combine-section-alist - (generic-serialize-ini-config-section - (list section subsection) format-section) - (generic-serialize-alist combine-alist serialize-field alist))) - ((section alist) - (combine-section-alist - (generic-serialize-ini-config-section section format-section) - (generic-serialize-alist combine-alist serialize-field alist)))) - fields) - "\n")) - -(define yaml-config? list?) -(define (make-yaml-indent depth) - (make-string (* 2 depth) #\space)) - -(define ((serialize-yaml-value depth) value) - (let* ((tab (make-yaml-indent depth))) - (cond - ((string? value) - (list (format #f "'~a'" value))) - ((boolean? value) - (list (format #f "~a" (if value "true" "false")))) - ((file-like? value) - (list value)) - ((alist? value) - (serialize-yaml-alist value #:depth (1+ depth))) - ((vector? value) - (serialize-yaml-vector value #:depth depth)) - (else (list (format #f "~a" value)))))) - -(define ((serialize-yaml-key depth) key) - (when (vector? key) - (raise (formatted-message - (G_ "Vector as key value are not supported by serializer, \ -try to avoid them. ~a") key))) - ((serialize-yaml-value depth) key)) - -(define ((serialize-yaml-key-value depth) key value) - (let ((tab (make-yaml-indent depth))) - `("\n" - ,tab - ,@((serialize-yaml-key depth) key) ": " - ,@((serialize-yaml-value depth) value)))) - -(define ((serialize-yaml-vector-elem depth) elem) - (let ((tab (make-yaml-indent (1+ depth)))) - (cons* - "\n" tab "- " - ((serialize-yaml-value (1+ depth)) elem)))) - -(define* (serialize-yaml-vector vec #:key (depth 0)) - (append-map (serialize-yaml-vector-elem depth) (vector->list vec))) - -(define* (serialize-yaml-alist lst #:key (depth 0)) - (generic-serialize-alist append (serialize-yaml-key-value depth) lst)) - -(define (serialize-yaml-config config) - "Simplified yaml serializer, which supports only a subset of yaml, use -it with caution." - (serialize-yaml-alist config)) - -(define (string-or-gexp? sg) (or (string? sg) (gexp? sg))) -(define (serialize-string-or-gexp field-name val) "") - -;; Guix proper has a different version of text-config. -(define (gexp-text-config? config) - (and (list? config) (every string-or-gexp? config))) -(define (serialize-gexp-text-config field-name val) - #~(string-append #$@(interpose val "\n" 'suffix))) - -;;; -;;; Miscellaneous. -;;; - -(define rest cdr) - -;; Confusing with maybe-list type. -(define (maybe-list a) - "If A is a list, return it, otherwise return a singleton list with A." - (if (list? a) - a - (list a))) - -;; If EXPR1 evaluates to a non-@code{#f} value and EXPR2 is specified, -;; return EXPR2; if it isn't specified, return EXPR1. Otherwise, return -;; an empty list @code{'()}. -(define-syntax optional - (syntax-rules () - ((_ expr1) - (if expr1 expr1 '())) - ((_ expr1 expr2) - (if expr1 expr2 '())))) - -(define (wrap-package pkg executable-name gexp) - "Create a @code{} object that is a wrapper for PACKAGE, and -runs GEXP. NAME is the name of the executable that will be put in the store." - (let* ((wrapper-name (string-append executable-name "-wrapper")) - (wrapper (program-file wrapper-name gexp))) - (package - (inherit pkg) - (name wrapper-name) - (source wrapper) - (propagated-inputs `((,(package-name pkg) ,pkg))) - (build-system trivial-build-system) - (arguments - `(#:modules - ((guix build utils)) - #:builder - (begin - (use-modules (guix build utils) - (srfi srfi-1)) - (let* ((bin (string-append %output "/bin")) - (wrapper (assoc-ref %build-inputs "source"))) - (mkdir-p bin) - (copy-file wrapper (string-append bin "/" ,executable-name))))))))) - - -;;; -;;; Enums. -;;; - -(define-record-type - (make-enum name value) - enum? - (name enum-name) - (value enum-value)) - -;; Copied from (gnu services configuration) -(define-syntax-rule (id ctx parts ...) - "Assemble PARTS into a raw (unhygienic) identifier." - (datum->syntax ctx (symbol-append (syntax->datum parts) ...))) - -;; (define-enum pinentry-flavor -;; '(emacs gtk qt ncurses tty)) -;; -;; (pinentry-flavor? 'gtk) -;; => #t -;; -;; (enum-value pinentry-flavor) -;; => '(emacs gtk qt ncurses tty) -;; -;; (pinentry-flavor? 'vim) -;; exception: `pinetry-flavor' must be one of `emacs', `gtk', `qt', -;; `ncurses', or `tty', was given `vim' - -(define-syntax define-enum - (lambda (x) - (syntax-case x () - ((_ stem value) - (with-syntax ((stem? (id #'stem #'stem #'?)) - (msg (list->human-readable-list - (second (syntax->datum #'value)) - #:proc (cut format #f "`~a'" <>)))) - #'(begin - (define stem (make-enum (quote stem) value)) - - (define (stem? val) - (if (member val value) - #t - (raise (formatted-message - (G_ "`~a' must of ~a, was given: ~s") - (enum-name stem) - (syntax->datum msg) - val)))))))))) diff --git a/modules/rosenthal/utils/serializers/ini.scm b/modules/rosenthal/utils/serializers/ini.scm new file mode 100644 index 0000000..82db486 --- /dev/null +++ b/modules/rosenthal/utils/serializers/ini.scm @@ -0,0 +1,154 @@ +;;; SPDX-FileCopyrightText: Copyright © 2022 Andrew Tropin +;;; +;;; SPDX-License-Identifier: GPL-3.0-or-later + +(define-module (rosenthal utils serializers ini) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + + #:use-module (rosenthal utils serializers utils) + + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module (guix diagnostics) + #:use-module (guix ui) + + #:export (ini-serialize + ini-print + ini-merge + ini-append + + serialize-ini-config + ini-config?)) + +(define ini-config? list?) + +(define sample-ini + `((global ((daemon) + (log . file))) + (http ((host . 127.0.0.1) + (port . 1234))))) + +(define (format-ini-section section) + (match section + ('global "") + (name (format #f "[~a]\n" (symbol->string name))))) + +(define* (ini-serialize + config + #:key + (equal-string " = ") + (format-ini-section format-ini-section)) + "For global properties use global section, the properties will be added to the +beginning of the list before any section, this behavior can be adjusted with +FORMAT-INI-SECTION argument. + +@lisp +`((global ((daemon) + (log . file))) + (http ((host . 127.0.0.1) + (port . 1234)))) +@end lisp + +would yeld + +@example +@end example +" + (define (serialize-ini-term term) + (match term + (#t "true") + (#f "false") + ((? symbol? e) (symbol->string e)) + ((? number? e) (number->string e)) + ((? string? e) (object->string e)) + ((lst ...) + (raise (formatted-message + (G_ "INI term should be a non-list value (string, \ +boolean, number, symbol, or gexp). Provided term is:\n ~a") lst))) + (e e))) + + (define (serialize-ini-properties properties) + (unless (alist? properties) + (raise (formatted-message + (G_ "INI properties should be an alist, \ +but provided value is:\n ~a") properties))) + (append-map + (match-lambda + ((? gexp? e) + (list e "\n")) + ((k) + (list (serialize-ini-term k) equal-string "\n")) + ((k . v) + (list (serialize-ini-term k) equal-string + (serialize-ini-term v) "\n"))) + properties)) + + (define (serialize-ini-section section) + (match section + ((name properties) + (append + (list (format-ini-section name)) + (serialize-ini-properties properties))) + (e + (raise (formatted-message + (G_ "INI section should be a list containing a section name as \ +the first element and alist of properties as the second, but provided value \ +is:\n~a") e))))) + + ;; TODO: serialize global section before all other sections. + (append-map + (lambda (expr) + (append + (match expr + ((? gexp? e) (list e)) + (e (serialize-ini-section e))) + (list "\n"))) + config)) + +(define (ini-merge ini1 ini2) + "Combine to INIs. Naive quadratic implementation, which can be rediculously +slow." + (define keys-to-merge + (fold + (match-lambda* + (((k v) acc) (if (assoc-ref ini2 k) (cons k acc) acc)) + (((? gexp? e) acc) acc)) + '() ini1)) + + (define enriched-ini1 + (fold-right + (match-lambda* + (((k v) acc) + (cons + (cons k (list (append v (car (or (assoc-ref ini2 k) '(())))))) + acc)) + (((? gexp? e) acc) (cons e acc))) + '() + ini1)) + + (define stripped-ini2 + (remove (match-lambda + ((k . v) (memq k keys-to-merge)) + (e #f)) + ini2)) + (append enriched-ini1 stripped-ini2)) + +(define (ini-append x acc) + (ini-merge acc x)) + +(define serialize-ini-config ini-serialize) +;; (display +;; (merge-ini +;; '((section1 ((k1 . v1))) +;; (section2 ((k4 . v4)))) +;; '((section1 ((k2 . v2) +;; (k3 . v3))) +;; (section3 ((k5 . v5)))))) + +;; (cdr '(a ((k . v) (k2 . v2)))) + +(define (ini-print ini) + "Prints generated INI, useful for debugging." + (display (apply string-append (ini-serialize ini)))) diff --git a/modules/rosenthal/utils/serializers/utils.scm b/modules/rosenthal/utils/serializers/utils.scm new file mode 100644 index 0000000..fb4baa0 --- /dev/null +++ b/modules/rosenthal/utils/serializers/utils.scm @@ -0,0 +1,36 @@ +;;; SPDX-FileCopyrightText: Copyright © 2022 Andrew Tropin +;;; +;;; SPDX-License-Identifier: GPL-3.0-or-later + +(define-module (rosenthal utils serializers utils) + #:use-module (gnu services configuration) + #:use-module (guix gexp) + #:use-module (srfi srfi-1) + + #:export (alist? + + path? + serialize-path + + string-or-gexp? + serialize-string-or-gexp + + gexp-text-config? + serialize-gexp-text-config) + #:re-export (interpose)) + +(define (alist? lst) + (every pair? lst)) + + +(define path? string?) +(define (serialize-path field-name val) val) + +(define (string-or-gexp? sg) (or (string? sg) (gexp? sg))) +(define (serialize-string-or-gexp field-name val) "") + +;; Guix proper has a different version of text-config. +(define (gexp-text-config? config) + (and (list? config) (every string-or-gexp? config))) +(define (serialize-gexp-text-config field-name val) + #~(string-append #$@(interpose val "\n" 'suffix))) diff --git a/modules/rosenthal/utils/serializers/yaml.scm b/modules/rosenthal/utils/serializers/yaml.scm new file mode 100644 index 0000000..c620184 --- /dev/null +++ b/modules/rosenthal/utils/serializers/yaml.scm @@ -0,0 +1,153 @@ +;;; SPDX-FileCopyrightText: Copyright © 2023 Miguel Ángel Moreno +;;; +;;; SPDX-License-Identifier: GPL-3.0-or-later + +(define-module (rosenthal utils serializers yaml) + #:use-module (rosenthal utils serializers utils) + #:use-module (gnu home services utils) + #:use-module (gnu services configuration) + #:use-module (guix diagnostics) + #:use-module (guix gexp) + #:use-module (guix ui) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) + #:export (yaml-print + yaml-config? + yaml-serialize + + serialize-yaml-term + serialize-yaml-element + serialize-yaml-config)) + +(define yaml-config? list?) + +(define (yaml-term? t) + (fold (lambda (x acc) (or acc (x t))) + #f + (list boolean? symbol? number? string? file-like? gexp?))) + +(define (serialize-yaml-string v) + (format #f "~s" v)) + +(define (serialize-yaml-symbol v) + (format #f "~a" v)) + +(define (serialize-yaml-term term) + (match term + ((? boolean? v) (if v "true" "false")) + ((? number? v) (number->string v)) + ((? string? v) (serialize-yaml-string v)) + ((? symbol? v) (serialize-yaml-symbol v)) + ((or (? gexp? v) + (? file-like? v)) + v) + (v (raise (formatted-message + (G_ "\ +YAML term should be boolean, number, string, symbol, or gexp. Provided term +is:\n ~a") v))))) + +(define (serialize-yaml-key k) + (list + (cond + ((symbol? k) (serialize-yaml-symbol k)) + ((string? k) (serialize-yaml-string k)) + (else (raise (formatted-message + (G_ "\ +YAML key should be symbol or string. Provided key is:\n ~a") + k)))))) + +(define (serialize-yaml-newline pretty?) + (if pretty? (list "\n") '())) + +(define (serialize-yaml-space pretty?) + (if pretty? (list " ") '())) + +(define (serialize-yaml-indentation level pretty?) + (if pretty? + (list (format #f "~v_" (- (* 2 level) 2))) + '())) + +(define (serialize-yaml-vector v level pretty?) + (append + (serialize-yaml-newline pretty?) + (vector-fold + (lambda (i acc e) + (append acc + (if (> i 0) + (serialize-yaml-newline pretty?) + '()) + (serialize-yaml-indentation (1+ level) pretty?) + (list "- ") + (match e + ((? alist? e) + (serialize-yaml-vector-alist e (+ 1 level) pretty?)) + (_ (serialize-yaml-element e (1+ level) pretty?))))) + '() v))) + +(define (serialize-yaml-list v pretty?) + (append + (list "[") + (interpose + (append-map + (lambda (x) + (serialize-yaml-element x 0 pretty?)) + v) + ", ") + (list "]"))) + +(define (serialize-yaml-pair v level pretty?) + (append + (serialize-yaml-indentation level pretty?) + (serialize-yaml-key (car v)) + (list ":") + (serialize-yaml-space pretty?) + (if (alist? (cdr v)) + (serialize-yaml-newline pretty?) + (list "")) + (serialize-yaml-element (cdr v) level pretty?))) + +(define (serialize-yaml-alist v level pretty?) + (append + (serialize-yaml-pair (car v) (1+ level) pretty?) + (append-map + (lambda (x) + (append + (serialize-yaml-newline pretty?) + (serialize-yaml-pair x (1+ level) pretty?))) + (cdr v)))) + +(define (serialize-yaml-vector-alist v level pretty?) + (append + (serialize-yaml-pair (car v) (- level (- level 1)) pretty?) + (append-map + (lambda (x) + (append + (serialize-yaml-newline pretty?) + (serialize-yaml-pair x (1+ level) pretty?))) + (cdr v)))) + +(define (serialize-yaml-element yaml level pretty?) + (append + (match yaml + (() (list "")) + ((? yaml-term? v) (list (serialize-yaml-term v))) + ((? alist? v) (serialize-yaml-alist v level pretty?)) + ((? list? v) (serialize-yaml-list v pretty?)) + ((? vector? v) (serialize-yaml-vector v level pretty?)) + (e (throw 'yaml-invalid yaml))))) + +(define (serialize-yaml-config f c) + #~(apply string-append + (list #$@(serialize-yaml-element c 0 #t)))) + +(define* (yaml-serialize config) + "Returns a list of YAML strings which have to be concatenated. It supports + gexps, file-likes, vectors -> arrays, alists -> dictionaries, etc." + (serialize-yaml-config #f config)) + +(define* (yaml-print yaml #:key (pretty? #t)) + "Prints the generated YAML, useful for debugging purposes." + (display (apply string-append + (serialize-yaml-element yaml 0 pretty?))))