[climacs-cvs] CVS esa

[thenriksen]

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

Modified Files:
	packages.lisp esa.lisp 
Log Message:
Added command and command-binding description functions.


--- /project/climacs/cvsroot/esa/packages.lisp	2006/04/08 23:36:44	1.2
+++ /project/climacs/cvsroot/esa/packages.lisp	2006/05/02 18:01:49	1.3
@@ -9,6 +9,9 @@
            #:esa-top-level #:simple-command-loop
            #:global-esa-table #:keyboard-macro-table
            #:help-table
+           #:describe-command-binding-to-stream
+           #:describe-command-to-stream
+           #:gesture-name
            #:set-key
            #:find-applicable-command-table))
 
--- /project/climacs/cvsroot/esa/esa.lisp	2006/04/30 11:59:03	1.8
+++ /project/climacs/cvsroot/esa/esa.lisp	2006/05/02 18:01:49	1.9
@@ -639,6 +639,67 @@
 			 :height (* length (stream-line-height stream)))
 		  (scroll-extent stream 0 0))))
 
+(defun print-docstring-for-command (command-name &optional (stream *standard-output*))
+  "Print documentation for `command-name', which should 
+   be a symbol bound to a function, to `stream. If no 
+   documentation can be found, this fact will be printed to the stream."
+  ;; Eventually, we should try to parse the docstring and hyperlink
+  ;; it to other relevant symbols.
+  (let ((command-documentation (or (documentation command-name 'function)
+                                   "This command is not documented.")))
+    (princ command-documentation stream)))
+
+(defun describe-command-binding-to-stream (gesture-name command &key 
+                                           (command-table (find-applicable-command-table *application-frame*))
+                                           (stream *standard-output*))
+  "Describe `command' as invoked by `gesture' to `stream'."
+  (let* ((command-name (if (listp command)
+                          (first command)
+                          command))        
+        (command-args (if (listp command)
+                          (rest command)))
+        (real-command-table (or (command-accessible-in-command-table-p 
+                                  command-name
+                                  command-table)
+                                 command-table)))
+    (princ "The gesture " stream)
+    (with-text-face (stream :italic)
+                    (princ gesture-name stream))
+    (princ " is bound to the command " stream)
+    (if (command-present-in-command-table-p command-name real-command-table)
+        (present command-name 'command-name :stream stream)
+        (present command-name 'symbol :stream stream))
+    (princ " in " stream)
+    (present real-command-table 'command-table :stream stream)
+    (format stream ".~%")
+    (when command-args
+      (apply #'format stream "This binding invokes the command with the arguments ~@{~A~^, ~}.~%" command-args))
+    (terpri stream)
+    (print-docstring-for-command command-name stream)))
+
+(defun describe-command-to-stream (command-name &key 
+                                   (command-table (esa:find-applicable-command-table *application-frame*))
+                                   (stream *standard-output*))
+  "Describe `command' to `stream'."
+  (let ((keystrokes (find-keystrokes-for-command-with-inheritance command-name command-table)))
+    (present command-name 'command-name :stream stream)
+    (princ " calls the function " stream)
+    (present command-name 'symbol :stream stream)
+    (princ " and is accessible in " stream)
+    (present (command-accessible-in-command-table-p command-name command-table) 'command-table
+             :stream stream)
+    (format stream ".~%")
+    (when (plusp (length keystrokes))
+      (princ "It is bound to " stream)
+      (loop for gestures-list on (first keystrokes)
+            do (format stream "~{~A~^ ~}"
+                       (mapcar #'gesture-name (reverse (first gestures-list))))
+            when (not (null (rest gestures-list)))
+            do (princ ", " stream)))
+    (terpri stream)
+    (terpri stream)
+    (print-docstring-for-command command-name stream)))
+
 ;;; help commands
 
 (define-command-table help-table)