--- a/.TODO.done Fri Aug 21 21:48:29 2020 -0400
+++ b/.TODO.done Tue Aug 25 00:08:28 2020 -0400
@@ -1,5 +1,6 @@
Add read/print disabling mechanism | id:1268bf0b10c13aec23aafbd8f5e236db1e485fa5
Fix :allow-print and :allow-read to set t when removing them during class redef. | id:21cce1bed829a138de33b33e3ad3219f7888be04
+Add basic wrapper definition | id:861f048b3b69079dedf8779be1cb73c05e6fc732
Optimize discarding | id:93105ef9d21d33bfb10c67fcac36bc60434d3fb4
Add after-read and before-print functions | id:9f982ca45b68d644159e0c64f0dc1b185f72a2f8
Add opaque-json type | id:a1a380eb9782d088693dfb75402b99c2b30cf039
--- a/TODO Fri Aug 21 21:48:29 2020 -0400
+++ b/TODO Tue Aug 25 00:08:28 2020 -0400
@@ -1,5 +1,4 @@
Clean up error hierarchy | id:3d3efa4af649474151661a9d294080ab24e22ff7
-Add basic wrapper definition | id:861f048b3b69079dedf8779be1cb73c05e6fc732
Add extra key preservation | id:cfb63b37d87893083fc98477ec3d488fb909a984
Test reading explicit types, not just t. | id:d2def699c46f12c02d49c01c869fc9b927bda72d
Add more MOP-based tests (including errors). | id:df727baeb41bad02c7d79b92f98c24c8a28ca772
--- a/jarl.asd Fri Aug 21 21:48:29 2020 -0400
+++ b/jarl.asd Tue Aug 25 00:08:28 2020 -0400
@@ -15,6 +15,7 @@
:components ((:file "package")
(:file "basic")
(:file "opaque")
+ (:file "wrappers")
(:file "mop")))))
@@ -24,7 +25,7 @@
:author "Steve Losh <steve@stevelosh.com>"
:license "MIT"
- :depends-on (:jarl :1am :alexandria :yason :chancery)
+ :depends-on (:jarl :1am :alexandria :yason :chancery :uuid)
:serial t
:components ((:module "test"
--- a/src/mop.lisp Fri Aug 21 21:48:29 2020 -0400
+++ b/src/mop.lisp Tue Aug 25 00:08:28 2020 -0400
@@ -174,38 +174,45 @@
: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)))))
+ (let ((wrapper (find-wrapper class-name)))
+ (if wrapper
+ (read-with-wrapper wrapper 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 render-json-class (class thing stream)
+ (write-char #\{ stream)
+ (loop :with first = t
+ :for (slot name before-print) :in (slot-alist class)
+ :when (slot-boundp thing slot)
+ :do (let ((value (slot-value thing slot)))
+ (if first
+ (setf first nil)
+ (write-char #\, stream))
+ (print% name stream)
+ (write-char #\: stream)
+ (print% (if before-print
+ (funcall before-print value)
+ value)
+ stream)))
+ (write-char #\} stream))
+
(defmethod print% (thing stream)
- (let ((class (class-of thing)))
+ (let* ((class (class-of thing))
+ (wrapper (find-wrapper (class-name class))))
(cond
+ (wrapper (print-with-wrapper wrapper thing stream))
((not (typep class 'json-class))
(error "Don't know how to print object ~S of class ~S as JSON." thing class))
((not (allow-print class))
(error "Class ~S does not allow printing." class))
- (t
- (write-char #\{ stream)
- (loop :with first = t
- :for (slot name before-print) :in (slot-alist class)
- :when (slot-boundp thing slot)
- :do (let ((value (slot-value thing slot)))
- (if first
- (setf first nil)
- (write-char #\, stream))
- (print% name stream)
- (write-char #\: stream)
- (print% (if before-print
- (funcall before-print value)
- value)
- stream)))
- (write-char #\} stream)))))
+ (t (render-json-class class thing stream)))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/wrappers.lisp Tue Aug 25 00:08:28 2020 -0400
@@ -0,0 +1,47 @@
+(in-package :jarl)
+
+(defvar *global-wrappers* (make-hash-table :test 'eq))
+(defvar *wrappers* (list))
+
+(defun make-wrapper (underlying-class-designator read print)
+ (list (canonicalize-class-designator underlying-class-designator) read print))
+
+(defun wrapper-c (wrapper) (first (first wrapper)))
+(defun wrapper-cc (wrapper) (second (first wrapper)))
+(defun wrapper-read (wrapper) (second wrapper))
+(defun wrapper-print (wrapper) (third wrapper))
+
+(defun set-global-wrapper (class underlying-class-designator &key read print)
+ (check-type class symbol)
+ ;; TODO Sanity check that there's not alread a json-class here? Or mabye not.
+ (setf (gethash class *global-wrappers*)
+ (make-wrapper underlying-class-designator read print)))
+
+(defun remove-global-wrapper (class)
+ (check-type class symbol)
+ (remhash class *global-wrappers*))
+
+(defun find-wrapper (class)
+ (dolist (wrappers *wrappers* (gethash class *global-wrappers*))
+ (let ((wrapper (getf wrappers class)))
+ (when wrapper
+ (return wrapper)))))
+
+(defmacro with-wrappers (bindings &body body)
+ (flet ((binding-to-plist-entry (binding)
+ (destructuring-bind (class underlying-class-designator &key read print)
+ binding
+ (check-type class symbol)
+ (list `',class `(make-wrapper ,underlying-class-designator ,read ,print)))))
+ (let ((wrappers (mapcan #'binding-to-plist-entry bindings)))
+ ;; todo optimize when everything is constant
+ `(let (,@(when wrappers
+ (list `(*wrappers* (cons (list ,@wrappers) *wrappers*)))))
+ ,@body))))
+
+(defun read-with-wrapper (wrapper input)
+ (funcall (wrapper-read wrapper)
+ (read% (wrapper-c wrapper) (wrapper-cc wrapper) input)))
+
+(defun print-with-wrapper (wrapper thing stream)
+ (print% (funcall (wrapper-print wrapper) thing) stream))
--- a/test/tests.lisp Fri Aug 21 21:48:29 2020 -0400
+++ b/test/tests.lisp Tue Aug 25 00:08:28 2020 -0400
@@ -384,6 +384,92 @@
:foos (v (foo :i 10) (foo :n nil :v (v)))))
+;;;; Wrappers -----------------------------------------------------------------
+(defclass w ()
+ ((names :type list :initarg :names)))
+
+(define-test global-wrappers
+ (jarl::set-global-wrapper
+ 'w '(vector string)
+ :read (lambda (strings) (make-instance 'w :names (coerce strings 'list)))
+ :print (lambda (w) (coerce (slot-value w 'names) 'vector)))
+ (jarl::set-global-wrapper
+ 'uuid:uuid 'string
+ :read 'uuid:make-uuid-from-string
+ :print 'princ-to-string)
+ (unwind-protect
+ (progn
+ (is (equal `("a" "b" "c")
+ (slot-value (jarl:read 'w (json "['a', 'b', 'c']")) 'names)))
+ (is (uuid:uuid=
+ (uuid:make-uuid-from-string "733DB032-C573-4EAA-AF6B-0FF7C99302D2")
+ (jarl:read 'uuid:uuid (json "'733db032-c573-4eaa-af6b-0ff7c99302d2'"))))
+ (is (string= (json "'733DB032-C573-4EAA-AF6B-0FF7C99302D2'")
+ (string-upcase
+ (jarl:print
+ (uuid:make-uuid-from-string "733DB032-C573-4EAA-AF6B-0FF7C99302D2")
+ nil))))
+ (is (string= (json "['meow','wow']")
+ (jarl:print (make-instance 'w :names '("meow" "wow")) nil))))
+ (map nil 'jarl::remove-global-wrapper '(w uuid:uuid))))
+
+(define-test with-wrappers
+ (jarl::with-wrappers
+ ((uuid:uuid 'string :read 'uuid:make-uuid-from-string :print 'princ-to-string)
+ (w '(vector string)
+ :read (lambda (strings) (make-instance 'w :names (coerce strings 'list)))
+ :print (lambda (w) (coerce (slot-value w 'names) 'vector))))
+ (is (equal `("a" "b" "c")
+ (slot-value (jarl:read 'w (json "['a', 'b', 'c']")) 'names)))
+ (is (uuid:uuid=
+ (uuid:make-uuid-from-string "733DB032-C573-4EAA-AF6B-0FF7C99302D2")
+ (jarl:read 'uuid:uuid (json "'733db032-c573-4eaa-af6b-0ff7c99302d2'"))))
+ (is (string= (json "'733DB032-C573-4EAA-AF6B-0FF7C99302D2'")
+ (string-upcase
+ (jarl:print
+ (uuid:make-uuid-from-string "733DB032-C573-4EAA-AF6B-0FF7C99302D2")
+ nil))))
+ (is (string= (json "['meow','wow']")
+ (jarl:print (make-instance 'w :names '("meow" "wow")) nil)))))
+
+
+(defclass w2 ()
+ ((name :initarg :name)))
+
+(defun wrap1 (string)
+ (make-instance 'w2 :name (coerce string 'list)))
+
+(defun wrap2 (string)
+ (make-instance 'w2 :name (reverse string)))
+
+(defun unwrap1 (w2)
+ (coerce (slot-value w2 'name) 'string))
+
+(defun unwrap2 (w2)
+ (reverse (slot-value w2 'name)))
+
+(define-test nested-wrappers
+ (jarl::with-wrappers ((w2 'string :read #'wrap1 :print #'unwrap1))
+ (is (equal '(#\a #\b #\c)
+ (slot-value (jarl:read 'w2 (json "'abc'")) 'name)))
+ (is (equal (json "'abc'")
+ (jarl:print (make-instance 'w2 :name '(#\a #\b #\c)) nil)))
+ (jarl::with-wrappers ((w2 'string :read #'wrap2 :print #'unwrap2))
+ (is (equal "cba"
+ (slot-value (jarl:read 'w2 (json "'abc'")) 'name)))
+ (is (equal (json "'abc'")
+ (jarl:print (make-instance 'w2 :name "cba") nil))))))
+
+(define-test half-wrappers
+ (jarl::with-wrappers ((w2 'string :read #'wrap1))
+ (is (equal '(#\a #\b #\c) (slot-value (jarl:read 'w2 (json "'abc'")) 'name)))
+ (signals error (jarl:print (make-instance 'w2 :name '(#\a #\b #\c)) nil)))
+ (jarl::with-wrappers ((w2 'string :print #'unwrap1))
+ (signals error (jarl:read 'w2 (json "'abc'")))
+ (is (equal (json "'abc'")
+ (jarl:print (make-instance 'w2 :name '(#\a #\b #\c)) nil)))))
+
+
;;;; Allow Print/Read ---------------------------------------------------------
(defclass apr ()
((id :json number :initarg :id))
@@ -526,8 +612,8 @@
(defgeneric to-jarl (from o)
- (:method (from o) o)
- (:method (from (o string)) o))
+ (:method (from o) (declare (ignore from)) o)
+ (:method (from (o string)) (declare (ignore from)) o))
(defmethod to-jarl (from (o vector))
(map 'vector (alexandria:curry #'to-jarl from) o))
@@ -537,8 +623,8 @@
(defgeneric from-jarl (to o)
- (:method (to o) o)
- (:method (to (o string)) o))
+ (:method (to o) (declare (ignore to)) o)
+ (:method (to (o string)) (declare (ignore to)) o))
(defmethod from-jarl (to (o vector))
(map 'vector (alexandria:curry #'from-jarl to) o))