;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.presentation)

;;;;;;
;;; parent/mixin

(def (component e) parent/mixin ()
  ((parent-component
    nil
    :type t
    ;; TODO: can't use this type there, because it would make this slot a component-slot, which is not what we want
    ;;       we could introduce a :child-component slot option but that is somewhat difficult due to CLOS being unable
    ;;       to easily modify slot options during making the direct slots and thus resulting in an initarg error
    #+nil(or null component))))

(def method (setf slot-value-using-class) :after (child (class component-class) (parent component) (slot component-effective-slot-definition))
  (setf (parent-component-references child) parent))

(def (function o) (setf parent-component-references) (new-parent child &optional parent-component-slot-index)
  (flet (((setf parent-component) (child)
           (bind ((current-parent (parent-component-of child)))
             (assert (or (not current-parent)
                         (eq current-parent new-parent)) nil "Cannot set ~A~%as new parent to child ~A~%while it is already under another parent ~A" new-parent child current-parent))
           (if parent-component-slot-index
               (setf (standard-instance-access child parent-component-slot-index) new-parent)
               (setf (parent-component-of child) new-parent))))
    (typecase child
      (parent/mixin
       (setf (parent-component) child))
      (sequence
       (iter (for element :in-sequence child)
             (when (typep element 'parent/mixin)
               (setf (parent-component) element))))
      (hash-table
       (iter (for (key value) :in-hashtable child)
             (when (typep value 'parent/mixin)
               (setf (parent-component) value))
             (when (typep key 'parent/mixin)
               (setf (parent-component) key)))))))

(def method add-component-message ((component parent/mixin) message message-args &rest initargs)
  (apply #'add-component-message (parent-component-of component) message message-args initargs))

(def method make-component-place ((component parent/mixin))
  (assert component nil "The value NIL is not a valid component.")
  (when-bind parent (parent-component-of component)
    (bind ((parent-class (class-of parent)))
      (iter (for slot :in (class-slots parent-class))
            (when (and (child-component-slot? parent slot)
                       (slot-boundp-using-class parent-class parent slot))
              (bind ((slot-value (slot-value-using-class parent-class parent slot)))
                (typecase slot-value
                  (component
                   (when (eq component slot-value)
                     (return-from make-component-place (make-object-slot-place parent slot))))
                  (sequence
                   (when (find component slot-value)
                     (return-from make-component-place (make-object-slot-sequence-element-place parent slot (position component slot-value)))))
                  (hash-table
                   (awhen (block find-key
                            (maphash (lambda (key value)
                                       (when (eq value component)
                                         (return-from find-key key)))
                                     slot-value))
                     (return-from make-component-place (make-object-slot-hash-table-value-place parent slot it)))))))))))