window-can-do-operation oversight

["Mark A. Tapia" <markt@dgp.toronto.edu>]

Suppose that a window contains several views which
can be selected (and hilited) and that in each
views, the  edit operations suppported depend 
on the the view. For example, when the view is "empty" 
the operations of cut, copy and clear are not enabled but paste is.

The following example defines a new window class, where the
enabled edit menu items depend on the association list in a slot
(edit-ops). Notice the additional machinations required to
circumvent the deficiency in the window-can-do-operation method.

The problem is that the standard *edit-menu* enables a menu-item
when a method exists for the menu-item-action (method-exists-p ...) 
and the window can do the operation 
(window-can-do-operation window operation &optional opt).
However, the window-can-do-operation function depends on the window
and the title of the menu-item (operation) and not on the menu-item.

Is there a simpler way to do this while still retaining the full
functionality of the *edit-menu*.

mark


(in-package cl-user)

(defclass my-window (window)
  ((edit-ops :initform `((cut . t) (copy . t) (paste . t) (clear . t))
             :accessor edit-ops))
  (:default-initargs :window-title "Edit Demo"))

(defmethod cut ((window my-window))
  t)

(defmethod copy ((window my-window))
  t)

(defmethod paste ((window my-window))
  t)

(defmethod clear ((window my-window))
  t)

(defmethod hilited-items ((self window))
  (list self))

(defmethod window-can-do-op ((window my-window) menu-item operation &optional
opt)
  (when (window-can-do-operation window operation opt)
    (let ((menu-item-action (menu-item-action-function menu-item))
          (hilited-items (hilited-items window)))
      (and hilited-items 
           (loop for hilited-item in hilited-items
                 when (view-can-do-op window
                                      hilited-item 
                                      menu-item-action 
                                      operation)
                 do (return t) 
                 finally nil)))))

(defmethod view-can-do-op ((window my-window) view menu-item-action operation)
  (and (method-exists-p menu-item-action view)
       (rest (assoc operation (edit-ops window)))))

(defmethod ccl::modal-p ((self window))
  nil)

(advise CCL::EDIT-MENU-ITEM-UPDATE
        (let* ((menu-item (car arglist))
               (action (cadr arglist))
               (front-window (front-window))
               (class-precedence-list (class-precedence-list (class-of
front-window))))
          (if (or (null front-window)
                  (not (ccl::modal-p front-window)))
            (if (member 'my-window class-precedence-list 
                        :test #'equal 
                        :key #'class-name)
              (if (window-can-do-op front-window menu-item action)
                (menu-item-enable menu-item)
                (menu-item-disable menu-item))
              (:do-it))
            (menu-item-disable menu-item)))
        :when :around)

#|
(defparameter *w* (make-instance 'my-window))
; (setf (rest (assoc 'cut (edit-ops *w*))) t)    ; enable cut
; (setf (rest (assoc 'cut (edit-ops *w*))) nil)  ; disable cut
|#