blob: 65b85d97f1028ff65af0974d073b063a99cc8d9a (
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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
(in-package #:json)
(defparameter number-literal
(let ((signed-digits
(comp ((sign (optional (one-of (unit #\-)
(unit #\+))))
(natural (many (unit digit-char-p))))
(cons sign natural))))
(comp ((base signed-digits)
(dot (optional (unit #\.)))
(fraction (if dot
(many (unit digit-char-p))
nothing))
(e (optional (one-of (unit #\e) (unit #\E))))
(exponent (if e
signed-digits
nothing)))
(read-from-string
(coerce
(remove nil (append base
(cons dot fraction)
(cons (when e #\d) exponent)))
'string)))))
(defparameter string-literal
(comp ((_ (unit #\"))
(chars
(optional
(many
(one-of
(comp ((slash (unit #\\))
(escaped (unit))
(codepoints (if (char= escaped #\u)
(repeat (unit digit-char-p) 4)
nothing)))
(case escaped
(#\n #\Newline)
(#\t #\Tab)
(#\u (read-from-string
(coerce (append '(#\# #\\ #\u)
codepoints)
'string)))
(t escaped)))
(unit (and (char/= it #\") (char/= it #\\)))))))
(_ (unit #\")))
(coerce chars 'string)))
(defmacro json-symbol (name)
`(comp ((v (literal ,name)))
(intern v)))
(defparameter true-symbol
(json-symbol "true"))
(defparameter false-symbol
(json-symbol "false"))
(defparameter null-symbol
(json-symbol "null"))
(defun json-array (value)
(comp ((_ (unit #\[))
(vn (optional (separated-list value (unit #\,))))
(_ (unit #\])))
(apply #'vector vn)))
(defun json-object (value)
(let ((json-pair
(comp ((_ whitespace)
(k string-literal)
(_ whitespace)
(_ (unit #\:))
(v value))
(cons k v))))
(comp ((_ (unit #\{))
(vn (optional (separated-list json-pair (unit #\,))))
(_ (unit #\})))
(let* ((obj (make-hash-table :test #'equal :size (length vn))))
(dolist (v vn)
(setf (gethash (car v) obj) (cdr v)))
obj))))
(defparameter json-value
(comp ((_ whitespace)
(value (one-of number-literal
string-literal
(json-object json-value)
(json-array json-value)
true-symbol
false-symbol
null-symbol))
(_ whitespace))
value))
(defun from-string (str)
(parse json-value str))
(defun from-file (path)
(let (buf)
(with-open-file (f path)
(let ((size (file-length f)))
(setf buf (make-string size))
(read-sequence buf f)))
(parse json-value buf)))
|
