;; Copyright (c) 2003-2005 Edward Marco Baringer
;; All rights reserved. 
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 
;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;;    of its contributors may be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :org.unknownlamer.ucw-im)

(defstruct (indirect-value :named
                           (:constructor make-indirect-value)
                           (:conc-name indirect-))
  object
  reader
  writer)

(defmacro indirect-value (object accessor/reader/slot-name &optional writer)
  "Create instance of indirect-value structure.
OBJECT -- value for object slot of structure.

If WRITER defined then second and third arguments are treated as
READER/WRITER and must evaluate to funcallable objects.

Otherwise if second argument is a symbol it is treated as accessor name.
If it is not a symbol it must evaluate to slot name of OBJECT.
\(INDIRECT-VALUE object #'reader #'writer)
\(INDIRECT-VALUE object slot-accessor)
\(INDIRECT-VALUE object 'slot-name)."
  (with-unique-names (r w sn)
  `(let ((,r)
         (,w)
         (,sn))
     (setf
      ,@(if writer
            `(,r ,accessor/reader/slot-name
                 ,w ,writer)
            (typecase  accessor/reader/slot-name
              (symbol `(,r #',accessor/reader/slot-name
                           ,w #'(lambda (o v)
                                  (setf (,accessor/reader/slot-name o) v))))
             (t `(,sn ,accessor/reader/slot-name
                      ,r #'(lambda (o) (slot-value o ,sn))
                      ,w #'(lambda (o v) (setf (slot-value o ,sn) v)))))))
     (make-indirect-value
      :object ,object
      :reader ,r
      :writer ,w))))
                           
(defclass indirect-value-mixin-class (standard-class)
  ()
  (:documentation "Metaclass for INDIRECT-VALUE-CLASS-MIXIN."))

(defmethod mopp:validate-superclass ((class indirect-value-mixin-class) (superclass mopp:standard-class))
  t)

(defclass indirect-value-standard-component-class (standard-component-class indirect-value-mixin-class)
  ())

(defclass interface-element-class (standard-component-class
				   indirect-value-mixin-class)
      ()
  (:documentation "Metaclass for interface elements."))

(defmethod mopp:slot-boundp-using-class ((class indirect-value-mixin-class) obj slotd)
  (declare (special %indirect-value-access%))
  (when (call-next-method)
    (let ((value (mopp:slot-value-using-class (find-class 'standard-class)
                                              obj
                                              slotd)))
      (if (and (indirect-value-p value)
               (not (and (boundp '%indirect-value-access%)
                         %indirect-value-access%)))
          (not (null (indirect-object value)))
          t))))

(defmethod mopp:slot-makunbound-using-class ((class indirect-value-mixin-class) obj slotd)
  (when (mopp:slot-boundp-using-class (find-class 'standard-class) obj slotd)
    (let ((value (mopp:slot-value-using-class (find-class 'standard-class)
                                              obj
                                              slotd)))
      (if (indirect-value-p value)
          (setf (indirect-object value) nil)
          (call-next-method)))))

(defmethod mopp:slot-value-using-class ((class indirect-value-mixin-class) obj slotd)
  (declare (ignore obj))
  (let ((value (call-next-method)))
    (if (indirect-value-p value)
        (with-slots (object reader)
            value
          (if reader
              (funcall reader object)
              (slot-value object (mopp:slot-definition-name slotd))))
        value)))

(defmethod (setf mopp:slot-value-using-class) (new (class indirect-value-mixin-class) obj slotd)
  (let ((value (when (mopp:slot-boundp-using-class (find-class 'standard-class)
                                                   obj
                                                   slotd)
                 (mopp:slot-value-using-class (find-class 'standard-class)
                                              obj
                                              slotd))))
    (if (indirect-value-p value)
        (with-slots (object writer)
            value
          (if writer
              (funcall writer object new)
              (setf (slot-value object (mopp:slot-definition-name slotd)) new)))
        (call-next-method))))

(defgeneric  slot-indirect-value (object slot-name)
  (:documentation "Get real value of indirect slot not one of indirect object."))

(defgeneric  (setf slot-indirect-value) (new object slot-name)
  (:documentation "Set real value of indirect slot not one of indirect object."))

(defun find-slot-definition (class slot-name)
  (dolist (slot (mopp:class-slots class) nil)
    (when (eql slot-name (mopp:slot-definition-name slot))
      (return slot))))

(defmethod slot-indirect-value ((obj t) (slot-name symbol))
  (if-bind slot-def (find-slot-definition (class-of obj) slot-name)
	 (slot-indirect-value obj slot-def)
	 (error "When attempting to read the slot's indirect value (slot-indirect-value), the slot ~a is missing from obj ~a" slot-name obj)))

(defmethod slot-indirect-value ((obj t)
                                (slotd mopp:standard-effective-slot-definition))
  (let ((%indirect-value-access% t))
    (declare (special %indirect-value-access%))
    (mopp:slot-value-using-class (find-class 'standard-class) obj slotd)))

(defmethod (setf slot-indirect-value) (new (obj t) (slot-name symbol))
  (setf (slot-indirect-value obj (find-slot-definition (class-of obj) slot-name))
        new))

(defmethod (setf slot-indirect-value) (new
                                       (obj t)
                                       (slotd mopp:standard-effective-slot-definition))
  (let ((%indirect-value-access% t))
    (declare (special %indirect-value-access%))
    (setf (mopp:slot-value-using-class (find-class 'standard-class) obj slotd)
          new)))

(defmethod slot-indirect-boundp ((obj t) slot)
  (let ((%indirect-value-access% t)) ; we want actual state of the slot
    (declare (special %indirect-value-access%)) 

    (slot-boundp obj slot)))

(defmethod slot-indirect-makunbound ((obj t) slot)
  (let ((%indirect-value-access% t)) ; we want actual state of the slot
    (declare (special %indirect-value-access%)) 
    
    (when (slot-boundp obj slot)
      (setf (slot-indirect-value obj slot) nil) ; delete indirect-value
      (slot-makunbound obj slot)                ; now ordinary method will work
      )))

(defmethod slot-indirect-object ((obj t) (slot t))
  (indirect-object (slot-indirect-value obj slot)))

(defmethod (setf slot-indirect-object) (new (obj t) (slot t))
  (setf (indirect-object (slot-indirect-value obj slot)) new))

(defmethod slot-indirect-p ((obj t) (slot-name symbol))
  (indirect-value-p (slot-indirect-value obj slot-name)))