4
\$\begingroup\$

Coming from this question https://stackoverflow.com/questions/58131614/how-to-convert-json-string-into-complex-clos-object-using-cl-json-library I've finally come up with the following solution.

I use cl-json custom handle functionality

  • json::*object-key-handler* to always know the last key (parent slot name) we run through while parsing JSON.
  • json::*beginning-of-object-handler* to push on stack a cons with :

    1. the last key read (which represent the slot name in the parent object)
    2. the type of the parent object we parse, which is either the type of the root object (for first level referenced object) or which is found on the top of the same stack (general case).
      • special case for the root object where last key read is nil. (we then push nil on the stack).
  • json::*end-of-object-handler* to set the json::*prototype* of the class that should be instantiated. I do this by using the stack.

    • if the stack top is nil we need to instantiate the root object
    • else we need to instantiate a class from the type of the slot-definition from the 2 data on the stack (the parent slot class having the specific slot definition name).

I then have defgeneric make-instance-from-json ,so I can still overload that generic Json2CLOS engine depending on the root object to instantiate, without changing the call syntax.

As I'm just beginning with lisp, what are your thoughts on that code (design/implementation) ? ...and yes, I've just noticed while typing the code here that it's not compatible yet with json arrays [] :-/

;; dependencies
;;(ql:quickload :cl-change-case)
;;(ql:quickload :closer-mop)
;;(ql:quickload :cl-json)
(require :cl-change-case)
(require :closer-mop)
(require :cl-json)

