CLIM mail archive
[Prev][Next][Index][Thread]

menus and commands

    Date: Tue, 7 Jul 1992 16:20 EDT
    From: Tom Trinko <ttrinko@dipl.rdd.lmsc.lockheed.com>

    I'm using CLIM 1.1, common lisp, and Genera 8.1.1 but I think these are generic CLIM questions.

    1)  I have a popup menu associated with presentation objects.  I use the
	define presentation action command which in turn calls the
	call-presentation-menu command.  This works fine except the list
	 of commands doesn't appear to be alphabetized.  I have added the
	 :after :sort options to some, but not all of the commands that
	 appear in the popup menu.  The commands with the :after :sort don't
	  seem to appear in alphabetical order. What am I doing wrong?

:AFTER :SORT affects command menus, not menus of presentation
translators.  CALL-PRESENTATION-MENU could certainly sort the
translators it comes up with, maybe based on the command names.
I've included the source below for you to hack on.

    2)  we have several panes that contain command menus.  we use the 
	display-command-menu as the display function.  some of the
	commands in the command-menu have menu's associated with them.
	I'd like to be able to associate some of the commands in the menu's
	that popup with the top level command.  for example the command pane
	might look like this
	     command 1 
	     command 2
	     command 3
 
	 when you click on command 2 you get a menu with entries 
	      command 1-1
	      command  1-2
	      command 1-3

	 what I'd like to do is associate command 1-3 with the top level
	 command 2 so that when the user moves the mouse over command 2
	 and clicks say shift mouse middle command 1-3 is executed.  in
	 dw we used define-command-menu-handler to get this behavior.

    Thanks for any help.  I'd especially appreciate code samples.

I used the following code for a hack I was working on.  I think it
will work in CLIM 1.1, but I did not test it again to make sure.
It does not presently get the mouse doc line right, either.  No
warranties expressed or implied.


-------- command menu handlers --------
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-

(in-package "CLIM")

(eval-when (compile load eval)
  (export '(clim::define-command-menu-handlers) 'clim))

;; Defines a command menu item named MENU-NAME (a string) in the command table
;; COMMAND-TABLE that has multiple "handlers".  HANDLER-NAME is a symbol that
;; names the handler.  Each of the clauses in HANDLERS is a list of the FORM
;; (GESTURE-NAME COMMAND).
(defmacro define-command-menu-handlers (menu-name handler-name command-table &body handlers)
  `(progn
     (defun ,handler-name (event numeric-arg)
       (declare (ignore numeric-arg))
       (typecase event
	 (null
	   ;;--- We really want to compute all the pointer documentation here,
	   ;;--- but CLIM just can't manage that right now, because things like
	   ;;--- FIND-INNERMOST-APPLICABLE-PRESENTATION do not pass along the
	   ;;--- event (or shift mask) argument uniformly when we are running
	   ;;--- to compute documentation.
	   ',(second (first handlers)))
	 (pointer-button-press-event
	   (cond ,@(mapcar #'(lambda (h)
			       `((button-press-event-matches-gesture-name event ',(first h))
				 ',(second h)))
			   handlers)))))
     (add-menu-item-to-command-table ',command-table
       ,menu-name :function ',handler-name
       :errorp nil)))

;;--- Adding :GESTURE T to these has the unpleasant side-effects that
;;--- the :MENU gesture stops working for command menu items.
(define-presentation-translator command-menu-element-to-command
    (command-menu-element command global-command-table
     :gesture t
     :tester
       ((object event)
	(let* ((menu-item (third object))
	       (type (command-menu-item-type menu-item)))
	  (and (or (eql type ':command)
		   (eql type ':function))
	       (command-enabled-p
		 (command-name (extract-command-menu-item-value menu-item event))
		 *application-frame*))))
     :tester-definitive t
     ;; The pointer-documentation uses this, too
     :documentation
       ((object presentation context-type frame event window x y stream)
	(let ((documentation (getf (command-menu-item-options (third object)) :documentation)))
	  (if documentation
	      (write-string documentation stream)
	      (document-presentation-to-command-translator
		(find-presentation-translator 'command-menu-element-to-command
					      'global-command-table)
		presentation context-type frame event
		window x y stream)))))
    (object event)
  (extract-command-menu-item-value (third object) event))

(define-presentation-translator command-menu-element-to-sub-menu
    (command-menu-element command global-command-table
     :gesture t
     :tester
       ((object)
	(let ((menu-item (third object)))
	  (and (eql (command-menu-item-type menu-item) ':menu)
	       (let ((comtab (find-command-table
			       (command-menu-item-value menu-item)
			       :errorp nil)))
		 (and comtab
		      (slot-value comtab 'menu)
		      ;; You might think that including the following in the
		      ;; tester is reasonable (that is, make the translator
		      ;; applicable only if the context's command table inherits
		      ;; from the command table that this menu item points to.)
		      ;; Unfortunately, that doesn't work because command table
		      ;; inheritance isn't the only way to get something into a
		      ;; command table.  The only alternative is to recursively
		      ;; walk over the sub-menu(s) to see if at least one command
		      ;; is applicable.
		      #+++ignore
		      (with-presentation-type-parameters (command context-type)
			(command-table-presentation-subtypep command-table comtab)))))))
     :tester-definitive t
     ;; The pointer-documentation uses this, too
     :documentation
       ((object stream)
	(write-string (first object) stream)
	(write-char #\Space stream)
	(write-string "Menu" stream)))
    (object window)
  (values
    (menu-execute-command-from-command-table
      (command-menu-item-value (third object))
      :associated-window window :cache t)))


-------- hack this to sort presentation menus --------
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-

(in-package "CLIM")

(defun call-presentation-menu (presentation input-context frame window x y
			       &key (for-menu t) label)
  (let* ((translators (find-applicable-translators presentation input-context 
						   frame window x y
						   :event nil :for-menu for-menu))
	 ;; Yecch.  The problem is each "translator stuff" is a list, which
	 ;; is indistinguishable from the item syntax.  Oh well, we're already
	 ;; consing up stuff already...
	 (item-list
	   (and translators (map 'list
				 #'(lambda (thing)
				     (list thing :value thing))
				 translators))))
    (when translators				;just in case...
      (flet ((translator-documentation (translator-stuff stream)
	       (setq translator-stuff (menu-item-value translator-stuff))
	       (let* ((translator (pop translator-stuff))
		      (presentation (pop translator-stuff))
		      (context-type (pop translator-stuff)))
		 (document-presentation-translator translator presentation context-type
						   frame nil window x y
						   :stream stream
						   ;; Run the body if need be
						   :documentation-type :from-body))))
	(declare (dynamic-extent #'translator-documentation))
	(let ((chosen (menu-choose item-list
				   :associated-window window
				   :label label
				   :printer #'translator-documentation)))
	  (when chosen
	    ;; Anticipate the day when we can move the mouse off the menu
	    (let* ((translator (pop chosen))
		   (presentation (pop chosen))
		   (context-type (pop chosen))
		   (tag (pop chosen)))
	      (multiple-value-bind (translated-object translated-type options)
		  (call-presentation-translator translator presentation context-type
						frame nil window x y)
		(throw tag (values translated-object
				   (or translated-type context-type)
				   nil		;would be an event...
				   options))))))))))
References:
Main Index | Thread Index