# HG changeset patch # User Steve Losh # Date 1598328508 14400 # Node ID bd7953d25dbd29cbc59ff49275df982cfb60b788 # Parent 64303dece1779cb2c167380795e24928dadce320 Add basic wrapper functionality Need to clean up the API for this at some point. diff -r 64303dece177 -r bd7953d25dbd .TODO.done --- 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 diff -r 64303dece177 -r bd7953d25dbd TODO --- 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 diff -r 64303dece177 -r bd7953d25dbd jarl.asd --- 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 " :license "MIT" - :depends-on (:jarl :1am :alexandria :yason :chancery) + :depends-on (:jarl :1am :alexandria :yason :chancery :uuid) :serial t :components ((:module "test" diff -r 64303dece177 -r bd7953d25dbd src/mop.lisp --- 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))))) diff -r 64303dece177 -r bd7953d25dbd src/wrappers.lisp --- /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)) diff -r 64303dece177 -r bd7953d25dbd test/tests.lisp --- 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))