# HG changeset patch # User Steve Losh # Date 1606803498 18000 # Node ID 6d4f34a78d74a63e1f42675384f71ed944e27d75 # Parent 11d14162a533808afc3acde2b7f2b8391061cbc0 Remove local wrappers, for now diff -r 11d14162a533 -r 6d4f34a78d74 .TODO.done --- 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 diff -r 11d14162a533 -r 6d4f34a78d74 TODO --- 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 diff -r 11d14162a533 -r 6d4f34a78d74 src/basic.lisp --- 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 diff -r 11d14162a533 -r 6d4f34a78d74 src/package.lisp --- 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 + )) diff -r 11d14162a533 -r 6d4f34a78d74 src/wrappers.lisp --- 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)))) diff -r 11d14162a533 -r 6d4f34a78d74 test/tests.lisp --- 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 ---------------------------------------------------------