src/wrappers.lisp @ 11d14162a533

(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 indent)
  (print% (funcall (wrapper-print wrapper) thing) stream indent))

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