From 3c824a2ce132e0fd2c78c511261e002a8b33f130 Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Mon, 5 Jun 2023 00:12:30 -0500
Subject: Add (fff json)

(fff json) serializes fff to json, but not the other way.
---
 .repl        |  5 ++--
 fff.json.sld |  7 ++++++
 fff.json.ss  | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 88 insertions(+), 2 deletions(-)
 create mode 100644 fff.json.sld
 create mode 100644 fff.json.ss

diff --git a/.repl b/.repl
index 7d50383..af13f78 100644
--- a/.repl
+++ b/.repl
@@ -3,12 +3,13 @@
 #+chicken (import (r7rs))
 
 (let loop ((load-files '("fff.parse"
-                         "fff.read")))
+                         "fff.read"
+                         "fff.json")))
   (if (null? load-files)
       #t
       (let ((this (car load-files)))
         (load (string-append (car load-files) ".sld"))
-        (eval `(import ,(map string->symbol (string-split this "."))))
+        ;; (eval `(import ,(map string->symbol (string-split this "."))))
         (load (string-append (car load-files) ".ss"))
         (loop (cdr load-files)))))
 
diff --git a/fff.json.sld b/fff.json.sld
new file mode 100644
index 0000000..d2745cd
--- /dev/null
+++ b/fff.json.sld
@@ -0,0 +1,7 @@
+;;; (fff josn)
+
+#+chicken (import r7rs)
+
+(define-library (fff json)
+  (export fff->json)
+  (include "fff.json.ss"))
diff --git a/fff.json.ss b/fff.json.ss
new file mode 100644
index 0000000..62724c8
--- /dev/null
+++ b/fff.json.ss
@@ -0,0 +1,78 @@
+;;; (fff json) --- serialize fff to json
+;; NOTE: serialization does NOT work the other way---my thinking is, if you've
+;; got data in json, it's already too complex for fff.
+
+(import (scheme base)
+        (chicken format)
+        (chicken string)
+        (srfi 14)
+        (utf8)
+        (fff read))
+
+(define (fff->json fff)
+  (cond
+   ((list? fff)
+    (string-append "{"
+                   (string-intersperse (map fff->json fff) ",")
+                   "}"))
+   ((vector? fff)
+    (string-append "["
+                   (string-intersperse
+                    (vector->list (vector-map fff->json fff))
+                    ",")
+                   "]"))
+   ((pair? fff)
+    (string-append (fff->json (car fff))
+                   ":"
+                   (fff->json (cdr fff))))
+   ((eq? fff #t) "true")
+   ((eq? fff #f) "false")
+   ((eq? fff 'null) "null")
+   ((string? fff) (string-append "\"" (escape-json-string fff) "\""))
+   ((number? fff) (number->string fff))
+   (else (error "Bad type" fff))))
+
+(define (escape-json-string str)
+  (let loop ((cs (string->list str))
+             (acc '()))
+    (if (null? cs)
+        (list->string (reverse acc))
+        (loop (cdr cs)
+              (append (let ((c (car cs)))
+                        (cond
+                         ((memq c '(#\\ #\" #\/ #\backspace #\page
+                                    #\newline #\return #\tab))
+                          (case c
+                            ((#\\)      ; reverse solidus
+                             '(#\\ #\\))
+                            ((#\")      ; quotation mark
+                             '(#\" #\\))
+                            ((#\/)      ; solidus
+                             '(#\/ #\\))
+                            ((#\backspace)
+                             '(#\b #\\))
+                            ((#\page)   ; form-feed
+                             '(#\f #\\))
+                            ((#\newline) ; linefeed
+                             '(#\n #\\))
+                            ((#\return) ; carriage return
+                             '(#\r #\\))
+                            ((#\tab)    ; horizontal tab
+                             '(#\t #\\))))
+                         ((and (not (char-set-contains? char-set:ascii c))
+                               (not (char-set-contains?
+                                     char-set:iso-control c)))
+                          (reverse
+                           (string->list (string-append
+                                          "\\u"
+                                          (zero-pad-hex (char->integer c))))))
+                         (else (list c))))
+                      acc)))))
+
+(define (zero-pad-hex n)
+  (let ((x (sprintf "~x" n)))
+    (case (string-length x)
+      ((1) (string-append "000" x))
+      ((2) (string-append "00" x))
+      ((3) (string-append "0" x))
+      (else x))))
-- 
cgit 1.4.1-21-gabe81