bd7953d25dbd

Add basic wrapper functionality

Need to clean up the API for this at some point.
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Tue, 25 Aug 2020 00:08:28 -0400
parents 64303dece177
children 6d74e7ab0fc0
branches/tags (none)
files .TODO.done TODO jarl.asd src/mop.lisp src/wrappers.lisp test/tests.lisp

Changes

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