about summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--.repl5
-rw-r--r--fff.json.sld7
-rw-r--r--fff.json.ss78
3 files changed, 88 insertions, 2 deletions
diff --git a/.repl b/.repl index 7d50383..af13f78 100644 --- a/.repl +++ b/.repl
@@ -3,12 +3,13 @@
3#+chicken (import (r7rs)) 3#+chicken (import (r7rs))
4 4
5(let loop ((load-files '("fff.parse" 5(let loop ((load-files '("fff.parse"
6 "fff.read"))) 6 "fff.read"
7 "fff.json")))
7 (if (null? load-files) 8 (if (null? load-files)
8 #t 9 #t
9 (let ((this (car load-files))) 10 (let ((this (car load-files)))
10 (load (string-append (car load-files) ".sld")) 11 (load (string-append (car load-files) ".sld"))
11 (eval `(import ,(map string->symbol (string-split this ".")))) 12 ;; (eval `(import ,(map string->symbol (string-split this "."))))
12 (load (string-append (car load-files) ".ss")) 13 (load (string-append (car load-files) ".ss"))
13 (loop (cdr load-files))))) 14 (loop (cdr load-files)))))
14 15
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 @@
1;;; (fff josn)
2
3#+chicken (import r7rs)
4
5(define-library (fff json)
6 (export fff->json)
7 (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 @@
1;;; (fff json) --- serialize fff to json
2;; NOTE: serialization does NOT work the other way---my thinking is, if you've
3;; got data in json, it's already too complex for fff.
4
5(import (scheme base)
6 (chicken format)
7 (chicken string)
8 (srfi 14)
9 (utf8)
10 (fff read))
11
12(define (fff->json fff)
13 (cond
14 ((list? fff)
15 (string-append "{"
16 (string-intersperse (map fff->json fff) ",")
17 "}"))
18 ((vector? fff)
19 (string-append "["
20 (string-intersperse
21 (vector->list (vector-map fff->json fff))
22 ",")
23 "]"))
24 ((pair? fff)
25 (string-append (fff->json (car fff))
26 ":"
27 (fff->json (cdr fff))))
28 ((eq? fff #t) "true")
29 ((eq? fff #f) "false")
30 ((eq? fff 'null) "null")
31 ((string? fff) (string-append "\"" (escape-json-string fff) "\""))
32 ((number? fff) (number->string fff))
33 (else (error "Bad type" fff))))
34
35(define (escape-json-string str)
36 (let loop ((cs (string->list str))
37 (acc '()))
38 (if (null? cs)
39 (list->string (reverse acc))
40 (loop (cdr cs)
41 (append (let ((c (car cs)))
42 (cond
43 ((memq c '(#\\ #\" #\/ #\backspace #\page
44 #\newline #\return #\tab))
45 (case c
46 ((#\\) ; reverse solidus
47 '(#\\ #\\))
48 ((#\") ; quotation mark
49 '(#\" #\\))
50 ((#\/) ; solidus
51 '(#\/ #\\))
52 ((#\backspace)
53 '(#\b #\\))
54 ((#\page) ; form-feed
55 '(#\f #\\))
56 ((#\newline) ; linefeed
57 '(#\n #\\))
58 ((#\return) ; carriage return
59 '(#\r #\\))
60 ((#\tab) ; horizontal tab
61 '(#\t #\\))))
62 ((and (not (char-set-contains? char-set:ascii c))
63 (not (char-set-contains?
64 char-set:iso-control c)))
65 (reverse
66 (string->list (string-append
67 "\\u"
68 (zero-pad-hex (char->integer c))))))
69 (else (list c))))
70 acc)))))
71
72(define (zero-pad-hex n)
73 (let ((x (sprintf "~x" n)))
74 (case (string-length x)
75 ((1) (string-append "000" x))
76 ((2) (string-append "00" x))
77 ((3) (string-append "0" x))
78 (else x))))