1 files changed, 78 insertions, 0 deletions

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