# HG changeset patch # User Steve Losh # Date 1595463450 14400 # Node ID e3c35d5a968110ef373a4285181772b514f0344a # Parent 30f068e0228519d9d6dc3139d8eda529058e5be3 Sketch out the new implementation diff -r 30f068e02285 -r e3c35d5a9681 src/main.lisp --- 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 + }]")))