(defpackage :json2clos
  (:use :common-lisp)
  (:export #:make-instance-from-json))
(in-package :json2clos)
(defvar *stack-of-object-ref*) ;; holds elements as cons (class-name . slot-symbol)
(defvar *last-json-key-read*)
(defvar *name-of-current-class-being-decoded*)
(defun get-slot-definition (class-symbol json-key)
  "returns a slot-definition from the slot of class-symbol which is infered from using json-key / method symbol"
  (find
   (cl-change-case:param-case json-key)
   (closer-mop:class-direct-slots
    (find-class class-symbol))
   :test (lambda(a b) (string-equal a (symbol-name (closer-mop:slot-definition-name b))))))

(defun start-wrap-for-class (root-class-symbol &optional (fn json::*beginning-of-object-handler*))
  (lambda ()
    (let ((class-symbol-of-reference-holder nil)
      (method-symbol-of-reference-holder *last-json-key-read*)) ;; default case : we are on root object, don't do anything else.
      (when method-symbol-of-reference-holder
    (let ((previous-class-symbol (caar *stack-of-object-ref*))
          (previous-json-key-for-slot (cdar *stack-of-object-ref*)))
      (if previous-class-symbol
          ;; if we are not in first class object : get the current class by using previous class and slot-definition-type.
          (setf class-symbol-of-reference-holder
            (closer-mop:slot-definition-type
             (get-slot-definition previous-class-symbol previous-json-key-for-slot)))
          ;; else we are a first class object : use class-symbol.
          (setf class-symbol-of-reference-holder root-class-symbol))))
      ;; now that the three cases are resolved let's push the cons on the stack.
      (setf *stack-of-object-ref* (cons (cons class-symbol-of-reference-holder method-symbol-of-reference-holder) *stack-of-object-ref*))) ;; stack push
    (funcall fn)))

(defun end-wrap-for-class (root-class-symbol &optional (fn json::*end-of-object-handler*))
  "Utility code to unwrap JSON using cl-json::prototype and create instances of defined CLOS objects (https://stackoverflow.com/a/55018976/6509567)"
  (let ((top-level-prototype (make-instance 'json::prototype :lisp-class root-class-symbol :lisp-package (find-symbol (package-name (symbol-package root-class-symbol))))))
    (lambda ()
      ;; dynamically re-bind *prototype* right around calling fn
      (let ((json::*prototype* top-level-prototype) ;;root case
        (current-class-symbol (caar *stack-of-object-ref*))
        (current-json-key-for-slot (cdar *stack-of-object-ref*))
        (json:*json-symbols-package* (symbol-package root-class-symbol)))
    (when current-json-key-for-slot
      ;; regular case
      (let ((the-method (get-slot-definition current-class-symbol current-json-key-for-slot)))
        (setf json::*prototype* (make-instance 'json::prototype
                           :lisp-class (closer-mop:slot-definition-type the-method)
                           :lisp-package (find-symbol (package-name (symbol-package (closer-mop:slot-definition-type the-method))))))
        (format t "json::*prototype*= ~a (the-parent-slot-name= ~a) class-name= ~a package-name= ~a~%" json::*prototype* the-method (closer-mop:slot-definition-type the-method) (package-name (symbol-package (closer-mop:slot-definition-type the-method))))
        (setf json:*json-symbols-package* (symbol-package (closer-mop:slot-definition-type the-method)))))
    ;; reset the same *last-json-key-read* as wrap-for-key does, in case we are in an array.
    (setf *last-json-key-read* current-json-key-for-slot) ;; redo as if we had read this key again (array scenario)
    (setf *stack-of-object-ref* (cdr *stack-of-object-ref*)) ; stack pop
    (funcall fn)))))

(defun wrap-for-key (&optional (fn json::*object-key-handler*))
  (lambda (the-key)
    (setf *last-json-key-read* the-key)
    (funcall fn the-key)))

(defun decode-json-to-clos (output-class-symbol json-input-string)
  "JSON string to CLOS instance method.
This could be called make-instance-from-json."
  (let ((json:*json-symbols-package* (symbol-package output-class-symbol)))
    (json:with-decoder-simple-clos-semantics
      (let* ((*stack-of-object-ref* (list))
         (*last-json-key-read* nil)
         (*name-of-current-class-being-decoded* nil)
         (json::*beginning-of-object-handler* (start-wrap-for-class output-class-symbol))
         (json::*end-of-object-handler* (end-wrap-for-class output-class-symbol))
         (json::*object-key-handler* (wrap-for-key )))
    (json:decode-json-from-string json-input-string)))))

(defgeneric make-instance-from-json (class-symbol json-input)
  (:documentation "make an instance of class-symbol from the json-input data"))
                    ;( the-class json-input)
(defmacro define-method-make-instance-from-json ((target-class-symbol  &optional json-input-class-symbol) &key with)
  "Used to create methods make-instance-from-json specialized on a type of object.
Structure of WITH must be ((the-class json-input) body)
 - where the-class and json-input are designators of the defmethod parameters to refer to in the body context.
 - where body is a list of sexp that forms the body of the defmethod."

  (let ((the-class (first (first with)))
    (json-input (second (first with)))
    (body (second with))
    (json-type json-input-class-symbol))
    (when (null json-type)
      (setf json-type 'common-lisp:string))
    `(defmethod make-instance-from-json ((,the-class (eql (find-class ',target-class-symbol)))
                     (,json-input ,json-input-class-symbol))
       ,@body)))

;; deprecated use make-instance-from-json since it now has a method to handle a symbol as parameter
(defmacro make-instance-from-json* (class-symbol json-input)
  "Shortcut macro for usability through code"
  (make-instance-from-json (find-class class-symbol) json-input))

(defmethod make-instance-from-json ((the-class common-lisp:standard-class)
                    (json-input common-lisp:string))
  (decode-json-to-clos (class-name the-class) json-input))

(defmethod make-instance-from-json ((the-class-symbol symbol)
                    (json-input common-lisp:string))
  "fallback to use the method with a symbol which is bound to a class"
  (make-instance-from-json (find-class the-class-symbol) json-input))

;;;; test tryout of a specifically definned instantiation:
;; (defmethod make-instance-from-json ((the-class (eql (find-class 'common-lisp:real)))
;;                  (json-input common-lisp:string))
;;   (format t "hello test i'm a real~%~a" the-class))

;; (defmethod make-instance-from-json ((the-class (eql (find-class 'common-lisp:rational)))
;;                  (json-input common-lisp:string))
;;   (format t "hello test i'm a RaTioNal~%~a" the-class))

;; (defmethod make-instance-from-json ((the-class (eql (find-class 'common-lisp:number)))
;;                  (json-input common-lisp:string))
;;   (format t " hey number here!! ~%~a" the-class))

;; from here example classes to illustrate json2clos use.
(defpackage :test-company
    (:use :common-lisp)
  (:export #:company))

(in-package :test-company)
(declaim (optimize (safety 3) (debug 0) (speed 0)))
(defclass company ()
  ((name
     :reader name
     :initarg :name)
   (address
    :reader address
    :initarg :address)
   (phone-number
    :reader phone-number
    :initarg :phone)))
(defpackage :test-person
  (:use :common-lisp :test-company)
  (:export #:person #:alone-person))
(in-package :test-person)
(declaim (optimize (safety 3) (debug 0) (speed 0)))
(defclass person ()
  ((name
    :reader name
    :initarg :name)
   (address
    :reader address
    :initarg :address)
   (phone-number
    :reader phone-number
    :initarg :phone)
   (favorite-color
    :reader favorite-color
    :initarg :color)
   (partner
    :type person
    :reader person
    :initarg :partner)
   (employed-by
    :type company
    :reader employed-by
    :initarg :employed-by)
   ))
(defclass alone-person ()
  ((name
    :reader name
    :initarg :name)
   (address
    :reader address
    :initarg :address)
   (phone-number
    :reader phone-number
    :initarg :phone)
   (favorite-color
    :reader favorite-color
    :initarg :color)))

;;from here test instances to run json2clos code.
(in-package :cl-user)
(declaim (optimize (safety 3) (debug 0) (speed 0)))
(defvar *myperson*)
(defvar *myalone-partner*)
(defvar *mypartner*)
(defvar *mycompany*)
(defvar *mycompany2*)
(setf *mycompany* (make-instance 'test-company:company
                 :name "World Company"
                 :address "Wall street, NYC"
                 :phone "999-999999"))
(setf *mycompany2* (make-instance 'test-company:company
                 :name "World Company2"
                 :address "Brexit street, London"
                 :phone "123-456789"))
(setf *mypartner* (make-instance 'test-person:person
                 :name "Alice"
                 :address "Regent Street, London"
                 :phone "555-99999"
                 :color "blue"
                 :employed-by *mycompany*
                 ))
(setf *myperson* (make-instance 'test-person:person
                 :name "Bob"
                 :address "Broadway, NYC"
                 :phone "555-123456"
                 :color "orange"
                 :partner *mypartner*
                 :employed-by *mycompany*
                 ))

;to encode in json
(defvar *myperson-string*)
(setf *myperson-string* (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))
(with-output-to-string (myperson-stream *myperson-string*)
  (cl-json:encode-json *myperson* myperson-stream))

(defvar *my-decoded-person*)
(setf *my-decoded-person* (json2clos:make-instance-from-json 'test-person:person *myperson-string*))
(inspect *my-decoded-person*)

```
\$\endgroup\$
  • \$\begingroup\$ Can you add an example? \$\endgroup\$ – Ehvince Oct 25 '19 at 22:44
  • \$\begingroup\$ Yes the 7 last lines are the run of the example. First I encode a PERSON in JSON, the I decode it back to the object PERSON (json2clos:make-instance-from-json 'test-person:person *myperson-string*) \$\endgroup\$ – user212061 Oct 28 '19 at 7:30

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.