src/wrappers.lisp @ 06299969c903 default tip

(in-package :jarl)

(defvar *wrappers* (make-hash-table :test 'eq))

(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-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 *wrappers*)
        (make-wrapper underlying-class-designator read print)))

(defun remove-wrapper (class)
  (check-type class symbol)
  (remhash class *wrappers*))

(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 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))))
    (if wrapper
      (print-with-wrapper wrapper thing stream indent)
      (error "Don't know how to print object ~S of class ~S as JSON, ~
              because it's not a JSON class and doesn't have any wrapper(s)."
             thing class))))