blob: 62724c8f5f8cafcfe5a58e859ad5800b082f96b1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
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))))
|
