[cells-devel] Cells: Controlling the way kids are added to a parent ...

[Kenny Tilton]

[hmmm... did you get my other response? This is a diff question, but you 
did not mention my other so I am concenred.]

Frank Goenninger wrote:
> ... and again a question related to this:
> 
> Suppose I have :
> 
> (defmd kid-test-2 (family)
>          (a-slot (c-in nil))
>          :kids (list (make-instance 'my-kid)
>                       (make-instance 'my-kid)))
> 
> Now - this completely bypasses the control mechanism inserted into fm- 
> kid-add - which is not what I wanted ;-)

Good point, another hole. In ACL and any CL supporting a full MOP, btw, 
you can supply an around method to (setf slot-value-using-class) which 
is the implementation of (setf slot-value) and /really/ control access. 
Anyway...

> So, I am asking myself if it would be better to insert the check into  
> the .kids observer ...

One big concern I have is, is this too late? Do you have any requirement 
to stop these sooner? ie, If you want to signal a condition that is 
fine, but recovering from it means also backing out the change and 
/that/ would be a lot of work at the late stage when the observer gets 
called.


> 
> I now have:
> 
> (defmodel family (model)
>   ((.kid-slots :cell nil
>      :initform nil
>      :accessor kid-slots
>      :initarg :kid-slots)
>    (.kids :initform (c-in nil) ;; most useful
>      :owning t
>      :accessor kids
>      :initarg :kids)
>    (registry? :cell nil
>      :initform nil
>      :initarg :registry?
>      :accessor registry?)
>    (registry :cell nil
>      :initform nil
>      :accessor registry)
>    ;; added: frgo, 2008-10-30
>    (control-hooks :cell nil
>                   :accessor control-hooks
>                   :initform (make-hash-table :test 'eql)
>                   :initarg :control-hooks)))
> 
> (defmethod get-control-hooks ((self family) hook-id)
>   (gethash hook-id (control-hooks self)))
> 
> (defmethod add-hook ((self family) id hook)
>   (setf (gethash id (control-hooks self)) hook))
> 
> (defun call-control-hook (hook self &rest args)
>   ;;; to be completed here
> )
> 
> (eval-when (:compile-time :load-toplevel)
>   (proclaim '(inline mklist))
>   (if (not (fboundp 'mklist))
>       (defun mklist (obj)
>         (if (listp obj)
>             obj
>             (list obj)))))
> 
> (defun run-control-hooks (id self &rest args)
>   (c-assert (typep self 'family))
>   (let ((hooks (get-control-hooks self id)))
>     (if hooks
>         (loop for hook in (get-control-hooks self id)
>            collect (call-control-hook hook self args)
>            into result
>            finally (return (mklist result)))
>         (mklist t))))
> 
> and
> 
> (define-condition cells-adding-kid-not-allowed-error (error)
>   ((text :initarg :text :reader text)))
> 
> (defun kid-add-allowed? (fm-parent kid)
>   (notany #'null (run-control-hooks 'fm-kid-add-control fm-parent  kid)))
> 
> (defun fm-kid-add (fm-parent kid &optional before)
>   (c-assert (or (null (fm-parent kid)) (eql fm-parent (fm-parent  kid))))
>   (c-assert (typep fm-parent 'family))
>   ;; Added: frgo, 2008-10-30
>   (if (kid-add-allowed? fm-parent kid)
>       (progn
>         ;; (trc "Adding kid to parent" kid fm-parent)
>         (setf (fm-parent kid) fm-parent)
>         (fm-kid-insert kid before))
>       (error 'cells-adding-kid-not-allowed-error
>               :text (format nil
>                             "ERROR: Kid ~s not allowed for parent  ~s." 
> kid fm-parent))))
> 
> - which is incomplete, of course, but shows the basic idea, or so I  hope.
> 
> Any thoughts if I should use the observer or do some clever slot  
> trickery using MOP ?

Ah, you were way ahead of me. The observer might be too late if you want 
this to be recoverable.

kt