;;; -*- Mode:Emacs-Lisp -*-

;;; The names of the menu items (as emacs sees them) are short and ugly.
;;; These are the names by which the Energize protocol knows the commands.
;;; The menu items are made to display in a more human-friendly way via the
;;; X resource database, which is expected to contain entries like
;;;
;;;	*buildanddebug.labelString:	Build and Debug
;;;
;;; in the Emacs app-defaults file.
;;;
;;; We need to map these short Energize-names to the functions which invoke
;;; them; we do this via the energize-menu-item-table, which is an obarray
;;; hash table associating the names with the functions.  We do the reverse
;;; association via an 'energize-name property on the function's name symbol.

(require 'menubar)

(defconst energize-menu-item-table (make-vector 511 nil)
  "obarray used for fast mapping of symbolic energize request-names to the 
functions that invoke them.")

(defvar energize-menu-state ()
  "Buffer local variable listing the menu items associated with a buffer.")

(defvar energize-default-menu-state ()
  "List of the Energize menu items associated with every buffers.")

;;; Hook to update the menu state when the kernel tells us it changed

(defun energize-update-menu-state (items)
  (let ((buffer (car items))
	(previous-buffer (current-buffer))
	(extent (car (cdr items))))
    (if (null buffer)
	(setq energize-default-menu-state items)
      (unwind-protect
	  (progn
	    (set-buffer buffer)
	    (setq energize-menu-state items))
	(set-buffer previous-buffer)))))

(setq energize-menu-update-hook 'energize-update-menu-state)

;;; The energize-with-timeout macro is used to show to the user that we are 
;;; waiting for a reply from the energize kernel when it is too slow.

(defvar initial-energize-timeout-state
  (let ((l '("." ".." "..." "...." "....." "......" "......." "........")))
    (nconc l l)))

(defvar energize-timeout-state initial-energize-timeout-state)

(defun energize-warn-kernel-slow (pair)
  (setq energize-timeout-state (cdr energize-timeout-state))
  (message (if (eq interrupt-char ?\C-g)
	       "%s Type ^G to cancel%s"
	     (format "%%s Type %c to cancel%%s" interrupt-char))
	   (car pair) (car energize-timeout-state))
  (rplacd pair t))

(defmacro energize-with-timeout (notice &rest body)
  (list 'let* (list
	       (list 'timeout-pair (list 'cons notice nil))
	       '(timeout (add-timeout 1.5 'energize-warn-kernel-slow
				      timeout-pair 1.5)))
	(list 'unwind-protect (cons 'progn body)
	      '(disable-timeout timeout)
	      '(setq energize-timeout-state initial-energize-timeout-state)
	      '(if (cdr timeout-pair) (message "")))))

(defun energize-def-menu-item (name function &optional dont-define)
  ;; function->name mapping is on the function name's plist
  ;; name->function mapping is via an obarray
  ;; dont-define means it already has a function definition
  (put function 'energize-name name)
  (set (intern name energize-menu-item-table) function)
  ;; Define the (trivial) function
  ;; It's ok that this function is interpreted, because it contains only
  ;; one function call with constant args, so it's just as fast as it would
  ;; be if it were byte-coded.
  (if (not dont-define)
      (fset function
	    (` (lambda ()
		 (, (format "Executes the Energize \"%s\" command." name))
		 (interactive)
		 (energize-execute-command (, name))))))
  ;; Return the menu-item descriptor.
  (vector name function nil))

(defmacro energize-def-menu (menu-name &rest items)
  (` (list (, menu-name)
	   (,@ (mapcar
		'(lambda (x)
		   (if (and (consp x) (stringp (car x)))
		       (cons 'energize-def-menu-item
			     (mapcar '(lambda (xx)
					(if (stringp xx) xx (list 'quote xx)))
				     x))
		     x))
		items)))))

(put 'energize-def-menu 'lisp-indent-function 1)

(defconst energize-menubar
  (let ((file (or (assoc "File" default-menubar) (error "no File menu?")))
	(edit (or (assoc "Edit" default-menubar) (error "no Edit menu?")))
	(buffers (or (assoc "Buffers" default-menubar)
		     (error "no Buffers menu?"))))
    (list

 ;; The first thing in the menubar is the "sheet" button
 ["sheet" energize-toggle-psheet nil]

 ;; Add a "shutdown" menu item to the existing "File" menu.
 (append file
	 (list (energize-def-menu-item "quit" 'energize-kill-server t)))
     
 edit	; unchanged
     
 (energize-def-menu "Navigate"
   ["Next Error"	next-error			t]
   ["Previous Error"	previous-error			t]
   "-----"
   ("findproject"	energize-find-project)
   ("project"		energize-pop-to-project-buffer)
   ("energize"		energize-pop-to-energize-buffer)
   ["Shell"		shell				t]
   )
 
 (energize-def-menu "Browse"
   ("editdef"		energize-edit-definition-dbox)
   ("editdec"		energize-edit-declaration-dbox)
   ("lebrowser"		energize-browse-language-elt)
   ("calltreebrowser"	energize-browse-tree)
   ("classbrowser"	energize-browse-class)
   "-----"
   ("errorbrowser"	energize-browse-error)
   ("clearerrorlog"	energize-clear-error-log)
   "-----"
   ("includers"		energize-where-included)
   "-----"
   ("toolstatus"	energize-browse-toolstat)
   ("showsystemlog"	energize-browse-system-log)
   )

 (energize-def-menu "Debug"
   ("debugprogram"	energize-debug-target)
   ("debuggerpanel"	energize-show-debugger-panel)
   "-----"
   ("breaklist"		energize-list-breakpoints)
   ("setbreakpoint"	energize-set-breakpoint)
   "-----"
   ("runprogram"	energize-run-target)
   ("openprogram"	energize-debugger-start-main)
   ("stopprogram"	energize-debugger-stop)
   ("continueprogram"	energize-debugger-continue)
   ("steponce"		energize-debugger-step)
   ("stepnext"		energize-debugger-next)
   ("continueuntilreturn"  energize-debugger-finish)
   "-----"
   ("innerframe"	energize-debugger-current-frame)
   ("upframe"		energize-debugger-up-frame)
   ("downframe"		energize-debugger-down-frame)
   ("backtrace"		energize-debugger-backtrace)
   "-----"
   ("print"		energize-debugger-print)
   "-----"
   ("cleardebuggerlog"	energize-clear-debugger-log)
   ("closeprogram"	energize-debugger-kill-program)
   ("quitdebugger"	energize-quit-debugger)
   )

 (energize-def-menu "Compile"
   ("buildanddebug"	energize-build-and-debug)
   ("incrementalbuild"	energize-build)
   ("buildprogram"	energize-full-build)
   ("compileprogram"	energize-compile-target)
   ("link"		energize-link-target)
   "-----"
   ("compilemods"	energize-compile-file)
   ("compilefile"	energize-full-compile-file)
   ("compilecheck"	energize-check-for-errors)
   "-----"
   ("deleteallobjects"	energize-delete-object-files)
   )

 (energize-def-menu "Project"
   ("newproject"		energize-new-project)
   ("importproject"		energize-import-project)
   "-----"
   ("importprojectlist"		energize-import-project-list)
   ("writeprojectlist"		energize-write-project-list)
   "-----"
   (energize-def-menu "addtarget"
     ("addfiletarget"		energize-insert-file-target)
     ("addexecutabletarget"	energize-insert-executable-target)
     ("addlibrarytarget"	energize-insert-library-target)
     ("addcollectiontarget"	energize-insert-collection-target))
   ("abbreviatetargets"		energize-abbreviate-targets)
   ("fulltargets"		energize-full-targets)
   "-----"
   ("showallfiles"		energize-show-all-files)
   ("onlyshowsources"		energize-show-only-sources)
   ("shownofiles"		energize-show-no-files)
   "-----"
   ("revertproject"		energize-fully-revert-project-buffer)
   )

 buffers

 nil
 
 '("Help"	["Info"			info			t]
		["Describe Mode"	describe-mode		t]
		["Command Apropos"	command-apropos		t]
		["List Keybindings"	describe-bindings	t]
		["Describe Key"		describe-key		t]
		["Describe Function"	describe-function	t]
		["Describe Variable"	describe-variable	t]
		"-----"
		;; the "manual" entry is the only difference between this
		;; and the default Help menu.
		["manual"		energize-unix-manual	t]
		["Emacs Tutorial"	help-with-tutorial	t]
		["Emacs News"		view-emacs-news		t]
		)
 ))
  "The emacs menubar used when Energize is installed.")

(set-menubar energize-menubar)

(defun energize-kill-server ()
  "Kill the Energize server and all buffers associated with it."
  (interactive)
  (condition-case nil
      (energize-execute-command "quit")
    (error nil)))

(defun energize-unix-manual ()
  "Display a manual entry; if connected to Energize, uses the Energize version.
Otherwise, just runs the normal emacs `manual-entry' command."
  (interactive)
  (if (connected-to-energize-p)
      (energize-execute-command "manual")
    (call-interactively 'manual-entry)))

;;; These functions are used in the menubar activate hook to update the
;;; enable state of the menu items

(defsubst activate-energize-menu-item-internal (item)
  (cond
   ((vectorp item)
    (let ((fn (aref item 1)))
      (if (not (and (symbolp fn) (get fn 'energize-name)))
	  nil
	;; Referencing special binding of `active-items' from a-e-m-i-hook.
	;; If the function which this item invokes is an Energize function
	;; (determined by the presence of an 'energize-name property) then
	;; make it be active iff it's on the active-items list.
	(let ((active-p (memq fn active-items)))
	  (if (eq (not active-p) (not (aref item 2)))
	      nil
	    (aset item 2 (not (not active-p)))
	    t)))))
   ((consp item)  ; descend nested submenus
    (activate-energize-menu-items-internal (cdr item)))
   (t nil)))

(defun activate-energize-menu-items-internal (items)
  (let ((change-p nil))
    (if (not (consp items))
	(activate-energize-menu-item-internal items)
      (while items
	(setq change-p (or (activate-energize-menu-item-internal (car items))
			   change-p)
	      items (cdr items)))
      change-p)))

(defun energize-build-menubar-names ()
  ;;; makes the list of currently active menu items.
  (let* ((selection-p (x-selection-exists-p 'PRIMARY))
	 (menubar
	  (if (< (cdr (energize-protocol-level)) 7)
	      (energize-with-timeout
	       "Getting updated menubar from kernel..."
	       (energize-list-menu (current-buffer) () selection-p))
	    (append energize-menu-state energize-default-menu-state))))
    (delq nil
	  (mapcar '(lambda (x)
		     (and (vectorp x)
			  (if (/= 0 (logand 1 (aref x 3)))
			      nil
			    (symbol-value
			     (intern-soft (aref x 0)
					  energize-menu-item-table)))))
		  menubar))))

(defun activate-energize-menu-items-hook (nothing)
  ;; This is O^2 because of the `rassq', but it looks like the elisp part
  ;; of it only takes .03 seconds.  
  (if (connected-to-energize-p)
      (let* ((items current-menubar)
	     (change-p nil)
	     (active-items (energize-build-menubar-names))
	     item)
	(while items
	  (setq item (car items)
		change-p (or (and item (activate-energize-menu-items-internal
					(if (consp item) (cdr item) item)))
			     change-p)
		items (cdr items)))
	(not change-p))))


(or (memq 'activate-energize-menu-items-hook activate-menubar-hook)
    (setq activate-menubar-hook
	  (nconc activate-menubar-hook '(activate-energize-menu-items-hook))))
 

;;; Popup-menus

(defvar energize-popup-menu)

(defun energize-popup-menu (event)
  (interactive "e")
  (let* ((buffer (window-buffer (event-window event)))
	 (extent (if (extentp (event-glyph event))
		     (event-glyph event)
		   (energize-menu-extent-at (event-point event) buffer)))
	 choices)
    (select-window (event-window event))
    (if (null extent)
	(error "No extent with an Energize menu here"))
    (energize-with-timeout
     "Asking for extent menu to Energize server..."
     (setq choices
	   (cdr
	    (cdr
	     (energize-list-menu buffer extent
				 (x-selection-exists-p 'PRIMARY))))))
    (if (null choices)
	(error "No Energize menu here"))
    (force-highlight-extent extent t)
    (sit-for 0)
    (setq energize-popup-menu
	  (cons "energizePopup"
		(mapcar
		 (function (lambda (item)
			     (vector
			      (aref item 0)
			      (list 'energize-execute-command
				    (aref item 0)
				    extent)
			      (= 0 (logand 1 (aref item 3))))))
		 choices)))
    (popup-menu 'energize-popup-menu)
    ;;
    ;; Setting zmacs-region-stays is necessary here because executing a
    ;; command from a menu is really a two-command process: the first command
    ;; (bound to the button-click) simply pops up the menu, and returns.
    ;; This causes a sequence of magic-events (destined for the popup-menu
    ;; widget) to begin.  Eventually, a menu item is selected, and a menu-
    ;; event blip is pushed onto the end of the input stream, which is then
    ;; executed by the event loop.
    ;;
    ;; So there are two command-events, with a bunch of magic-events between
    ;; them.  We don't want the *first* command event to alter the state of
    ;; the region, so that the region can be available as an argument for the
    ;; second command.
    ;;
    (setq zmacs-region-stays t)))


;;; Functions to interactively execute menu items by their names.

(defun energize-menu-extent-at (pos buffer)
  (if (null pos)
      nil
    (let ((extent (extent-at pos buffer 'menu)))
      (if (and extent (energize-extent-menu-p extent))
	  extent
	nil))))

;;; functions to execute the menu with the keyboard
(defun default-selection-value-for-item (menu-item)
  (let ((flags (aref menu-item 3)))
    (cond ((= (logand flags 2) 2)
	   (if (x-selection-owner-p 'PRIMARY)
	       (x-get-selection-internal 'PRIMARY 'STRING)))
	  ((= (logand flags 4) 4)
	   (if (x-selection-owner-p 'PRIMARY)
	       (x-get-selection-internal 'PRIMARY 'ENERGIZE_OBJECT)))
	  ((= (logand flags 128) 128)
	   (if (x-selection-owner-p 'SECONDARY)
	       (x-get-selection-internal 'SECONDARY 'STRING)))
	  ((= (logand flags 256) 256)
	   (if (x-selection-owner-p 'SECONDARY)
	       (x-get-selection-internal 'SECONDARY 'ENERGIZE_OBJECT))))))
  
(defun energize-execute-menu-item-with-selection (buffer
						  extent
						  item
						  selection
						  no-confirm)
  (if (/= 0 (logand 1 (aref item 3)))
      (error "The `%s' command is inappropriate in this context"
	     (aref item 0)))
  (if (null selection)
      (setq selection (default-selection-value-for-item item)))
  (energize-execute-menu-item buffer extent item selection no-confirm))

(defun energize-find-item (name list)
  (let ((l list) i (found ()))
    (while (and l (not found))
      (setq i (car l) l (cdr l))
      (if (and (vectorp i) (equal (aref i 0) name))
	  (setq found i)))
    found))

(defun energize-menu-item-for-name (extent name)
  (if (or extent (< (cdr (energize-protocol-level)) 7))
      (energize-with-timeout
       "Checking Energize command with kernel..."
       (energize-list-menu (current-buffer) extent
			   (x-selection-exists-p 'PRIMARY) name))
    (or (energize-find-item name energize-menu-state)
	(energize-find-item name energize-default-menu-state))))

(defun energize-execute-command (name &optional extent selection no-confirm)
  ;; add completion here...
  (interactive "sExecute Energize command named: ")

  (if (not (stringp name))
      (error "Can't execute a choice, %s, that is not a string" name))

  ;; patch the selection argument for "setbreakpoint"
  (if (and (equal name "setbreakpoint")
	   (null selection))
      (setq selection
	    (save-excursion
	      (vector (energize-buffer-id (current-buffer))
		      (progn (beginning-of-line) (1- (point)))
		      (progn (end-of-line) (1- (point)))))))

  (let* ((buffer (current-buffer))
	 (extent (if extent
		     (if (extentp extent)
			 extent
		       (energize-menu-extent-at (point) buffer))
		   nil)))
    (if (< (cdr (energize-protocol-level)) 7)
	;; old way
	(let ((item (energize-menu-item-for-name extent name)))
	  (if (not item)
	      (error "No Energize command named %s" name))
	  (energize-execute-menu-item-with-selection buffer extent item
						     selection no-confirm))
      ;; new way
      (if (and (null selection)
	       (x-selection-exists-p 'PRIMARY))
	  (setq selection
		(condition-case
		    ()
		    (x-get-selection-internal 'PRIMARY 'STRING)
		  (error ""))))
      (let ((energize-make-many-buffers-visible-should-enqueue-event ()))
	(energize-execute-command-internal buffer
					   extent
					   name
					   selection
					   no-confirm)))))



;;; Sparc function keys.  This isn't the most appropriate place for this...

(defun setup-sparc-function-keys ()
  (if (not (eq window-system 'x))
      nil
    (define-key global-map 'f20 'x-kill-primary-selection)   ; kp_cut
    (define-key global-map 'f16 'x-copy-primary-selection)   ; kp_copy
    (define-key global-map 'f18 'x-yank-clipboard-selection) ; kp_paste
    (define-key global-map 'f29 'scroll-down)		     ; kp_pgup
    (define-key global-map 'f35 'scroll-up)		     ; kp_pgdn
    (define-key global-map 'f27 'beginning-of-buffer)	     ; kp_home
    (define-key global-map 'r13 'end-of-buffer)		     ; kp_end
    ))

(or (memq 'setup-sparc-function-keys window-setup-hook)
    (setq window-setup-hook
	  (cons 'setup-sparc-function-keys window-setup-hook)))
(setup-sparc-function-keys)
(fset 'energize-announce 'play-sound)

;;; Buffer modified the first time hook
;;; Should be in energize-init.el but is here to benefit from the 
;;; add-timeout macro  

(defun energize-check-if-buffer-locked ()
  (if (connected-to-energize-p)
      (energize-with-timeout
       "Asking kernel if buffer is editable..."
       (energize-barf-if-buffer-locked))))

(setq first-change-function 'energize-check-if-buffer-locked)

