1 files changed, 120 insertions, 0 deletions
diff --git a/load.lisp b/load.lisp
new file mode 100644
index 0000000..80fef99
--- /dev/null
+++ b/load.lisp
@@ -0,0 +1,120 @@
+(in-package #:json)
+
+(defparameter number-literal
+  (let ((signed-digits
+          (comp ((sign (optional (one-of (unit #\-)
+                                         (unit #\+))))
+                 (natural (if sign
+                            (one-of (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
+                       (one-of (many (unit-if #'digit-char-p))
+                               (fail "Malformed fractional part."))
+                       nothing))
+           (e (optional (one-of (unit #\e) (unit #\E))))
+           (exponent (if e
+                       (one-of 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 (one-of (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 #\\))))))))
+         (_ (one-of (unit #\")
+                    (fail "String is not properly closed."))))
+    (str:from-list chars)))
+
+(defparameter true-symbol
+  (comp ((_ (unit #\t))
+         (_ (one-of (literal "rue")
+                    (fail "Expected 'true'."))))
+    'true))
+
+(defparameter false-symbol
+  (comp ((_ (unit #\f))
+         (_ (one-of (literal "alse")
+                    (fail "Expected 'false'."))))
+    'false))
+
+(defparameter null-symbol
+  (comp ((_ (unit #\n))
+         (_ (one-of (literal "ull")
+                    (fail "Expected 'null'."))))
+    'null))
+
+(defvar json-value nil)
+
+(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 (one-of string-literal
+                            (fail "Expected a string.")))
+                 (_ whitespace)
+                 (_ (one-of (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 (one-of 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)))