blob: 17e111a57735700aa18809c28d095d4ea0eb8a86 (
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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
(in-package #:json)
(defparameter number-literal
(let ((signed-digits
(comp ((sign (optional (either (unit #\-)
(unit #\+))))
(natural (if sign
(either (many (unit-if #'digit-char-p))
(fail "Malformed number."))
(many (unit-if #'digit-char-p)))))
(cons sign natural))))
(comp ((base signed-digits)
(dot (optional (unit #\.)))
(fraction (if dot
(either (many (unit-if #'digit-char-p))
(fail "Malformed fractional part."))
nothing))
(e (optional (either (unit #\e) (unit #\E))))
(exponent (if e
(either signed-digits
(fail "Malformed exponent part."))
nothing)))
(read-from-string
(str:from-list
(remove nil (append base (cons dot fraction) (cons e exponent))))))))
(defparameter string-literal
(comp ((_ (unit #\"))
(chars (optional (many (either (comp ((slash (unit #\\))
(escaped (unit-if))
(codepoints (if (char= escaped #\u)
(comp ((cp0 (unit-if #'digit-char-p))
(cp1 (unit-if #'digit-char-p))
(cp2 (unit-if #'digit-char-p))
(cp3 (unit-if #'digit-char-p)))
(let ((str (make-string 7)))
(setf (char str 0) #\#)
(setf (char str 1) #\\)
(setf (char str 2) #\u)
(setf (char str 3) cp0)
(setf (char str 4) cp1)
(setf (char str 5) cp2)
(setf (char str 6) cp3)
str))
nothing)))
(case escaped
(#\n
#\Newline)
(#\t
#\Tab)
(#\u
(read-from-string codepoints))
(t escaped)))
(unit-if (lambda (x) (and (char/= x #\")
(char/= x #\\))))))))
(_ (either (unit #\")
(fail "String is not properly closed."))))
(str:from-list chars)))
(defparameter whitespace
(comp ((_ (optional (many (either (unit #\Space) (unit #\Newline) (unit #\Tab))))))
nil))
(defparameter true-symbol
(comp ((_ (unit #\t))
(_ (either (literal "rue")
(fail "Expected 'true'."))))
'true))
(defparameter false-symbol
(comp ((_ (unit #\f))
(_ (either (literal "alse")
(fail "Expected 'false'."))))
'false))
(defparameter null-symbol
(comp ((_ (unit #\n))
(_ (either (literal "ull")
(fail "Expected 'null'."))))
'null))
(defvar json-value)
(defparameter json-array
(comp ((_ (unit #\[))
(vn (optional (separated-list json-value (unit #\,))))
(_ (unit #\])))
(apply #'vector vn)))
(defparameter json-object
(let ((json-pair
(comp ((_ whitespace)
(k (either string-literal
(fail "Expected a string.")))
(_ whitespace)
(_ (either (unit #\:)
(fail "Expected a \":\"")))
(v json-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))))
(setf json-value
(comp ((_ whitespace)
(v (either number-literal
string-literal
json-object
json-array
true-symbol
false-symbol
null-symbol))
(_ whitespace))
v))
(defun parse-string (str)
(run json-value (input:from-string str)))
(defun parse-file (file)
(run json-value (input:from-file file)))
|
