From b69c1857f9b1f811d510f70cff2e15bc02bb2fea Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Juan=20Manuel=20Tom=C3=A1s?= <jtomas1815@gmail.com>
Date: Fri, 4 Nov 2022 01:35:33 -0300
Subject: Generate a better parse tree

---
 json.lisp | 48 ++++++++++++++++++++++++++++++++----------------
 1 file changed, 32 insertions(+), 16 deletions(-)

(limited to 'json.lisp')

diff --git a/json.lisp b/json.lisp
index 44d6262..ab6d52b 100644
--- a/json.lisp
+++ b/json.lisp
@@ -19,7 +19,9 @@
                        (either signed-digits
                                (fail "Malformed exponent part."))
                        nothing)))
-      (list 'number base fraction exponent))))
+      (read-from-string
+        (str:from-list
+          (remove nil (append base (cons dot fraction) (cons e exponent))))))))
 
 (defparameter string-literal
   (comp ((_ (unit (lambda (x) (char= x #\"))))
@@ -30,11 +32,14 @@
                                                                   (cp1 (unit #'digit-char-p))
                                                                   (cp2 (unit #'digit-char-p))
                                                                   (cp3 (unit #'digit-char-p)))
-                                                             (let ((str (make-string 4)))
-                                                               (setf (char str 0) cp0)
-                                                               (setf (char str 1) cp1)
-                                                               (setf (char str 2) cp2)
-                                                               (setf (char str 3) cp3)
+                                                             (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
@@ -43,11 +48,12 @@
                                           (#\t
                                            #\Tab)
                                           (#\u
-                                           codepoints)
+                                           (read-from-string codepoints))
                                           (t escaped)))
-                                      (unit (lambda (x) (char/= x #\"))))))
+                                      (unit (lambda (x) (and (char/= x #\")
+                                                             (char/= x #\\)))))))
          (_ (unit (lambda (x) (char= x #\")))))
-    (list 'string chars)))
+    (str:from-list chars)))
 
 (defparameter whitespace
   (comp ((_ (zero-or-more (unit (lambda (x) (or (char= x #\Space)
@@ -89,9 +95,11 @@
                              vi))
                nothing))
          (_ (unit (lambda (x) (char= x #\])))))
-    (if vn
-      (list 'array (cons v0 vn))
-      (list 'array v0))))
+    (if v0
+      (if vn
+        (cons v0 vn)
+        (list v0))
+      'empty-array)))
 
 (defparameter json-object
   (let ((json-pair
@@ -100,7 +108,7 @@
                  (_ whitespace)
                  (_ (unit (lambda (x) (char= x #\:))))
                  (v json-value))
-            (list 'pair k v))))
+            (cons k v))))
     (comp ((_ (unit (lambda (x) (char= x #\{))))
            (v0 (either json-pair
                        whitespace))
@@ -110,9 +118,17 @@
                                  vi))
                  nothing))
            (_ (unit (lambda (x) (char= x #\})))))
-      (if vn
-        (list 'object (cons v0 vn))
-        (list 'object v0)))))
+      (if v0
+        (if vn
+          (let* ((vlist (cons v0 vn))
+                 (obj (make-hash-table :test #'equal :size (length vlist))))
+            (dolist (v vlist)
+              (setf (gethash (car v) obj) (cdr v)))
+            obj)
+          (let ((obj (make-hash-table :test #'equal)))
+            (setf (gethash (car v0) obj) (cdr v0))
+            obj))
+        'empty-object))))
 
 (setf json-value
   (comp ((_ whitespace)
-- 
cgit v1.2.3