# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1597370804 14400
# Node ID d23a34c34dc3f1d45797fd0a474dd49e84f84fd8
# Parent  d093b64cf92c17041ddbfa6af27e66f6ee3bf23f
Split main.lisp into basic/mop files

diff -r d093b64cf92c -r d23a34c34dc3 jarl.asd
--- a/jarl.asd	Wed Aug 12 23:09:58 2020 -0400
+++ b/jarl.asd	Thu Aug 13 22:06:44 2020 -0400
@@ -13,7 +13,8 @@
   :serial t
   :components ((:module "src" :serial t
                 :components ((:file "package")
-                             (:file "main")))))
+                             (:file "basic")
+                             (:file "mop")))))
 
 
 (asdf:defsystem :jarl/test
diff -r d093b64cf92c -r d23a34c34dc3 src/basic.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/basic.lisp	Thu Aug 13 22:06:44 2020 -0400
@@ -0,0 +1,435 @@
+(in-package :jarl)
+
+;;;; Input --------------------------------------------------------------------
+(defstruct input
+  (stream nil :type stream)
+  (line 1 :type (and fixnum (integer 0)))
+  (column 0 :type (and fixnum (integer 0))))
+
+(defun p (input &optional (eof :eof)) ; peek
+  (peek-char nil (input-stream input) nil eof))
+
+(defun r (input) ; read
+  (let ((character (read-char (input-stream input) nil :eof)))
+    (case character
+      (#\newline (progn
+                   (incf (input-line input))
+                   (setf (input-column input) 0)))
+      (#\tab (incf (input-column input) 8))
+      (t (incf (input-column input))))
+    character))
+
+
+;;;; Errors -------------------------------------------------------------------
+(define-condition json-parsing-error (error)
+  ((line :accessor line :initarg :line)
+   (class-designator :accessor class-designator :initarg :class-designator)
+   (column :accessor column :initarg :column)
+   (message :accessor message :initarg :message))
+  (:report (lambda (c stream)
+             (format stream "Error parsing JSON~@[ into ~S~] at line ~D column ~D: ~A"
+                     (class-designator c)
+                     (line c)
+                     (column c)
+                     (message c)))))
+
+(defun e (class input format-string &rest args) ; error
+  (error 'json-parsing-error
+         :class-designator class
+         :line (input-line input)
+         :column (input-column input)
+         :message (apply #'format nil format-string args)))
+
+
+;;;; Parsing Utilities --------------------------------------------------------
+(defun skip-whitespace (input)
+  (loop :for ch = (p input)
+        :while (member ch '(#\space #\tab #\newline #\linefeed #\return))
+        :do (r input)))
+
+(defun requires-escape-p (character)
+  (or (char= #\" character)
+      (char= #\\ character)
+      (<= (char-code character) #x1F)))
+
+(defun parse-literal (input literal remaining-characters)
+  (loop :for next :across remaining-characters
+        :for char = (r input)
+        :unless (eql next char)
+        :do (e 'keyword input "expected ~S when parsing ~S but got ~S" next literal char))
+  literal)
+
+(defun parse-hex-digit (input)
+  (let ((ch (r input)))
+    (if (eql :eof ch)
+      (e nil input "cannot parse \\u escape sequence, got ~S" :eof)
+      (or (digit-char-p ch 16)
+          (e nil input "cannot parse \\u escape sequence, ~S is not a hexadecimal digit" ch)))))
+
+(defun parse-escaped-character (input)
+  (let ((ch (r input)))
+    (case ch
+      (#\" #\")
+      (#\\ #\\)
+      (#\/ #\/)
+      (#\b #\backspace)
+      (#\f (code-char #x0C))
+      (#\n #\linefeed)
+      (#\r #\return)
+      (#\t #\tab)
+      (#\u (let ((a (parse-hex-digit input)) ; todo handle surrogate pairs
+                 (b (parse-hex-digit input))
+                 (c (parse-hex-digit input))
+                 (d (parse-hex-digit input)))
+             (code-char (+ (* a (expt 16 3)) ; todo maybe do this more portably
+                           (* b (expt 16 2))
+                           (* c (expt 16 1))
+                           (* d (expt 16 0))))))
+      (t (e nil input "bad escape sequence ~S ~S" #\\ ch)))))
+
+(defun parse-int (input &optional (allow-leading-zero t))
+  (loop :with i = 0
+        :with n = 0
+        :for ch = (p input #\e)
+        :for digit = (digit-char-p ch)
+        :while digit
+        :do (progn (r input)
+                   (when (and (not allow-leading-zero)
+                              (zerop n) ; leading
+                              (zerop digit) ; zero
+                              (digit-char-p (p input #\e))) ; but not a bare zero
+                     (e nil input "bad leading zero"))
+                   (incf n)
+                   (setf i (+ (* 10 i) digit)))
+        :finally (if (zerop n)
+                   (e nil input "expected an integer")
+                   (return (values i n)))))
+
+(defun parse-exponent (input)
+  (let* ((char (p input))
+         (sign (if (member char '(#\+ #\-))
+                 (progn (r input)
+                        (case char
+                          (#\+ 1)
+                          (#\- -1)))
+                 1)))
+    (* sign (parse-int input))))
+
+(defun parse-number (input)
+  (let ((sign 1) integer
+        (fractional 0) (fractional-length 0)
+        (exponent 0) has-exponent)
+    (when (eql #\- (p input))
+      (r input)
+      (setf sign -1))
+    (setf integer (parse-int input nil))
+    (when (eql #\. (p input))
+      (r input)
+      (setf (values fractional fractional-length) (parse-int input)))
+    (when (member (p input) '(#\e #\E))
+      (r input)
+      (setf exponent (parse-exponent input)
+            has-exponent t))
+    (if (and (zerop fractional-length) (not has-exponent))
+      (* sign integer)
+      (values
+        (coerce ;; todo make this less horrifying
+          (read-from-string (format nil "~A~D.~V,'0Dd~D"
+                                    (if (= -1 sign) #\- #\+)
+                                    integer
+                                    fractional-length
+                                    fractional
+                                    exponent))
+          'double-float)))))
+
+(defun parse-kv-separator (class input)
+  (skip-whitespace input)
+  (let ((ch (r input)))
+    (unless (eql #\: ch)
+      (e class input "expected separator ~S but got ~S" #\: ch))
+    (skip-whitespace input)))
+
+(defun json-type-of (object)
+  (typecase object
+    (integer 'integer)
+    (float 'float)
+    (t (type-of object))))
+
+
+;;;; Readers ------------------------------------------------------------------
+(defgeneric read% (class contained-class input))
+
+
+(defmethod read% ((class (eql 'nil)) contained-class input)
+  ;; Optimized reader for cases where you don't actually care about the value
+  ;; and just need to parse over it without allocating anything.
+  (labels
+      ((any% ()
+         (case (p input)
+           (:eof (r input) (e nil input "got ~S" :eof))
+           (#\n (literal% "null"))
+           (#\t (literal% "true"))
+           (#\f (literal% "false"))
+           (#\" (string%))
+           (#\{ (object%))
+           (#\[ (array%))
+           ((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (number%))
+           (t (e nil input "unexpected character ~S" (r input)))))
+       (literal% (string)
+         (loop :for next :across string
+               :for char = (r input)
+               :unless (eql next char)
+               :do (e nil input "expected ~S when parsing ~S but got ~S" next string char)))
+       (array% ()
+         (r input) ; [
+         (skip-whitespace input)
+         (if (eql (p input) #\])
+           (r input)
+           (loop (any%)
+                 (skip-whitespace input)
+                 (let ((ch (r input)))
+                   (case ch
+                     (#\] (return))
+                     (#\, (skip-whitespace input))
+                     (t (e nil input "expected ~S or ~S but got ~S." #\] #\, ch)))))))
+       (object% ()
+         (r input) ; {
+         (skip-whitespace input)
+         (if (eql (p input) #\})
+           (r input)
+           (loop
+             (string%)
+             (parse-kv-separator nil input)
+             (any%)
+             (skip-whitespace input)
+             (let ((ch (r input)))
+               (case ch
+                 (#\} (return))
+                 (#\, (skip-whitespace input))
+                 (t (e nil input "expected ~S or ~S but got ~S" #\} #\, ch)))))))
+       (number% ()
+         ;; TODO: Optimize this too.  Not a huge priority since fixnums don't cons.
+         (parse-number input))
+       (string% ()
+         (let ((ch (r input)))
+           (unless (eql ch #\")
+             (e nil input "expected opening ~S but got ~S" #\" ch)))
+         (loop :for ch = (r input)
+               :do (cond
+                     ((eql ch :eof) (e nil input "got ~S" :eof))
+                     ((eql ch #\\) (parse-escaped-character input)) ; TODO: Optimize this too.
+                     ((eql ch #\") (return))
+                     ((requires-escape-p ch) (e nil input "bad unescaped character ~S" ch))
+                     (t nil)))))
+    (skip-whitespace input)
+    (any%)
+    (values)))
+
+(defmethod read% ((class (eql 'keyword)) contained-class input)
+  (let ((ch (r input)))
+    (case ch
+      (#\t (parse-literal input :true "rue"))
+      (#\f (parse-literal input :false "alse"))
+      (t (e 'keyword input "expected ~S or ~S but got ~S" #\t #\f ch)))))
+
+(defmethod read% ((class (eql 'null)) contained-class input)
+  (let ((ch (r input)))
+    (if (eql ch #\n)
+      (parse-literal input nil "ull")
+      (e 'null input "expected ~S but got ~S" #\n ch))))
+
+(defmethod read% ((class (eql 'vector)) contained-class input)
+  (let ((ch (r input)))
+    (unless (eql ch #\[)
+      (e 'vector input "expected ~S but got ~S" #\[ ch)))
+  (skip-whitespace input)
+  ;; todo allow specialized vectors?
+  (if (eql (p input) #\])
+    (progn (r input) (vector))
+    (coerce
+      (loop
+        :with c = (car contained-class)
+        :with cc = (cadr contained-class)
+        :collect (read% c cc input)
+        :do (progn
+              (skip-whitespace input)
+              (let ((ch (r input)))
+                (case ch
+                  (#\] (loop-finish))
+                  (#\, (skip-whitespace input))
+                  (t (e 'vector input "expected ~S or ~S but got ~S." #\] #\, ch))))))
+      'vector)))
+
+(defmethod read% ((class (eql 'string)) contained-class input)
+  (let ((ch (r input)))
+    (unless (eql ch #\")
+      (e 'string input "expected opening ~S but got ~S" #\" ch)))
+  (with-output-to-string (s)
+    (loop :for ch = (r input)
+          :do (cond
+                ((eql ch :eof) (e 'string input "got ~S" :eof))
+                ((eql ch #\\) (write-char (parse-escaped-character input) s))
+                ((eql ch #\") (loop-finish))
+                ((requires-escape-p ch) (e 'string input "bad unescaped character ~S" ch))
+                (t (write-char ch s))))))
+
+(defmethod read% ((class (eql 'hash-table)) contained-class input)
+  (let ((ch (r input)))
+    (unless (eql ch #\{)
+      (e 'hash-table input "expected ~S but got ~S" #\{ ch)))
+  (skip-whitespace input)
+  (let ((result (make-hash-table :test #'equal)))
+    (if (eql (p input) #\})
+      (r input)
+      (loop
+        :with c = (car contained-class)
+        :with cc = (cadr contained-class)
+        :for name = (read% 'string nil input)
+        :for sep = (parse-kv-separator 'hash-table input)
+        :for value = (progn (skip-whitespace input)
+                            (read% c cc input))
+        :do (progn
+              (setf (gethash name result) value)
+              (skip-whitespace input)
+              (let ((ch (r input)))
+                (case ch
+                  (#\} (loop-finish))
+                  (#\, (skip-whitespace input))
+                  (t (e 'hash-table input "expected ~S or ~S but got ~S" #\} #\, ch)))))))
+    result))
+
+(defmethod read% ((class (eql 'number)) contained-class input)
+  (let ((ch (p input)))
+    (unless (member ch '(#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+      (r input) ; chomp to ensure accurate column count
+      (e 'number input "expected digit or ~S but got ~S" #\- ch)))
+  (parse-number input))
+
+(defmethod read% ((class (eql 'nullable)) contained-class input)
+  (case (p input)
+    (:eof (e `(or null ,input) input "got ~S"  :eof))
+    (#\n (read% 'null nil input))
+    (t (read% (first contained-class) (second contained-class) input))))
+
+(defmethod read% ((class (eql t)) contained-class input)
+  (skip-whitespace input)
+  (case (p input)
+    (:eof (r input) (e 't input "got ~S" :eof))
+    ((#\t #\f) (read% 'keyword nil input))
+    (#\n (read% 'null nil input))
+    (#\" (read% 'string nil input))
+    (#\{ (read% 'hash-table '(t) input))
+    (#\[ (read% 'vector '(t) input))
+    ((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (read% 'number nil input))
+    (t (e 't input "unexpected character ~S" (r input)))))
+
+
+;;;; Printing -----------------------------------------------------------------
+(defun write-escaped-char (char stream)
+  (case char
+    ((#\newline #\linefeed) (write-string "\\n" stream))
+    (#\return (write-string "\\r" stream))
+    (#\\ (write-string "\\\\" stream))
+    (t (format stream "\\u~4,'0X" (char-code char)))))
+
+
+(defgeneric print% (thing stream))
+
+(defmethod print% ((thing null) stream)
+  (write-string "null" stream))
+
+(defmethod print% ((thing string) stream)
+  (write-char #\" stream)
+  (loop :for char :across thing
+        :do (if (requires-escape-p char)
+              (write-escaped-char char stream)
+              (write-char char stream)))
+  (write-char #\" stream))
+
+(defmethod print% ((thing vector) stream)
+  (write-char #\[ stream)
+  (loop :with first = t
+        :for object :across thing
+        :do (progn (if first
+                     (setf first nil)
+                     (write-char #\, stream))
+                   (print% object stream)))
+  (write-char #\] stream))
+
+(defmethod print% ((thing hash-table) stream)
+  (write-char #\{ stream)
+  (loop :with first = t
+        :for name :being :the hash-keys :in thing :using (hash-value value)
+        :do (progn (if first
+                     (setf first nil)
+                     (write-char #\, stream))
+                   (assert (stringp name))
+                   (print% name stream)
+                   (write-char #\: stream)
+                   (print% value stream)))
+  (write-char #\} stream))
+
+(defmethod print% ((thing single-float) stream)
+  (let ((*read-default-float-format* 'single-float))
+    (princ thing stream)))
+
+(defmethod print% ((thing double-float) stream)
+  (let ((*read-default-float-format* 'double-float))
+    (princ thing stream)))
+
+(defmethod print% ((thing integer) stream)
+  (format stream "~D" thing))
+
+(defmethod print% ((thing (eql :false)) stream)
+  (write-string "false" stream))
+
+(defmethod print% ((thing (eql :true)) stream)
+  (write-string "true" stream))
+
+
+;;;; API ----------------------------------------------------------------------
+(defun canonicalize-class-designator (class-designator)
+  (flet ((fail () (error "Malformed class designator ~S" class-designator)))
+    (etypecase class-designator
+      (cons (destructuring-bind (head a &optional (b nil b?)) class-designator
+              (ecase head
+                ; (vector foo)
+                ((hash-table vector)
+                 (progn (when b? (fail))
+                        (list head (canonicalize-class-designator a))))
+                ; (or null foo)
+                (or (progn
+                      (unless b? (fail)) ; must have a second option
+                      (when (eql 'null b) (rotatef a b)) ; sort a/b
+                      (unless (eql 'null a) (fail)) ; no arbitrary ors
+                      (list 'nullable (canonicalize-class-designator b)))))))
+      (symbol (case class-designator
+                (vector '(vector (t)))
+                (hash-table '(hash-table (t)))
+                (t (list class-designator)))))))
+
+(defun ensure-stream (stream-or-string)
+  (etypecase stream-or-string
+    (stream stream-or-string)
+    (string (make-string-input-stream stream-or-string))))
+
+(defun read (class-designator stream-or-string &optional (eof-error-p t) eof)
+  (let ((input (make-input :stream (ensure-stream stream-or-string))))
+    (skip-whitespace input)
+    (if (eql :eof (p input))
+      (if eof-error-p
+        (error 'end-of-file)
+        eof)
+      (destructuring-bind (class &optional contained)
+          (canonicalize-class-designator class-designator)
+        (read% class contained input)))))
+
+(defun print (object &optional (stream *standard-output*))
+  (let ((*read-default-float-format* 'double-float)
+        (*print-base* 10))
+    (etypecase stream
+      ((or stream (eql t)) (progn (print% object stream)
+                                  (values)))
+      (null (with-output-to-string (s)
+              (print% object s))))))
+
diff -r d093b64cf92c -r d23a34c34dc3 src/main.lisp
--- a/src/main.lisp	Wed Aug 12 23:09:58 2020 -0400
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,600 +0,0 @@
-(in-package :jarl)
-
-;;;; Input --------------------------------------------------------------------
-(defstruct input
-  (stream nil :type stream)
-  (line 1 :type (and fixnum (integer 0)))
-  (column 0 :type (and fixnum (integer 0))))
-
-(defun p (input &optional (eof :eof)) ; peek
-  (peek-char nil (input-stream input) nil eof))
-
-(defun r (input) ; read
-  (let ((character (read-char (input-stream input) nil :eof)))
-    (case character
-      (#\newline (progn
-                   (incf (input-line input))
-                   (setf (input-column input) 0)))
-      (#\tab (incf (input-column input) 8))
-      (t (incf (input-column input))))
-    character))
-
-
-;;;; Errors -------------------------------------------------------------------
-(define-condition json-parsing-error (error)
-  ((line :accessor line :initarg :line)
-   (class-designator :accessor class-designator :initarg :class-designator)
-   (column :accessor column :initarg :column)
-   (message :accessor message :initarg :message))
-  (:report (lambda (c stream)
-             (format stream "Error parsing JSON~@[ into ~S~] at line ~D column ~D: ~A"
-                     (class-designator c)
-                     (line c)
-                     (column c)
-                     (message c)))))
-
-(defun e (class input format-string &rest args) ; error
-  (error 'json-parsing-error
-         :class-designator class
-         :line (input-line input)
-         :column (input-column input)
-         :message (apply #'format nil format-string args)))
-
-
-;;;; Parsing Utilities --------------------------------------------------------
-(defun skip-whitespace (input)
-  (loop :for ch = (p input)
-        :while (member ch '(#\space #\tab #\newline #\linefeed #\return))
-        :do (r input)))
-
-(defun requires-escape-p (character)
-  (or (char= #\" character)
-      (char= #\\ character)
-      (<= (char-code character) #x1F)))
-
-(defun parse-literal (input literal remaining-characters)
-  (loop :for next :across remaining-characters
-        :for char = (r input)
-        :unless (eql next char)
-        :do (e 'keyword input "expected ~S when parsing ~S but got ~S" next literal char))
-  literal)
-
-(defun parse-hex-digit (input)
-  (let ((ch (r input)))
-    (if (eql :eof ch)
-      (e nil input "cannot parse \\u escape sequence, got ~S" :eof)
-      (or (digit-char-p ch 16)
-          (e nil input "cannot parse \\u escape sequence, ~S is not a hexadecimal digit" ch)))))
-
-(defun parse-escaped-character (input)
-  (let ((ch (r input)))
-    (case ch
-      (#\" #\")
-      (#\\ #\\)
-      (#\/ #\/)
-      (#\b #\backspace)
-      (#\f (code-char #x0C))
-      (#\n #\linefeed)
-      (#\r #\return)
-      (#\t #\tab)
-      (#\u (let ((a (parse-hex-digit input)) ; todo handle surrogate pairs
-                 (b (parse-hex-digit input))
-                 (c (parse-hex-digit input))
-                 (d (parse-hex-digit input)))
-             (code-char (+ (* a (expt 16 3)) ; todo maybe do this more portably
-                           (* b (expt 16 2))
-                           (* c (expt 16 1))
-                           (* d (expt 16 0))))))
-      (t (e nil input "bad escape sequence ~S ~S" #\\ ch)))))
-
-(defun parse-int (input &optional (allow-leading-zero t))
-  (loop :with i = 0
-        :with n = 0
-        :for ch = (p input #\e)
-        :for digit = (digit-char-p ch)
-        :while digit
-        :do (progn (r input)
-                   (when (and (not allow-leading-zero)
-                              (zerop n) ; leading
-                              (zerop digit) ; zero
-                              (digit-char-p (p input #\e))) ; but not a bare zero
-                     (e nil input "bad leading zero"))
-                   (incf n)
-                   (setf i (+ (* 10 i) digit)))
-        :finally (if (zerop n)
-                   (e nil input "expected an integer")
-                   (return (values i n)))))
-
-(defun parse-exponent (input)
-  (let* ((char (p input))
-         (sign (if (member char '(#\+ #\-))
-                 (progn (r input)
-                        (case char
-                          (#\+ 1)
-                          (#\- -1)))
-                 1)))
-    (* sign (parse-int input))))
-
-(defun parse-number (input)
-  (let ((sign 1) integer
-        (fractional 0) (fractional-length 0)
-        (exponent 0) has-exponent)
-    (when (eql #\- (p input))
-      (r input)
-      (setf sign -1))
-    (setf integer (parse-int input nil))
-    (when (eql #\. (p input))
-      (r input)
-      (setf (values fractional fractional-length) (parse-int input)))
-    (when (member (p input) '(#\e #\E))
-      (r input)
-      (setf exponent (parse-exponent input)
-            has-exponent t))
-    (if (and (zerop fractional-length) (not has-exponent))
-      (* sign integer)
-      (values
-        (coerce ;; todo make this less horrifying
-          (read-from-string (format nil "~A~D.~V,'0Dd~D"
-                                    (if (= -1 sign) #\- #\+)
-                                    integer
-                                    fractional-length
-                                    fractional
-                                    exponent))
-          'double-float)))))
-
-(defun parse-kv-separator (class input)
-  (skip-whitespace input)
-  (let ((ch (r input)))
-    (unless (eql #\: ch)
-      (e class input "expected separator ~S but got ~S" #\: ch))
-    (skip-whitespace input)))
-
-(defun json-type-of (object)
-  (typecase object
-    (integer 'integer)
-    (float 'float)
-    (t (type-of object))))
-
-
-;;;; Primitive Readers --------------------------------------------------------
-(defgeneric read% (class contained-class input))
-
-
-(defmethod read% ((class (eql 'nil)) contained-class input)
-  ;; Optimized reader for cases where you don't actually care about the value
-  ;; and just need to parse over it without allocating anything.
-  (labels
-      ((any% ()
-         (case (p input)
-           (:eof (r input) (e nil input "got ~S" :eof))
-           (#\n (literal% "null"))
-           (#\t (literal% "true"))
-           (#\f (literal% "false"))
-           (#\" (string%))
-           (#\{ (object%))
-           (#\[ (array%))
-           ((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (number%))
-           (t (e nil input "unexpected character ~S" (r input)))))
-       (literal% (string)
-         (loop :for next :across string
-               :for char = (r input)
-               :unless (eql next char)
-               :do (e nil input "expected ~S when parsing ~S but got ~S" next string char)))
-       (array% ()
-         (r input) ; [
-         (skip-whitespace input)
-         (if (eql (p input) #\])
-           (r input)
-           (loop (any%)
-                 (skip-whitespace input)
-                 (let ((ch (r input)))
-                   (case ch
-                     (#\] (return))
-                     (#\, (skip-whitespace input))
-                     (t (e nil input "expected ~S or ~S but got ~S." #\] #\, ch)))))))
-       (object% ()
-         (r input) ; {
-         (skip-whitespace input)
-         (if (eql (p input) #\})
-           (r input)
-           (loop
-             (string%)
-             (parse-kv-separator nil input)
-             (any%)
-             (skip-whitespace input)
-             (let ((ch (r input)))
-               (case ch
-                 (#\} (return))
-                 (#\, (skip-whitespace input))
-                 (t (e nil input "expected ~S or ~S but got ~S" #\} #\, ch)))))))
-       (number% ()
-         ;; TODO: Optimize this too.  Not a huge priority since fixnums don't cons.
-         (parse-number input))
-       (string% ()
-         (let ((ch (r input)))
-           (unless (eql ch #\")
-             (e nil input "expected opening ~S but got ~S" #\" ch)))
-         (loop :for ch = (r input)
-               :do (cond
-                     ((eql ch :eof) (e nil input "got ~S" :eof))
-                     ((eql ch #\\) (parse-escaped-character input)) ; TODO: Optimize this too.
-                     ((eql ch #\") (return))
-                     ((requires-escape-p ch) (e nil input "bad unescaped character ~S" ch))
-                     (t nil)))))
-    (skip-whitespace input)
-    (any%)
-    (values)))
-
-(defmethod read% ((class (eql 'keyword)) contained-class input)
-  (let ((ch (r input)))
-    (case ch
-      (#\t (parse-literal input :true "rue"))
-      (#\f (parse-literal input :false "alse"))
-      (t (e 'keyword input "expected ~S or ~S but got ~S" #\t #\f ch)))))
-
-(defmethod read% ((class (eql 'null)) contained-class input)
-  (let ((ch (r input)))
-    (if (eql ch #\n)
-      (parse-literal input nil "ull")
-      (e 'null input "expected ~S but got ~S" #\n ch))))
-
-(defmethod read% ((class (eql 'vector)) contained-class input)
-  (let ((ch (r input)))
-    (unless (eql ch #\[)
-      (e 'vector input "expected ~S but got ~S" #\[ ch)))
-  (skip-whitespace input)
-  ;; todo allow specialized vectors?
-  (if (eql (p input) #\])
-    (progn (r input) (vector))
-    (coerce
-      (loop
-        :with c = (car contained-class)
-        :with cc = (cadr contained-class)
-        :collect (read% c cc input)
-        :do (progn
-              (skip-whitespace input)
-              (let ((ch (r input)))
-                (case ch
-                  (#\] (loop-finish))
-                  (#\, (skip-whitespace input))
-                  (t (e 'vector input "expected ~S or ~S but got ~S." #\] #\, ch))))))
-      'vector)))
-
-(defmethod read% ((class (eql 'string)) contained-class input)
-  (let ((ch (r input)))
-    (unless (eql ch #\")
-      (e 'string input "expected opening ~S but got ~S" #\" ch)))
-  (with-output-to-string (s)
-    (loop :for ch = (r input)
-          :do (cond
-                ((eql ch :eof) (e 'string input "got ~S" :eof))
-                ((eql ch #\\) (write-char (parse-escaped-character input) s))
-                ((eql ch #\") (loop-finish))
-                ((requires-escape-p ch) (e 'string input "bad unescaped character ~S" ch))
-                (t (write-char ch s))))))
-
-(defmethod read% ((class (eql 'hash-table)) contained-class input)
-  (let ((ch (r input)))
-    (unless (eql ch #\{)
-      (e 'hash-table input "expected ~S but got ~S" #\{ ch)))
-  (skip-whitespace input)
-  (let ((result (make-hash-table :test #'equal)))
-    (if (eql (p input) #\})
-      (r input)
-      (loop
-        :with c = (car contained-class)
-        :with cc = (cadr contained-class)
-        :for name = (read% 'string nil input)
-        :for sep = (parse-kv-separator 'hash-table input)
-        :for value = (progn (skip-whitespace input)
-                            (read% c cc input))
-        :do (progn
-              (setf (gethash name result) value)
-              (skip-whitespace input)
-              (let ((ch (r input)))
-                (case ch
-                  (#\} (loop-finish))
-                  (#\, (skip-whitespace input))
-                  (t (e 'hash-table input "expected ~S or ~S but got ~S" #\} #\, ch)))))))
-    result))
-
-(defmethod read% ((class (eql 'number)) contained-class input)
-  (let ((ch (p input)))
-    (unless (member ch '(#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
-      (r input) ; chomp to ensure accurate column count
-      (e 'number input "expected digit or ~S but got ~S" #\- ch)))
-  (parse-number input))
-
-(defmethod read% ((class (eql 'nullable)) contained-class input)
-  (case (p input)
-    (:eof (e `(or null ,input) input "got ~S"  :eof))
-    (#\n (read% 'null nil input))
-    (t (read% (first contained-class) (second contained-class) input))))
-
-(defmethod read% ((class (eql t)) contained-class input)
-  (skip-whitespace input)
-  (case (p input)
-    (:eof (r input) (e 't input "got ~S" :eof))
-    ((#\t #\f) (read% 'keyword nil input))
-    (#\n (read% 'null nil input))
-    (#\" (read% 'string nil input))
-    (#\{ (read% 'hash-table '(t) input))
-    (#\[ (read% 'vector '(t) input))
-    ((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (read% 'number nil input))
-    (t (e 't input "unexpected character ~S" (r input)))))
-
-
-
-;;;; Object Parsers -----------------------------------------------------------
-(defun lisp-case-to-snake-case (string)
-  "Convert a Lisp-cased string designator `\"FOO-BAR\"` into snake cased `\"foo_bar\"`."
-  (substitute #\_ #\- (string-downcase string)))
-
-(defclass json-class (standard-class)
-  ((slot-name-to-json-name :accessor slot-name-to-json-name
-                           :initarg :slot-name-to-json-name
-                           :initform 'lisp-case-to-snake-case)
-   (unknown-slots :accessor unknown-slots
-                  :initarg :unknown-slots
-                  :initform :discard)
-   (name-initarg-map :accessor name-initarg-map)
-   (slot-name-alist :accessor slot-name-alist)))
-
-(defmethod c2mop:validate-superclass ((class json-class) (superclass standard-class))
-  t)
-
-
-(defclass json-direct-slot-definition (c2mop:standard-direct-slot-definition)
-  ((json-class :initarg :json :accessor json-class)
-   (json-name :initarg :json/name :accessor json-name)))
-
-(defclass json-effective-slot-definition (c2mop:standard-effective-slot-definition)
-  ((json-class :initarg :json :accessor json-class)
-   (json-name :initarg :json/name :accessor json-name)
-   (json-initarg :accessor json-initarg)))
-
-(defmethod c2mop:direct-slot-definition-class ((class json-class) &rest initargs)
-  (if (getf initargs :json)
-    (find-class 'json-direct-slot-definition)
-    (call-next-method)))
-
-(defvar *effective-slot-definition-class* nil)
-
-(defmethod c2mop:effective-slot-definition-class ((class json-class) &rest initargs)
-  (declare (ignore initargs))
-  ;; I'm not sure why we need to use this hack here, but for some reason
-  ;; initargs doesn't contain the slot options like :json and :json/name here
-  ;; like it does in direct-slot-definition-class.  So we need another way to
-  ;; know which class to use here.
-  (or *effective-slot-definition-class* (call-next-method)))
-
-(defmethod c2mop:compute-effective-slot-definition ((class json-class) name direct-slots)
-  (if (not (some (lambda (dslot)
-                   (typep dslot 'json-direct-slot-definition))
-                 direct-slots))
-    (call-next-method)
-    (let* ((*effective-slot-definition-class* (find-class 'json-effective-slot-definition))
-           (eslot (call-next-method))
-           (dslot (first direct-slots)) ; todo be smarter about coalescing these
-           (initarg (gensym (format nil "json-initarg-~A" name)))) ; todo nicer name
-      (setf (json-name eslot) (if (slot-boundp dslot 'json-name)
-                                (json-name dslot)
-                                (funcall (slot-name-to-json-name class) name)) ; todo make this less shitty
-            (json-class eslot) (if (slot-boundp dslot 'json-class)
-                                 (canonicalize-class-designator (json-class dslot))
-                                 '(t))
-            (json-initarg eslot) initarg) ; todo nicer name
-      (push initarg (c2mop:slot-definition-initargs eslot))
-      eslot)))
-
-
-(defun json-slots (class)
-  (remove-if-not (lambda (slot) (typep slot 'json-effective-slot-definition))
-                 (c2mop:class-slots class)))
-
-(defun make-name-initarg-map (class)
-  "Return a name/initarg map for the JSON slots of `class`.
-
-  The result will be a hash table of `{name: (initarg class contained-class)}`.
-
-  "
-  (let* ((slots (json-slots class))
-         (result (make-hash-table :test #'equal :size (length slots))))
-    (dolist (slot slots)
-      (destructuring-bind (c &optional cc) (json-class slot)
-        (setf (gethash (json-name slot) result)
-              (list (json-initarg slot) c cc))))
-    result))
-
-(defun make-slot-name-alist (class)
-  (mapcar (lambda (slot)
-            (cons (c2mop:slot-definition-name slot)
-                  (json-name slot)))
-          (json-slots class)))
-
-(defmethod shared-initialize ((class json-class) slot-names
-                              &rest initargs
-                              &key slot-name-to-json-name unknown-slots
-                              &allow-other-keys)
-  (apply #'call-next-method class slot-names
-         (append
-           (when slot-name-to-json-name ; todo assert length = 1
-             (list :slot-name-to-json-name (first slot-name-to-json-name)))
-           (when unknown-slots ; todo assert length = 1
-             (list :unknown-slots (first unknown-slots)))
-           initargs)))
-
-(defmethod c2mop:finalize-inheritance :after ((class json-class))
-  (setf (name-initarg-map class) (make-name-initarg-map class)
-        (slot-name-alist class) (make-slot-name-alist class)))
-
-
-(defun parse-json-class (class-name class input)
-  (let ((ch (r input)))
-    (unless (eql ch #\{)
-      (e class-name input "expected ~S but got ~S" #\{ ch)))
-  (skip-whitespace input)
-  (if (eql (p input) #\})
-    (progn
-      (r input)
-      (make-instance class))
-    (loop
-      :with unknown = (unknown-slots class)
-      :with map = (name-initarg-map class)
-      :with init = (list)
-      :for name = (read% 'string nil input)
-      :for sep = (parse-kv-separator class-name input)
-      :for (initarg c cc) = (gethash name map)
-      :do (progn
-            (if (null initarg)
-              (ecase unknown
-                (:discard (read% t nil input))
-                (:error (e class-name input "got unknown object attribute ~S" name)))
-              (progn
-                (push (read% c cc input) init)
-                (push initarg init)))
-            (skip-whitespace input)
-            (let ((ch (r input)))
-              (case ch
-                (#\} (loop-finish))
-                (#\, (skip-whitespace input))
-                (t (e class-name input "expected ~S or ~S but got ~S." #\} #\, ch)))))
-      :finally (return (apply #'make-instance class init)))))
-
-(defmethod read% ((class-name symbol) (contained-class null) (input input))
-  (let ((class (find-class class-name nil)))
-    (typecase class
-      (json-class
-        (c2mop:ensure-finalized class)
-        (parse-json-class class-name class input))
-      (null (error "Cannot find class ~S to parse JSON into." class-name))
-      (t (error "Cannot parse JSON into class ~S because that class is not a ~S"
-                class-name 'json-class)))))
-
-
-;;;; Printing -----------------------------------------------------------------
-(defun write-escaped-char (char stream)
-  (case char
-    ((#\newline #\linefeed) (write-string "\\n" stream))
-    (#\return (write-string "\\r" stream))
-    (#\\ (write-string "\\\\" stream))
-    (t (format stream "\\u~4,'0X" (char-code char)))))
-
-
-(defgeneric print% (thing stream))
-
-(defmethod print% ((thing null) stream)
-  (write-string "null" stream))
-
-(defmethod print% ((thing string) stream)
-  (write-char #\" stream)
-  (loop :for char :across thing
-        :do (if (requires-escape-p char)
-              (write-escaped-char char stream)
-              (write-char char stream)))
-  (write-char #\" stream))
-
-(defmethod print% ((thing vector) stream)
-  (write-char #\[ stream)
-  (loop :with first = t
-        :for object :across thing
-        :do (progn (if first
-                     (setf first nil)
-                     (write-char #\, stream))
-                   (print% object stream)))
-  (write-char #\] stream))
-
-(defmethod print% ((thing hash-table) stream)
-  (write-char #\{ stream)
-  (loop :with first = t
-        :for name :being :the hash-keys :in thing :using (hash-value value)
-        :do (progn (if first
-                     (setf first nil)
-                     (write-char #\, stream))
-                   (assert (stringp name))
-                   (print% name stream)
-                   (write-char #\: stream)
-                   (print% value stream)))
-  (write-char #\} stream))
-
-(defmethod print% ((thing single-float) stream)
-  (let ((*read-default-float-format* 'single-float))
-    (princ thing stream)))
-
-(defmethod print% ((thing double-float) stream)
-  (let ((*read-default-float-format* 'double-float))
-    (princ thing stream)))
-
-(defmethod print% ((thing integer) stream)
-  (format stream "~D" thing))
-
-(defmethod print% ((thing (eql :false)) stream)
-  (write-string "false" stream))
-
-(defmethod print% ((thing (eql :true)) stream)
-  (write-string "true" stream))
-
-(defmethod print% (thing stream)
-  (let ((class (class-of thing)))
-    (if (typep class 'json-class)
-      (progn
-        (write-char #\{ stream)
-        (loop :with first = t
-              :for (slot . name) :in (slot-name-alist class)
-              :when (slot-boundp thing slot)
-              :do (progn (if first
-                           (setf first nil)
-                           (write-char #\, stream))
-                         (print% name stream)
-                         (write-char #\: stream)
-                         (print% (slot-value thing slot) stream)))
-        (write-char #\} stream))
-      (error "Don't know how to print object ~S of class ~S as JSON." thing class))))
-
-
-;;;; API ----------------------------------------------------------------------
-(defun canonicalize-class-designator (class-designator)
-  (flet ((fail () (error "Malformed class designator ~S" class-designator)))
-    (etypecase class-designator
-      (cons (destructuring-bind (head a &optional (b nil b?)) class-designator
-              (ecase head
-                ; (vector foo)
-                ((hash-table vector)
-                 (progn (when b? (fail))
-                        (list head (canonicalize-class-designator a))))
-                ; (or null foo)
-                (or (progn
-                      (unless b? (fail)) ; must have a second option
-                      (when (eql 'null b) (rotatef a b)) ; sort a/b
-                      (unless (eql 'null a) (fail)) ; no arbitrary ors
-                      (list 'nullable (canonicalize-class-designator b)))))))
-      (symbol (case class-designator
-                (vector '(vector (t)))
-                (hash-table '(hash-table (t)))
-                (t (list class-designator)))))))
-
-(defun ensure-stream (stream-or-string)
-  (etypecase stream-or-string
-    (stream stream-or-string)
-    (string (make-string-input-stream stream-or-string))))
-
-(defun read (class-designator stream-or-string &optional (eof-error-p t) eof)
-  (let ((input (make-input :stream (ensure-stream stream-or-string))))
-    (skip-whitespace input)
-    (if (eql :eof (p input))
-      (if eof-error-p
-        (error 'end-of-file)
-        eof)
-      (destructuring-bind (class &optional contained)
-          (canonicalize-class-designator class-designator)
-        (read% class contained input)))))
-
-(defun print (object &optional (stream *standard-output*))
-  (let ((*read-default-float-format* 'double-float)
-        (*print-base* 10))
-    (etypecase stream
-      ((or stream (eql t)) (progn (print% object stream)
-                                  (values)))
-      (null (with-output-to-string (s)
-              (print% object s))))))
-
diff -r d093b64cf92c -r d23a34c34dc3 src/mop.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/mop.lisp	Thu Aug 13 22:06:44 2020 -0400
@@ -0,0 +1,215 @@
+(in-package :jarl)
+
+;;;; Object Parsers -----------------------------------------------------------
+(defun lisp-case-to-snake-case (string)
+  "Convert a Lisp-cased string designator `\"FOO-BAR\"` into snake cased `\"foo_bar\"`."
+  (substitute #\_ #\- (string-downcase string)))
+
+(defclass json-class (standard-class)
+  ((slot-name-to-json-name :accessor slot-name-to-json-name
+                           :initarg :slot-name-to-json-name
+                           :initform 'lisp-case-to-snake-case)
+   (unknown-slots :accessor unknown-slots
+                  :initarg :unknown-slots
+                  :initform :discard)
+   (name-initarg-map :accessor name-initarg-map)
+   (slot-name-alist :accessor slot-name-alist)))
+
+(defmethod c2mop:validate-superclass ((class json-class) (superclass standard-class))
+  t)
+
+
+(defclass json-direct-slot-definition (c2mop:standard-direct-slot-definition)
+  ((json-class :initarg :json :accessor json-class)
+   (json-name :initarg :json/name :accessor json-name)))
+
+(defclass json-effective-slot-definition (c2mop:standard-effective-slot-definition)
+  ((json-class :initarg :json :accessor json-class)
+   (json-name :initarg :json/name :accessor json-name)
+   (json-initarg :accessor json-initarg)))
+
+(defmethod c2mop:direct-slot-definition-class ((class json-class) &rest initargs)
+  (if (getf initargs :json)
+    (find-class 'json-direct-slot-definition)
+    (call-next-method)))
+
+(defvar *effective-slot-definition-class* nil)
+
+(defmethod c2mop:effective-slot-definition-class ((class json-class) &rest initargs)
+  (declare (ignore initargs))
+  ;; I'm not sure why we need to use this hack here, but for some reason
+  ;; initargs doesn't contain the slot options like :json and :json/name here
+  ;; like it does in direct-slot-definition-class.  So we need another way to
+  ;; know which class to use here.
+  (or *effective-slot-definition-class* (call-next-method)))
+
+(defmethod c2mop:compute-effective-slot-definition ((class json-class) name direct-slots)
+  (if (not (some (lambda (dslot)
+                   (typep dslot 'json-direct-slot-definition))
+                 direct-slots))
+    (call-next-method)
+    (let* ((*effective-slot-definition-class* (find-class 'json-effective-slot-definition))
+           (eslot (call-next-method))
+           (dslot (first direct-slots)) ; todo be smarter about coalescing these
+           (initarg (gensym (format nil "json-initarg-~A" name)))) ; todo nicer name
+      (setf (json-name eslot) (if (slot-boundp dslot 'json-name)
+                                (json-name dslot)
+                                (funcall (slot-name-to-json-name class) name)) ; todo make this less shitty
+            (json-class eslot) (if (slot-boundp dslot 'json-class)
+                                 (canonicalize-class-designator (json-class dslot))
+                                 '(t))
+            (json-initarg eslot) initarg) ; todo nicer name
+      (push initarg (c2mop:slot-definition-initargs eslot))
+      eslot)))
+
+
+(defun json-slots (class)
+  (remove-if-not (lambda (slot) (typep slot 'json-effective-slot-definition))
+                 (c2mop:class-slots class)))
+
+(defun make-name-initarg-map (class)
+  "Return a name/initarg map for the JSON slots of `class`.
+
+  The result will be a hash table of `{name: (initarg class contained-class)}`.
+
+  "
+  (let* ((slots (json-slots class))
+         (result (make-hash-table :test #'equal :size (length slots))))
+    (dolist (slot slots)
+      (destructuring-bind (c &optional cc) (json-class slot)
+        (setf (gethash (json-name slot) result)
+              (list (json-initarg slot) c cc))))
+    result))
+
+(defun make-slot-name-alist (class)
+  (mapcar (lambda (slot)
+            (cons (c2mop:slot-definition-name slot)
+                  (json-name slot)))
+          (json-slots class)))
+
+(defmethod shared-initialize ((class json-class) slot-names
+                              &rest initargs
+                              &key slot-name-to-json-name unknown-slots
+                              &allow-other-keys)
+  (apply #'call-next-method class slot-names
+         (append
+           (when slot-name-to-json-name ; todo assert length = 1
+             (list :slot-name-to-json-name (first slot-name-to-json-name)))
+           (when unknown-slots ; todo assert length = 1
+             (list :unknown-slots (first unknown-slots)))
+           initargs)))
+
+(defmethod c2mop:finalize-inheritance :after ((class json-class))
+  (setf (name-initarg-map class) (make-name-initarg-map class)
+        (slot-name-alist class) (make-slot-name-alist class)))
+
+
+;;;; Read ---------------------------------------------------------------------
+(defun parse-json-class (class-name class input)
+  (let ((ch (r input)))
+    (unless (eql ch #\{)
+      (e class-name input "expected ~S but got ~S" #\{ ch)))
+  (skip-whitespace input)
+  (if (eql (p input) #\})
+    (progn
+      (r input)
+      (make-instance class))
+    (loop
+      :with unknown = (unknown-slots class)
+      :with map = (name-initarg-map class)
+      :with init = (list)
+      :for name = (read% 'string nil input)
+      :for sep = (parse-kv-separator class-name input)
+      :for (initarg c cc) = (gethash name map)
+      :do (progn
+            (if (null initarg)
+              (ecase unknown
+                (:discard (read% t nil input))
+                (:error (e class-name input "got unknown object attribute ~S" name)))
+              (progn
+                (push (read% c cc input) init)
+                (push initarg init)))
+            (skip-whitespace input)
+            (let ((ch (r input)))
+              (case ch
+                (#\} (loop-finish))
+                (#\, (skip-whitespace input))
+                (t (e class-name input "expected ~S or ~S but got ~S." #\} #\, ch)))))
+      :finally (return (apply #'make-instance class init)))))
+
+(defmethod read% ((class-name symbol) (contained-class null) (input input))
+  (let ((class (find-class class-name nil)))
+    (typecase class
+      (json-class
+        (c2mop:ensure-finalized class)
+        (parse-json-class class-name class input))
+      (null (error "Cannot find class ~S to parse JSON into." class-name))
+      (t (error "Cannot parse JSON into class ~S because that class is not a ~S"
+                class-name 'json-class)))))
+
+
+;;;; Printing -----------------------------------------------------------------
+(defmethod print% (thing stream)
+  (let ((class (class-of thing)))
+    (if (typep class 'json-class)
+      (progn
+        (write-char #\{ stream)
+        (loop :with first = t
+              :for (slot . name) :in (slot-name-alist class)
+              :when (slot-boundp thing slot)
+              :do (progn (if first
+                           (setf first nil)
+                           (write-char #\, stream))
+                         (print% name stream)
+                         (write-char #\: stream)
+                         (print% (slot-value thing slot) stream)))
+        (write-char #\} stream))
+      (error "Don't know how to print object ~S of class ~S as JSON." thing class))))
+
+
+;;;; API ----------------------------------------------------------------------
+(defun canonicalize-class-designator (class-designator)
+  (flet ((fail () (error "Malformed class designator ~S" class-designator)))
+    (etypecase class-designator
+      (cons (destructuring-bind (head a &optional (b nil b?)) class-designator
+              (ecase head
+                ; (vector foo)
+                ((hash-table vector)
+                 (progn (when b? (fail))
+                        (list head (canonicalize-class-designator a))))
+                ; (or null foo)
+                (or (progn
+                      (unless b? (fail)) ; must have a second option
+                      (when (eql 'null b) (rotatef a b)) ; sort a/b
+                      (unless (eql 'null a) (fail)) ; no arbitrary ors
+                      (list 'nullable (canonicalize-class-designator b)))))))
+      (symbol (case class-designator
+                (vector '(vector (t)))
+                (hash-table '(hash-table (t)))
+                (t (list class-designator)))))))
+
+(defun ensure-stream (stream-or-string)
+  (etypecase stream-or-string
+    (stream stream-or-string)
+    (string (make-string-input-stream stream-or-string))))
+
+(defun read (class-designator stream-or-string &optional (eof-error-p t) eof)
+  (let ((input (make-input :stream (ensure-stream stream-or-string))))
+    (skip-whitespace input)
+    (if (eql :eof (p input))
+      (if eof-error-p
+        (error 'end-of-file)
+        eof)
+      (destructuring-bind (class &optional contained)
+          (canonicalize-class-designator class-designator)
+        (read% class contained input)))))
+
+(defun print (object &optional (stream *standard-output*))
+  (let ((*read-default-float-format* 'double-float)
+        (*print-base* 10))
+    (etypecase stream
+      ((or stream (eql t)) (progn (print% object stream)
+                                  (values)))
+      (null (with-output-to-string (s)
+              (print% object s))))))
+