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

[Frank Goenninger]

... 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 ;-)
So, I am asking myself if it would be better to insert the check into  
the .kids observer ...

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 ?

Thanks for feedback!

Regards
     Frank



Am 30.10.2008 um 13:15 schrieb Frank Goenninger:

> * PGP Signed: 10/30/08 at 13:15:51
>
> Hi -
>
> I want to control if a kid is added to a parent based on the  
> execution of a check function. The check function is supposed to  
> throw an condition when the check fails.
>
> Current use case:
>
> Control which classes of kids are added to a parent. I do have a  
> model of class BOM (bill of material) that only can accept classes  
> Assembly and Part as kids.
>
> I found two places at which I could insert a call to the check  
> function:
>
> function fm-kid-add (higher level interface)
> function fm-kid-insert (lower level interface)
>
> Question now is: Why would one be better than the other?
>
> Idea here is based on adding a new slot to class family:
>
> (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    -----
>   (kid-add-control-hook :cell nil
>                         :initform nil
>                         :initarg: kid-add-control-hook)))
>
> and then do run the check functions that have been added to the  
> control hook (= list of functions to be funcalled).
>
> Right approach? Any comments? (It works but I'd like to know if am  
> on the right track).
>
> Thanks for feedback.
>
> Cheers
>    Frank
>
>
>
>
>
> * Frank Goenninger <frgo at me.com>
> * 0xE6BDA9B9:0x6AEA9601
> _______________________________________________
> cells-devel site list
> cells-devel at common-lisp.net
> http://common-lisp.net/mailman/listinfo/cells-devel
>
>
> * PGP Signed: 10/30/08 at 13:15:51
> * text/plain body
> * Frank Goenninger <frgo at me.com>
> * 0xE6BDA9B9:0x6AEA9601

-------------- next part --------------
A non-text attachment was scrubbed...
Name: PGP.sig
Type: application/pgp-signature
Size: 859 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/cells-devel/attachments/20081030/473725d1/attachment.sig>