From c3c73e1a10999a7e1549b3c538e2d953bd26ebdc Mon Sep 17 00:00:00 2001
From: hylo <hylo@posteo.de>
Date: Fri, 30 Dec 2022 17:53:13 +0100
Subject: [PATCH] feat: initial encododer (wip)

---
 test/test-encoder.scm |  16 ++++++
 toml/builder.scm      | 110 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 126 insertions(+)
 create mode 100755 test/test-encoder.scm
 create mode 100644 toml/builder.scm

diff --git a/test/test-encoder.scm b/test/test-encoder.scm
new file mode 100755
index 0000000..7153320
--- /dev/null
+++ b/test/test-encoder.scm
@@ -0,0 +1,16 @@
+#!/usr/bin/env -S guile -s
+!#
+(use-modules
+ (toml parser)
+ (json)
+ (ice-9 match)
+ (ice-9 textual-ports)
+ (ice-9 pretty-print))
+
+(set-port-conversion-strategy! (current-input-port) 'error)
+
+;; (define str (get-string-all (current-input-port)))
+
+(define scm (json->scm (current-input-port)))
+
+(display scm)
diff --git a/toml/builder.scm b/toml/builder.scm
new file mode 100644
index 0000000..89d8c65
--- /dev/null
+++ b/toml/builder.scm
@@ -0,0 +1,110 @@
+(define-module (toml builder)
+  #:use-module (srfi srfi-1)
+  #:use-module (json)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 receive)
+  #:export (scm->toml))
+
+
+(define-syntax-rule (log-exprs exp ...) (begin (format #t "~a: ~S\n" (quote exp) exp) ...))
+
+;; we want to be able to dynamically bind this functin in test-decoder.scm
+;; TODO fix duplicate
+(define value?
+  (make-parameter
+   (lambda (expr) (not (list? expr)))))
+
+;; (define scm->value
+;;   (lambda))
+
+(define (build-object-pair p port)
+  ;; (log-exprs p)
+  ;; (put-string port "pair:")
+  (put-string port (car p))
+  (put-string port " = ")
+  ;; (put-string port (cdr p))
+  ;; (newline port)
+  ;; (put-string port (indent-string pretty level))
+  ;; (json-build-string (car p) port solidus unicode)
+  ;; (put-string port ":")
+  ;; (build-space port pretty)
+  (toml-build (cdr p) port))
+
+(define (toml-build-string s port)
+  (put-string port "\"")
+  (put-string port s)
+  (put-string port "\"")
+  (newline port))
+
+;; (define (values-first a b)
+;;   (let ((av? ((value?) a))
+;;         (bv? ((value?) b)))
+;;    (cond
+;;     ((and av? bv?) #t)
+;;     (av? #t)
+;;     (bv? #f))))
+
+(define (build-table scm port)
+  (put-string port "[")
+  (put-string port (car scm))
+  (put-string port "]")
+  (newline port)
+  (toml-build (cdr scm) port))
+
+(define (toml-build-object scm port)
+  (let ((pairs scm))
+    (unless (null? pairs)
+      (receive (keyvals tables)
+          (partition (value?) pairs)
+        (for-each (lambda (kv)
+                    (build-object-pair kv port))
+                  keyvals)
+        (for-each (lambda (t)
+                    (build-table t port))
+                  tables)))))
+
+;; (build-object-pair (car pairs) port)
+;; (for-each (lambda (p)
+;;             (build-object-pair p port))
+;;           (cdr pairs))
+;; (newline port))))
+
+(define (toml-build scm port)
+  ;; (log-exprs scm)
+  (cond
+   ;; ((eq? scm null) (toml-build-null port))
+   ;; ((boolean? scm) (toml-build-boolean scm port))
+   ;; ((toml-number? scm) (toml-build-number scm port))
+   ;; ((symbol? scm) (toml-build-string (symbol->string scm) port))
+   ((string? scm) (toml-build-string scm port))
+   ;; ((vector? scm) (toml-build-array scm port))
+   ((or (pair? scm) (null? scm))
+    (toml-build-object scm port))))
+;; (else (throw 'toml-invalid scm))))
+
+(define* (scm->toml scm
+                    #:optional (port (current-output-port)))
+  (toml-build scm port))
+
+;; (scm->toml '(("a" . "b") ("c" . "d")))
+;; (scm->toml '(("yo" ("a" . "b"))))
+;; (scm->toml '(("yo" ("a" . "b") ("c" . "d")) ("e" . "f")))
+
+'(("servers"
+   ("beta" ("role" . "backend") ("ip" . "10.0.0.2"))
+   ("alpha"
+    ("role" . "frontend")
+    ("ip" . "10.0.0.1")))
+  ("database"
+   ("temp_targets" ("case" . 72.0) ("cpu" . 79.5))
+   ("data" . #(#("delta" "phi") #(3.14)))
+   ("ports" . #(8000 8001 8002))
+   ("enabled" . #t))
+  ("owner"
+   ("dob"
+    . "date")
+   ("name" . "Tom Preston-Werner"))
+  ("title" . "TOML Example"))
+
+'()