Add a scm->yaml generator

1 files changed, 85 insertions, 0 deletions

diff --git a/scripts/yaml.scm b/scripts/yaml.scm
new file mode 100644
index 0000000..f940911
--- /dev/null
+++ b/scripts/yaml.scm
@@ -0,0 +1,85 @@
+;;
+;; scm->yaml
+;;
+;; This file implements a library to convert a scm tree to yaml.
+
+(define-module (yaml)
+  #:use-module (ice-9 match)
+  #:export (scm->yaml))
+
+(define (kebab->camel string)
+  "Convert STRING from kebab case to CAMEL case."
+  (match (string-split string #\-)
+    ((head tail ...)
+     (string-concatenate
+      (cons head (map string-titlecase tail))))))
+
+(define (display-atom atom port)
+  "Display ATOM in PORT converting from kebab case to camel case if
+ATOM is a symbol."
+  (cond
+   ((symbol? atom)
+    (display (string->symbol (kebab->camel (symbol->string atom))) port))
+   ((number? atom)
+    (display atom port))
+   ((string? atom)
+    ;; Escape string with double quotes if
+    ;; - every character is a digit or period, and the unescaped
+    ;; string can therefore be misinterpreted as a number
+    ;; - string contains the colon character
+    (if (or (string-every (char-set-union char-set:digit (char-set #\.)) atom)
+            (string-any #\: atom))
+        (write atom port)
+        (display atom port)))
+   ((boolean? atom)
+    (display (if atom "true" "false") port))
+   (else (error "Unknown atom" atom))))
+
+(define (indent-level port level)
+  "Emit whitespaces to PORT corresponding to nesting LEVEL."
+  (display (make-string (* 2 level) #\space) port))
+
+(define (display-array-element element port level)
+  "Display array ELEMENT to PORT at nesting LEVEL."
+  (display "- " port)
+  (scm->yaml element port (1+ level)))
+
+(define (display-dictionary-entry entry port level)
+  "Display dictionary ENTRY to PORT at nesting LEVEL."
+  (match entry
+    ((key . value)
+     (display-atom key port)
+     (display ":" port)
+     (match value
+       ((or #(_ ...)
+            ((_ . _) (_ . _) ...))
+        (newline port)
+        (indent-level port (1+ level))
+        (scm->yaml value port (1+ level)))
+       (_ (display " " port)
+          (scm->yaml value port level))))))
+
+(define* (scm->yaml scm #:optional (port (current-output-port)) (level 0))
+  "Convert SCM, an S-expression tree, to YAML and display to
+PORT. LEVEL is an internal recursion variable."
+  (match scm
+    (#(head tail ...)
+     (display-array-element head port level)
+     (for-each (lambda (element)
+                 (indent-level port level)
+                 (display-array-element element port level))
+               tail))
+    (#()
+     (display "[]" port))
+    ((head tail ...)
+     (display-dictionary-entry head port level)
+     (for-each (lambda (entry)
+                 (indent-level port level)
+                 (display-dictionary-entry entry port level))
+               tail))
+    (()
+     (display "{}" port)
+     (newline port))
+    (symbol
+     (display-atom symbol port)
+     (newline port))))