From 888e53f97c0a1ef5b714b9b7a3dc1a896b873fdb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Juan=20Manuel=20Tom=C3=A1s?= <jtomas1815@gmail.com>
Date: Thu, 3 Nov 2022 10:17:11 -0300
Subject: Add parsers for most of the spec

Some concessions were made when handling unicode and whitespace.
---
 json.lisp | 71 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 71 insertions(+)

(limited to 'json.lisp')

diff --git a/json.lisp b/json.lisp
index 94f04ee..cc3e0c1 100644
--- a/json.lisp
+++ b/json.lisp
@@ -54,3 +54,74 @@
                                                 (char= x #\Newline)
                                                 (char= x #\Tab)))))))
     nil))
+
+(defparameter true-symbol
+  (comp ((_ (unit (lambda (x) (char= x #\t))))
+         (_ (unit (lambda (x) (char= x #\r))))
+         (_ (unit (lambda (x) (char= x #\u))))
+         (_ (unit (lambda (x) (char= x #\e)))))
+    'true))
+
+(defparameter false-symbol
+  (comp ((_ (unit (lambda (x) (char= x #\f))))
+         (_ (unit (lambda (x) (char= x #\a))))
+         (_ (unit (lambda (x) (char= x #\l))))
+         (_ (unit (lambda (x) (char= x #\s))))
+         (_ (unit (lambda (x) (char= x #\e)))))
+    'false))
+
+(defparameter null-symbol
+  (comp ((_ (unit (lambda (x) (char= x #\n))))
+         (_ (unit (lambda (x) (char= x #\u))))
+         (_ (unit (lambda (x) (char= x #\l))))
+         (_ (unit (lambda (x) (char= x #\l)))))
+    'null))
+
+(defvar json-value)
+
+(defparameter json-array
+  (comp ((_ (unit (lambda (x) (char= x #\[))))
+         (v0 (either json-value
+                     whitespace))
+         (vn (if v0
+               (zero-or-more (comp ((_ (unit (lambda (x) (char= #\,))))
+                                  (vi json-value))
+                             vi))
+               nothing))
+         (_ (unit (lambda (x) (char= x #\])))))
+    (if vn
+      (list 'array (cons v0 vn))
+      (list 'array v0))))
+
+(defparameter json-object
+  (let ((json-pair
+          (comp ((_ whitespace)
+                 (k string-literal)
+                 (_ whitespace)
+                 (_ (unit (lambda (x) (char= x #\:))))
+                 (v json-value))
+            (list 'pair k v))))
+    (comp ((_ (unit (lambda (x) (char= x #\{))))
+           (v0 (either json-pair
+                       whitespace))
+           (vn (if v0
+                 (zero-or-more (comp ((_ (unit (lambda (x) (char= #\,))))
+                                      (vi json-pair))
+                                 vi))
+                 nothing))
+           (_ (unit (lambda (x) (char= x #\})))))
+      (if vn
+        (list 'object (cons v0 vn))
+        (list 'object v0)))))
+
+(setf json-value
+  (comp ((_ whitespace)
+         (v (either number-literal
+                    string-literal
+                    json-array
+                    json-object
+                    true-symbol
+                    false-symbol
+                    null-symbol))
+         (_ whitespace))
+    v))
-- 
cgit v1.2.3