[climacs-cvs] CVS esa

[thenriksen]

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

Modified Files:
	esa.lisp 
Log Message:
Use sans-serif font for documentation, `present' command names in
Describe Bindings, remove single linebreaks from docstrings.


--- /project/climacs/cvsroot/esa/esa.lisp	2006/05/10 09:52:05	1.15
+++ /project/climacs/cvsroot/esa/esa.lisp	2006/05/10 16:22:20	1.16
@@ -817,11 +817,9 @@
 	  do (formatting-row (stream) 
 	       (formatting-cell (stream :align-x :right)
 		 (with-text-style (stream '(:sans-serif nil nil))
-		   (format stream "~A"
-			   (or (command-line-name-for-command command
-							      command-table
-							      :errorp nil)
-			       command))))
+		   (present command
+                            `(command-name :command-table ,command-table)
+                            :stream stream)))
 	       (formatting-cell (stream)
 		 (with-drawing-options (stream :ink +dark-blue+
 					       :text-style '(:fix nil nil))
@@ -832,66 +830,90 @@
 			 :height (* length (stream-line-height stream)))
 		  (scroll-extent stream 0 0))))
 
-(defun print-docstring-for-command (command-name &optional (stream *standard-output*))
+(defun print-docstring-for-command (command-name command-table &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)))
+  (declare (ignore command-table))
+  ;; This needs more regex magic. Also, it is only an interim
+  ;; solution.
+  (with-text-style (stream '(:sans-serif nil nil))
+    (let ((command-documentation (or (documentation command-name 'function)
+                                     "This command is not documented.")))
+          
+      ;; Remove single linebreaks but preserve double linebreaks.
+      (loop for char across command-documentation
+         with newline = nil
+         do
+         (if (char-equal char #\Newline)
+             (if newline
+                 (progn
+                   (terpri stream)
+                   (terpri stream)
+                   (setf newline nil))
+                 (setf newline t))
+             (progn
+               (when newline
+                 (princ #\Space stream)
+                 (setf newline nil))
+               (princ char stream)))))))
 
-(defun describe-command-binding-to-stream (gesture-name command &key 
+(defun describe-command-binding-to-stream (gesture 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 
+                           (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)))
+    (with-text-style (stream '(:sans-serif nil nil))
+      (princ "The gesture " stream)
+      (with-text-style (stream '(:fix nil nil))
+        (princ gesture 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 :command-table ,command-table) :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 command-table 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)))
+    (with-text-style (stream '(:sans-serif nil nil))
+      (present command-name `(command-name :command-table ,command-table) :stream stream)
+      (princ " calls the function " stream)
+      (present command-name 'symbol :stream stream)
+      (princ " and is accessible in " stream)
+      (if (command-accessible-in-command-table-p command-name command-table)
+          (present (command-accessible-in-command-table-p command-name command-table)
+                   'command-table
+                   :stream stream)
+          (princ "an unknown command table" stream))
+      (format stream ".~%")
+      (when (plusp (length keystrokes))
+        (princ "It is bound to " stream)
+        (loop for gestures-list on (first keystrokes)
+           do (with-text-style (stream '(:fix nil nil))
+                (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 command-table stream))))
 
 ;;; help commands