[climacs-cvs] CVS climacs

[thenriksen]

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv632

Modified Files:
	gui.lisp 
Log Message:
Added new help commands.


--- /project/climacs/cvsroot/climacs/gui.lisp	2006/05/01 18:36:41	1.210
+++ /project/climacs/cvsroot/climacs/gui.lisp	2006/05/02 18:02:15	1.211
@@ -478,3 +478,49 @@
 (set-key 'com-kill-buffer
 	 'pane-table
 	 '((#\x :control) (#\k)))
+
+;;; Commands for calling the ESA help functions.
+
+(define-command (com-describe-binding :name t :command-table help-table)
+    ()
+  "Display documentation for the command invoked by a giving gesture sequence. 
+When invoked, this command will wait for user input. If the user inputs a gesture 
+sequence bound to a command available in the syntax of the current buffer,
+documentation and other details will be displayed in a typeout pane."
+  (let ((command-table (esa:find-applicable-command-table *application-frame*)))
+    (multiple-value-bind (command gestures)
+        (esa::read-gestures-for-help command-table)
+      (let ((gesture-name (format nil "~{~A~#[~; ~; ~]~}"
+                                  (mapcar #'esa:gesture-name gestures))))
+        (if command
+            (let ((out-stream (typeout-window (format nil "~10THelp: Describe Binding for ~A" gesture-name))))
+              (describe-command-binding-to-stream gesture-name command
+                                                  :command-table command-table
+                                                  :stream out-stream))
+            (display-message "Unbound gesture: ~A" gesture-name))))))
+
+(define-command (com-describe-command :name t :command-table help-table)
+    ((command 'command-name))
+  "Display documentation for the given command."
+  (unless command
+    (setf command (accept 'command-name)))
+  (let ((command-table (esa::find-applicable-command-table *application-frame*))
+        (out-stream (typeout-window (format nil "~10THelp: Describe Command for ~A" command))))
+    (describe-command-to-stream command
+                                :command-table command-table
+                                :stream out-stream)))
+
+(set-key 'com-describe-binding
+         'help-table
+         '((#\h :control) (#\k)))
+
+(set-key '(com-describe-command nil)
+         'help-table
+         '((#\h :control) (#\f)))
+
+(define-presentation-to-command-translator describe-command
+    (command-name com-describe-command help-table
+                  :gesture :select
+                  :documentation "Describe command")
+    (object)
+    (list object))
\ No newline at end of file