-
Notifications
You must be signed in to change notification settings - Fork 2
/
macros.lisp
198 lines (181 loc) · 8.37 KB
/
macros.lisp
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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
;;;; SPDX-License-Identifier: BSD-3-Clause
(in-package #:njson)
(defmacro jif (test then &optional (else nil))
"JSON-aware version of `cl:if'.
If TEST is `jtruep' evaluate THEN, otherwise evaluate ELSE."
`(if (jtruep ,test)
,then
,else))
(defmacro jwhen (test &body body)
"JSON-aware version of `cl:when'.
If TEST is `jtruep' evaluate BODY."
`(jif ,test
(progn ,@body)))
(defmacro jor (&rest args)
"JSON-aware version of `cl:or'."
`(or ,@(loop for arg in args
collecting `(jwhen ,arg ,arg))))
(defmacro jand (&rest args)
"JSON-aware version of `cl:and'."
`(and ,@(loop for arg in args
collecting `(jwhen ,arg ,arg))))
(defun check-value (expected indices object)
"Check that JSON value in OBJECT at INDICES is `equal' to EXPECTED specification."
(restart-case
(let ((result (jget indices object)))
(or (typecase expected
((eql t) (handler-case
(return-from check-value (jget* indices object))
(error () nil)))
((eql :true) (eq t result))
((eql :false) (eq nil result))
((and array (not string))
(and (arrayp result)
(not (stringp result))))
(list (hash-table-p result))
;; This is to allow double and single float comparisons.
(number (when (numberp result)
(< (abs (- result expected))
single-float-epsilon)))
(t (equal result expected)))
(cerror
"Ignore the mismatch"
'value-mismatch
:expected (typecase expected
((eql :true) t)
((eql :false) nil)
(null (make-hash-table))
(t expected))
:actual result
:object (jget (subseq indices 0
;; This 1- and max is to get the
;; "parent" of RESULT.
(max 0 (1- (length indices))))
object))
t))
(store-value (new-value)
:report "Replace the offending value"
:interactive read-new-value
(setf (jget indices object) new-value)
(check-value expected indices object))
(use-value (new-value)
:report "Return a replacement"
:interactive read-new-value
new-value)))
;; DESTRUCTURING-PATTERN is not a (&rest destructuring-pattern)
;; because it might be a vector too.
(defmacro jbind (destructuring-pattern form &body body)
"Match the FORM against DESTRUCTURING-PATTERN.
The pattern might be:
- A symbol, in which case the current chosen form is bound to it. If
the symbol is _, simply skip the form.
- A literal form:
- String or number: compare with `equal'.
- Keywords :TRUE, :FALSE, and :NULL, matching T, NIL, and :NULL
respectively.
- If the pattern is a property list of string+pattern pairs, match the
string+pattern pairs inside it to the provided JSON object and
resolve them recursively.
- If the pattern is a list of symbols (VAR &optional VAR-P), these are
bound to the respective values of `jget'. It is a good way to make
`jbind' to be more lenient to missing keys, because the default
behavior is to error on missing data.
- If the pattern is an inline vector, match it against a JSON array
with at least as many elements as provided in the vector. Match
every form in the vector against the element with the same index.
If the DESTRUCTURING-PATTERN doesn't match the object, throw
`value-mismatch'.
Underlying `jget' can throw errors for the exceptionally malformed
inputs. See `jget' documentation for the types of errors it throws.
Example:
\(\"hello\" hello \"a\" _ \"b\" b
\"array\" #(first second third _))
matches a JSON object
{\"hello\": 3, \"a\": 8, \"b\": 3, \"c\": null, \"array\": [1, 2, 3, 4]}
and binds
- HELLO to 3
- B to 3
- FIRST to 1
- SECOND to 2
- THIRD to 3
It also checks that \"a\" key is present in the object and there's a
fourth element in the nested array.
See more examples in njson tests."
(let ((form-sym (gensym "BIND-FORM"))
(bindings (list)))
(labels ((parse-pattern (pattern &optional (current-path (list)))
(etypecase pattern
((or (member :true :false :null) string real)
(push (cons pattern (copy-list current-path))
bindings))
((cons symbol *)
(push (cons pattern (copy-list current-path))
bindings))
(list
(loop for (key subpattern) on pattern by #'cddr
do (parse-pattern subpattern (append current-path (list key))))
(push (cons nil (copy-list current-path))
bindings))
((and symbol (not keyword))
(push (cons (if (equal "_" (symbol-name pattern))
(gensym "_PATTERN")
pattern)
(copy-list current-path))
bindings))
(array
(loop for elem across pattern
for index from 0
do (parse-pattern elem (append current-path (list index))))
(push (cons #() (copy-list current-path))
bindings)))))
(check-type destructuring-pattern (or list (and array (not string))
(and symbol (not keyword)))
"proper jbind destructuring pattern: list, array, or symbol")
(parse-pattern destructuring-pattern)
(let ((let-forms (loop for (binding . key) in bindings
do (check-type binding (or array real symbol
;; For (VAR VAR-P) forms
(cons symbol (or (cons symbol null)
null))))
if (typep binding '(or array real null
(member :true :false :null)))
collect `(,(gensym) (check-value ,binding (vector ,@key) ,form-sym))
else if (and (symbolp binding)
(uiop:emptyp key))
collect `(,binding ,form-sym)
else if (listp binding)
append (destructuring-bind (var &optional (var-p nil var-p-provided))
binding
(append
`((,var (jget (vector ,@key) ,form-sym)))
(when var-p-provided
`((,var-p (nth-value 1 (jget (vector ,@key) ,form-sym)))))))
else
collect `(,binding (check-value t (vector ,@key) ,form-sym)))))
`(let* ((,form-sym ,form)
,@let-forms)
(declare (ignorable ,form-sym ,@(mapcar #'first let-forms)))
,@body)))))
(defmacro jmatch (form &body clauses)
"Similar to Trivia match macro, match the FORM (JSON value) against CLAUSES.
CLAUSES are (PATTERN . BODY) forms, where
- PATTERN is a `jbind' destructuring pattern.
- And BODY is an implicit progn.
If PATTERN matches successfully in `jbind', then BODY is executed with
the variables from the PATTERN bound to the respective values, as per
`jbind'.
The last clause could start with T, OTHERWISE, ELSE, or _, and it will
be invoked if other patterns don't match. If there's no such clause,
`jmatch' will simply return NIL on no matching patterns."
(let ((form-sym (gensym "MATCH-FORM")))
`(let ((,form-sym ,form))
(cond
,@(loop for (pattern . body) in clauses
when (and (symbolp pattern)
(member (symbol-name pattern) '("T" "_" "OTHERWISE" "ELSE")
:test #'string=))
collect `(t ,@body)
else
collect `((ignore-errors (jbind ,pattern ,form-sym t))
(jbind ,pattern ,form-sym ,@body)))))))