--- a/.TODO.done Tue Dec 01 00:37:06 2020 -0500
+++ b/.TODO.done Tue Dec 01 01:18:18 2020 -0500
@@ -12,3 +12,4 @@
Test reading explicit types, not just t. | id:d2def699c46f12c02d49c01c869fc9b927bda72d
Fix `Undefined function (SETF CCL:SLOT-DEFINITION-INITARGS)` in CCL | id:e834dd6749849e10669a643019337533e87f5cdd
Add basic unit tests | id:ed372a368fce619ce8230043635de5258212f607
+Remove wrappers for now. | id:fb86c2b6a6322ef04df60f74e3b3fefffc1c2d96
--- a/TODO Tue Dec 01 00:37:06 2020 -0500
+++ b/TODO Tue Dec 01 01:18:18 2020 -0500
@@ -3,4 +3,3 @@
Fuzz against other JSON implementations | id:ccfe488e219c9454228a0510c61f8c59946e5875
Ensure slots are coalesced properly. | id:d800e6516a5bf5f8ce843f442956078e7a1b672e
Add more MOP-based tests (including errors). | id:df727baeb41bad02c7d79b92f98c24c8a28ca772
-Remove wrappers for now. | id:fb86c2b6a6322ef04df60f74e3b3fefffc1c2d96
--- a/src/basic.lisp Tue Dec 01 00:37:06 2020 -0500
+++ b/src/basic.lisp Tue Dec 01 01:18:18 2020 -0500
@@ -143,7 +143,7 @@
(defun requires-escape-p (character)
(or (char= #\" character)
(char= #\\ character)
- (<= (char-code character) #x1F)))
+ (<= (char-code character) #x1F))) ; TODO: Technically this isn't portable.
(defun parse-literal (input literal remaining-characters)
(loop :for next :across remaining-characters
--- a/src/package.lisp Tue Dec 01 00:37:06 2020 -0500
+++ b/src/package.lisp Tue Dec 01 01:18:18 2020 -0500
@@ -9,4 +9,7 @@
:json-class
:lisp-case-to-snake-case
+ :set-wrapper
+ :remove-wrapper
+
))
--- a/src/wrappers.lisp Tue Dec 01 00:37:06 2020 -0500
+++ b/src/wrappers.lisp Tue Dec 01 01:18:18 2020 -0500
@@ -1,7 +1,6 @@
(in-package :jarl)
-(defvar *global-wrappers* (make-hash-table :test 'eq))
-(defvar *wrappers* (list))
+(defvar *wrappers* (make-hash-table :test 'eq))
(defun make-wrapper (underlying-class-designator read print)
(list (canonicalize-class-designator underlying-class-designator) read print))
@@ -11,33 +10,15 @@
(defun wrapper-read (wrapper) (second wrapper))
(defun wrapper-print (wrapper) (third wrapper))
-(defun set-global-wrapper (class underlying-class-designator &key read print)
+(defun set-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*)
+ (setf (gethash class *wrappers*)
(make-wrapper underlying-class-designator read print)))
-(defun remove-global-wrapper (class)
+(defun remove-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))))
+ (remhash class *wrappers*))
(defun read-with-wrapper (wrapper input)
(funcall (wrapper-read wrapper)
@@ -46,6 +27,9 @@
(defun print-with-wrapper (wrapper thing stream indent)
(print% (funcall (wrapper-print wrapper) thing) stream indent))
+(defun find-wrapper (class-name)
+ (gethash class-name *wrappers*))
+
(defmethod print% (thing stream indent)
(let* ((class (class-of thing))
(wrapper (find-wrapper (class-name class))))
--- a/test/tests.lisp Tue Dec 01 00:37:06 2020 -0500
+++ b/test/tests.lisp Tue Dec 01 01:18:18 2020 -0500
@@ -480,12 +480,12 @@
(defclass w ()
((names :type list :initarg :names)))
-(define-test global-wrappers
- (jarl::set-global-wrapper
+(define-test wrappers
+ (jarl::set-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
+ (jarl::set-wrapper
'uuid:uuid 'string
:read 'uuid:make-uuid-from-string
:print 'princ-to-string)
@@ -503,63 +503,7 @@
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)))))
+ (map nil 'jarl::remove-wrapper '(w uuid:uuid))))
;;;; Allow Print/Read ---------------------------------------------------------