pure CL prototype-based objects

flexijects.lisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; flexijects. An object system for CL.
;;;;
;;;; Uses closures and lists.
;;;;
;;;; CC0 - Paul Nathan, 2015.
;;;;
;;;;

(defparameter *known-classes* nil
  "Classes whose structure is known")

(defun erase-class (name)
  (setf *known-classes*
        (remove name *known-classes* :key #'car :test #'eql)))

(defun find-class-structure (name)
  (loop
    for class in *known-classes*
    do
       (when  (eql (car class) name)
         (return-from find-class-structure (cdr class)))))

(defun learn-or-relearn-class (name structure)
  (let ((old-structure (find-class-structure name)))
    (cond (old-structure
           (setf (cdr (assoc :slots old-structure))
                 (cdr (assoc :slots structure)))
           (setf (cdr (assoc :parents old-structure))
                 (cdr (assoc :parents structure)))
           old-structure)
          (t
           (pushnew (cons name structure) *known-classes* :key #'car :test #'eql)))))

(defun create-class-type (name parents slots)
  (let ((class-structure
          `((:name ,name)
            (:parents ,@parents)
            (:slots ,@slots))))
    (assert (listp parents))
    (assert (listp slots))
    (learn-or-relearn-class name class-structure)))

(defun collect-slot-list (name)
  (let*
      ((structure (find-class-structure name))
       (parents
         (cdr (assoc :parents structure))))

    (append (cdr (assoc :slots structure))
          (when parents
            (mapcan #'identity (mapcar #'collect-slot-list parents))))))

(defun find-expanded-class-structure (name)
  `((:name ,name)
    (:parents ,(cdr (assoc :parents (find-class-structure name))))
    (:slots ,(mapcar #'list (collect-slot-list name)))))

(defparameter *class-action-debug* t)
(defparameter *class-action-debug-stream* t)

(defun initialize-class-instance (class-name)
  (let ((instance (find-expanded-class-structure class-name)))

    (when *class-action-debug*
      (format *class-action-debug-stream* "~&Class template: ~a~%" instance))

    (lambda (&key action slot value)

      (when *class-action-debug*
        (format *class-action-debug-stream* "~&Action: ~a~%" action)
        (when slot
          (format *class-action-debug-stream* "~&Slot: ~a~%" slot))
        (when value
          (format *class-action-debug-stream* "~&Values: ~a~%" value)))

      (cond

        ((eq action :get)
         (cdr (assoc slot
                     (cadr (assoc :slots instance)))))

        ((eq action :set)
         (setf
          (cdr (assoc slot
                      (cadr (assoc :slots instance))))
          value))

        ((eq action :type-of-instance)
         class-name)

        ((eq action :slot-list)
         (mapcar #'car (cadr (assoc :slots instance))))

        (t
         (error "Unhandled method"))))))

(defparameter *function-table* (make-hash-table))

(defun recurse-building-hash-to-tail (list final &optional existing-table)
  "builds a trie-esque hash structure"
  (if list
    ;; relies on the lazy or short-circuit.
    (let ((table (or existing-table
                     (make-hash-table))))
      (if (gethash (car list) table)
          ;; if we have something to recurse in the table.
          (recurse-building-hash-to-tail (cdr list) final (gethash (cdr list) table))
          ;; otherwise...
          (setf (gethash (car list) table) (recurse-building-hash-to-tail (cdr list) final nil)))
      table)
    final))

(defun deep-hash-read (table list)
  (if (cdr list)
      (when (gethash (car list) table)
        (deep-hash-read (gethash (car list) table) (cdr list)))
      (gethash (car list) table)))

(defmethod print-object ((table hash-table) stream)
  (maphash #'(lambda (k v) (format t "~a => ~a" k v)) table))

(defun attach (function-object function-name class-names)
  ;; note that this doesn't obey package names at present. In order to
  ;; do so, either the function-name will have to be adjusted or
  ;; package names will be consed onto the front of the list
  (recurse-building-hash-to-tail (cons function-name class-names) function-object *function-table*))

(defun select-appropriate-dispatcher-function (function-name class-names)
  ;; pass in a list
  (deep-hash-read *function-table* (cons function-name class-names)))

(defun call-dispatcher-function (function-name &rest args)
  (let* ((arg-types
          (loop for arg in args collect (type-of-ject arg)))
         (funcallable
           (select-appropriate-dispatcher-function function-name arg-types)))

    (if funcallable
     (apply #'funcall
            funcallable
            args)
     (error "~a did not select a callable method: ~a were the called types" (cons function-name args) arg-types))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; interface

(defun findject (type)
  (find-class-structure type))

(defmacro defject (type parents slots)
  `(create-class-type ,type ,parents ,slots))

(defun makeject (type)
  (initialize-class-instance type))

(defun set-ject (object slot value)
  ;; reduces cognitive overhead
  (funcall object
           :action :set
           :slot slot
           :value value))

(defun get-ject (object slot)
  (funcall object
           :action :get
           :slot slot))

(defun type-of-ject (object)
  ;; checks type-of. if it's FUNCTION, try to get the ject type, which
  ;; might result in some kind of invalid function call error, if it's
  ;; not a ject type. we ignore and force that sad fate to NIL if
  ;; so. otherwise returns ject-type.
  ;;
  ;; FIXME: this code is ugly.
  (let ((existing-type (type-of object)))
    (if (eql existing-type 'function)
        (let ((ject-type
               (multiple-value-bind (type errors?)
                   (ignore-errors
                     (funcall object :action :type-of-instance))
                 (declare (ignore errors?))
                 type)))
          (if ject-type
              ject-type
              existing-type))
        existing-type)))

(defmacro defjectfun (name args &body body)
  (let ((actual-args (mapcar #'first args))
        (type-args (mapcar #'second args))
        (func-name `(quote ,name)))
    (let
        ((dispatch-args
          `(list ,@(loop for arg in type-args collect `',arg))))
      `(progn


         (unless (fboundp ,func-name)
           ;; this will not change regardless of redefinitions.
           (defun ,name (&rest args)
             (call-dispatcher-function ,func-name args)))

         (when (select-appropriate-dispatcher-function ,func-name ,dispatch-args)
           (warn "Flexiject method ~a is being redefined" ,func-name))

         (let ((actual-code
                #'(lambda ,actual-args
                    ,@body)))
           (attach
            actual-code
            ,func-name
            ,dispatch-args)
           actual-code)))))


(create-class-type 'drink nil '(:weight :size))
(create-class-type 'booze '(drink) '(:abv))
(create-class-type 'tracking-info nil '(:country-of-origin))
(create-class-type 'beer '(booze tracking-info) '(:type-of-beer))

(defparameter *foo* (makeject 'beer))
(set-ject *foo* :abv 10)
(defparameter *bar* (makeject 'booze))
(set-ject *bar* :abv 20)

(defjectfun drink ((cup Beer))
  (format t "~a~%" cup)
  (format t "Drinking ~a" (get-ject cup :abv)))

(defjectfun drink ((cup Beer) (keg whiskey))
  (format t "~a~%" cup)
  (format t "Drinking ~a" (get-ject cup :abv)))

(defjectfun drink ((cup booze))
  (format t "~a~%" cup)
  (format t "slurping ~a" (get-ject cup :abv)))