--- 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
--- /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))))))
+
--- 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))))))
-
--- /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))))))
+