--- a/src/main.lisp Sat Jul 18 13:53:29 2020 -0400
+++ b/src/main.lisp Wed Jul 22 20:17:30 2020 -0400
@@ -1,16 +1,5 @@
(in-package :jarl)
-;;;; Notes --------------------------------------------------------------------
-;;;
-;;; Reading is implemented as a generic function read% of three arguments:
-;;;
-;;; 1. The name of the class to read.
-;;; 2. Any contained class designator, for things like (vector foo) or (nullable foo).
-;;; 3. The input struct.
-;;;
-;;; Printing is just a simple generic function of the object and a stream.
-
-
;;;; Input --------------------------------------------------------------------
(defstruct input
(stream nil :type stream)
@@ -34,16 +23,19 @@
;;;; 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 at line ~D column ~D: ~A"
+ (format stream "Error parsing JSON~@[ into ~S~] at line ~D column ~D: ~A"
+ (class-designator c)
(line c)
(column c)
(message c)))))
-(defun e (input format-string &rest args) ; error
+(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)))
@@ -64,15 +56,15 @@
(loop :for next :across remaining-characters
:for char = (r input)
:unless (eql next char)
- :do (e input "Cannot parse literal ~S, expected ~S but got ~S" literal 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 input "Cannot parse \\u escape sequence, got ~S." :eof)
+ (e nil input "cannot parse \\u escape sequence, got ~S" :eof)
(or (digit-char-p ch 16)
- (e input "Cannot parse \\u escape sequence, ~S is not a hexadecimal digit." ch)))))
+ (e nil input "cannot parse \\u escape sequence, ~S is not a hexadecimal digit" ch)))))
(defun parse-escaped-character (input)
(let ((ch (r input)))
@@ -93,7 +85,7 @@
(* b (expt 16 2))
(* c (expt 16 1))
(* d (expt 16 0))))))
- (t (e input "Cannot parse string, bad escape sequence ~S ~S." #\\ ch)))))
+ (t (e nil input "bad escape sequence ~S ~S" #\\ ch)))))
(defun parse-int (input &optional (allow-leading-zero t))
(loop :with i = 0
@@ -106,11 +98,11 @@
(zerop n) ; leading
(zerop digit) ; zero
(digit-char-p (p input #\e))) ; but not a bare zero
- (e input "Cannot parse integer, bad leading zero."))
+ (e nil input "bad leading zero"))
(incf n)
(setf i (+ (* 10 i) digit)))
:finally (if (zerop n)
- (e input "Expected an integer.")
+ (e nil input "expected an integer")
(return (values i n)))))
(defun parse-exponent (input)
@@ -154,7 +146,7 @@
(skip-whitespace input)
(let ((ch (r input)))
(unless (eql #\: ch)
- (e input "Cannot parse ~S, expected ~S but got ~S" class #\: ch))
+ (e class input "expected separator ~S but got ~S" #\: ch))
(skip-whitespace input)))
(defun json-type-of (object)
@@ -168,35 +160,30 @@
(defgeneric read% (class contained-class input))
-(defmacro defreader (class (input &optional contained-class) &body body)
- `(defmethod read% ((class (eql ',class)) ,(or contained-class 'contained-class) (,input input))
- (declare (ignore class ,@(unless contained-class '(contained-class))))
- ,@body))
-
-(defreader keyword (input)
+(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 input "Cannot parse keyword, expected ~S or ~S but got ~S." #\t #\f ch)))))
+ (t (e 'keyword input "expected ~S or ~S but got ~S" #\t #\f ch)))))
-(defreader null (input)
+(defmethod read% ((class (eql 'null)) contained-class input)
(let ((ch (r input)))
(if (eql ch #\n)
(parse-literal input nil "ull")
- (e input "Cannot parse null, expected ~S but got ~S." #\n ch))))
+ (e 'null input "expected ~S but got ~S" #\n ch))))
-(defreader vector (input contained)
+(defmethod read% ((class (eql 'vector)) contained-class input)
(let ((ch (r input)))
(unless (eql ch #\[)
- (e input "Cannot parse vector, expected ~S but got ~S." #\[ 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 cc) = contained
+ :with (c cc) = contained-class
:collect (read% c cc input)
:do (progn
(skip-whitespace input)
@@ -204,32 +191,32 @@
(case ch
(#\] (loop-finish))
(#\, (skip-whitespace input))
- (t (e input "Cannot parse vector, expected ~S or ~S but got ~S." #\] #\, ch))))))
+ (t (e 'vector input "expected ~S or ~S but got ~S." #\] #\, ch))))))
'vector)))
-(defreader string (input)
+(defmethod read% ((class (eql 'string)) contained-class input)
(let ((ch (r input)))
(unless (eql ch #\")
- (e input "Cannot parse string, expected opening ~S but got ~S." #\" ch)))
+ (e 'string input "expected opening ~S but got ~S" #\" ch)))
(with-output-to-string (s)
(loop :for ch = (r input)
:collect (cond
- ((eql ch :eof) (e input "Cannot parse string, got ~S." :eof))
+ ((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 input "Cannot parse string, bad unescaped character ~S." ch))
+ ((requires-escape-p ch) (e 'string input "bad unescaped character ~S" ch))
(t (write-char ch s))))))
-(defreader hash-table (input contained)
+(defmethod read% ((class (eql 'hash-table)) contained-class input)
(let ((ch (r input)))
(unless (eql ch #\{)
- (e input "Cannot parse hash table, expected ~S but got ~S." #\{ 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 cc) = contained
+ :with (c cc) = contained-class
:for name = (read% 'string nil input)
:for sep = (parse-kv-separator 'hash-table input)
:for value = (progn (skip-whitespace input)
@@ -241,26 +228,26 @@
(case ch
(#\} (loop-finish))
(#\, (skip-whitespace input))
- (t (e input "Cannot parse hash table, expected ~S or ~S but got ~S." #\} #\, ch)))))))
+ (t (e 'hash-table input "expected ~S or ~S but got ~S" #\} #\, ch)))))))
result))
-(defreader number (input)
+(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 input "Cannot parse number, expected digit or ~S but got ~S." #\- ch)))
+ (e 'number input "expected digit or ~S but got ~S" #\- ch)))
(parse-number input))
-(defreader nullable (input contained)
+(defmethod read% ((class (eql 'nullable)) contained-class input)
(case (p input)
- (:eof (e "Cannot parse ~S, got ~S." `(or null ,input) :eof))
+ (:eof (e `(or null ,input) input "got ~S" :eof))
(#\n (read% 'null nil input))
- (t (read% (first contained) (second contained) input))))
+ (t (read% (first contained-class) (second contained-class) input))))
-(defreader t (input)
+(defmethod read% ((class (eql t)) contained-class input)
(skip-whitespace input)
(ecase (p input)
- (:eof (r input) (e input "Cannot parse JSON, got ~S." :eof))
+ (:eof (r input) (e 't input "got ~S" :eof))
((#\t #\f) (read% 'keyword nil input))
(#\n (read% 'null nil input))
(#\" (read% 'string nil input))
@@ -277,7 +264,12 @@
(unknown-slots :accessor unknown-slots
:initarg :unknown-slots
:initform :discard)
- (name-initarg-map :accessor name-initarg-map)))
+ (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-name :initarg :json/name :accessor json-name)
@@ -298,14 +290,16 @@
(defmethod c2mop:compute-effective-slot-definition ((class json-class) name direct-slots)
(let ((eslot (call-next-method))
- (dslot (first direct-slots))) ; todo be smarter about coalescing these
+ (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) (gensym (format nil "json-initarg-~A" name))) ; todo nicer name
+ (json-initarg eslot) initarg) ; todo nicer name
+ (push initarg (c2mop:slot-definition-initargs eslot))
eslot))
@@ -317,146 +311,45 @@
(let* ((slots (json-slots class))
(result (make-hash-table :test #'equal :size (length slots))))
(dolist (slot slots)
- (setf (gethash (json-name slot) result)
- (json-initarg slot)))
+ (destructuring-bind (c &optional cc) (json-class slot)
+ (setf (gethash (json-name slot) result)
+ (list (json-initarg slot) c cc))))
result))
-(defmethod shared-initialize ((instance json-class) slot-names
+(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 instance slot-names
+ (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))
- instance)
-
-(defun build-reader-lambda (class)
- ;; todo consider whether compiling a separate method for every class is REALLY
- ;; worth it, or whether we should just do things the reflecty way like
- ;; everyone else in the world.
- (let ((slots (c2mop:class-slots class))
- (class-name (class-name class)))
- `(lambda (class contained-class input)
- (let ((result (make-instance ',(class-name class))))
- (let ((ch (r input)))
- (unless (eql ch #\{)
- (e input "Cannot parse ~S, expected ~S but got ~S." ',class-name #\{ ch)))
- (skip-whitespace input)
- (if (eql (p input) #\})
- (r input)
- (loop
- :for name = (read% 'string nil input)
- :for sep = (parse-kv-separator ',class-name input)
- :do (progn
- (cond
- ,@(loop
- :for slot :in slots
- :for name = (json-name slot)
- :for (c cc) = (json-class slot)
- :collect `((string= name ,name)
- (setf (slot-value result ',(c2mop:slot-definition-name slot))
- (read% ',c ',cc input)))) ; todo types
- (t ,(ecase (unknown-slots class)
- (:discard `(read% t nil input)) ; todo: handle discarded keys, skip more efficiently
- (:error `(e input "Cannot parse ~S, got unknown object attribute ~S." ',class-name name)))))
- (skip-whitespace input)
- (let ((ch (r input)))
- (case ch
- (#\} (loop-finish))
- (#\, (skip-whitespace input))
- (t (e input "Cannot parse ~S, expected ~S or ~S but got ~S." ',class-name #\} #\, ch)))))))
- result))))
-
-(defun make-read%-method (class)
- (multiple-value-bind (lambda-form initargs)
- (c2mop:make-method-lambda #'read%
- (first (c2mop:generic-function-methods #'read%))
- (build-reader-lambda class)
- nil)
- (apply #'make-instance 'standard-method
- :lambda-list '(class contained-class input)
- :specializers (list (c2mop:intern-eql-specializer (class-name class))
- (find-class t)
- (find-class 'input))
- :function (compile nil lambda-form)
initargs)))
-
(defmethod c2mop:finalize-inheritance :after ((class json-class))
- (setf (name-initarg-map class) (make-name-initarg-map class))
- nil
- ; todo: we may need to do things a bit differently here. I think the MOP spec
- ; says that the class doesn't need to be finalized until we're ready to
- ; allocate the first instance. but we need the read% method to be ready
- ; *before* that, because that method is what allocates the instance! So we
- ; might need to do something like making the default method on read% allocate
- ; a result instance and pass it to a call on a separate method read%%. Sigh.
- #+no(add-method #'read% (make-read%-method class)))
-
-(defmethod c2mop:validate-superclass ((class json-class) (superclass standard-class))
- t)
-
-
-(defclass post ()
- ((id :json/class number)
- (title :json/class string)
- (body :json/name "pingus")
- (author :json/class user))
- (:metaclass json-class)
- (:unknown-slots :discard))
-
-(defclass user ()
- ((id :type integer)
- (name :type string)
- (friends :type (vector integer)))
- (:metaclass json-class))
-
+ (setf (name-initarg-map class) (make-name-initarg-map class)
+ (slot-name-alist class) (make-slot-name-alist class)))
-;; (make-instance 'post)
-
-;; (build-reader-lambda (find-class 'post))
-
-;; (find-class 'user)
-(find-class 'post)
-
-;; (make-instance 'post)
-
-;; (setf (find-class 'post) nil (find-class 'user) nil)
-
-;; (read '(vector post) (substitute #\" #\' "[{
-;; 'id': 69,
-;; 'pingus': 'oh my christ, it works!',
-;; 'author': {
-;; 'id': 101,
-;; 'name': 'sjl'
-;; },
-;; 'wat': 1
-;; }, {
-;; 'id': 420,
-;; 'title': 'hello, world!',
-;; 'pingus': 'incredible',
-;; 'author': {
-;; 'id': 101,
-;; 'name': 'sjl',
-;; 'friends': [1,2,3]
-;; }
-;; }]"))
(defun parse-json-class (class-name class input)
(let ((ch (r input)))
(unless (eql ch #\{)
- (e input "Cannot parse ~S, expected ~S but got ~S." class-name #\{ 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 = (first (unknown-slots class))
+ :with unknown = (unknown-slots class)
:with map = (name-initarg-map class)
:with init = (list)
:for name = (read% 'string nil input)
@@ -466,7 +359,7 @@
(if (null initarg)
(ecase unknown
(:discard (read% t nil input))
- (:error (e input "Cannot parse ~S, got unknown object attribute ~S." class-name name)))
+ (:error (e class-name input "got unknown object attribute ~S" name)))
(progn
(push (read% c cc input) init)
(push initarg init)))
@@ -475,15 +368,18 @@
(case ch
(#\} (loop-finish))
(#\, (skip-whitespace input))
- (t (e input "Cannot parse ~S, expected ~S or ~S but got ~S." class-name #\} #\, ch)))))
+ (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 (parse-json-class class-name class input))
+ (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 it is not a ~S" class-name 'json-class)))))
+ (t (error "Cannot parse JSON into class ~S because that class is not a ~S"
+ class-name 'json-class)))))
;;;; Printing -----------------------------------------------------------------
@@ -548,15 +444,22 @@
(defmethod print% ((thing (eql :true)) stream)
(write-string "true" stream))
-
-(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))))))
+(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 ----------------------------------------------------------------------
@@ -596,23 +499,55 @@
(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))))))
+
#; Scratch --------------------------------------------------------------------
-(read '1 "[true, null, false, true]")
-
-(canonicalize-class-designator 'keyword)
+(defclass a () ())
+(defclass b () ())
+(defclass c () ())
+(defclass d () ())
-(defclass post ()
- ((title :type string)
- (id :type integer)
- (body :type string))
+(defclass post (a b c)
+ ((id :json/class number)
+ (title :json/class string)
+ (body :json/class string)
+ (author :json/class user)
+ (extra))
+ (:metaclass json-class)
+ (:unknown-slots :discard))
+
+(defclass user ()
+ ((id :json/class number :initarg :id)
+ (name :json/class string)
+ (friends :json/class (vector number)))
(:metaclass json-class))
-(defclass user ()
- ((name :type string)
- (id :type integer)
- (posts :type (vector post)))
- (:metaclass json-class))
+
+(find-class 'user)
+(find-class 'post)
+(find-class 'wat)
+
+(make-instance 'user :id 1)
+(make-instance 'post)
+
+(setf (find-class 'post) nil (find-class 'user) nil)
-(canonicalize-type-designator '(vector keyword))
+(print (read '(vector post) (substitute #\" #\' "[{
+ 'id': 69,
+ 'body': 'oh my christ, it works!',
+ 'author': {
+ 'id': 101,
+ 'name': 'sjl',
+ 'friends': [1,2,3]
+ },
+ 'wat': 1
+ }]")))