Re: window groups

[Stefan Monnier <monnier@iro.umontreal.ca>]

> That was one thing that has annoyed me since switching from XEmacs.  I also
> miss the compact disiplay of hyper-apropos bound to C-h a in XEmacs.  Here
> is an example as was recently asked for:
<as well as>
> The key virtue is columnar layout which is visually easier to parse and
> faster to navigate.  My final sample shows that gnu emacs does not eschew
> long lines.

The patch below adds an apropos-compact-layout customization to get
something similar to what XEmacs provides.  Check it out,


        Stefan



--- apropos.el.~1.127.~	2008-05-06 23:35:06.000000000 -0400
+++ apropos.el	2008-06-07 22:31:01.000000000 -0400
@@ -190,6 +190,7 @@
 
 (define-button-type 'apropos-function
   'apropos-label "Function"
+  'apropos-short-label "<f>"
   'help-echo "mouse-2, RET: Display more help on this function"
   'follow-link t
   'action (lambda (button)
@@ -197,6 +198,7 @@
 
 (define-button-type 'apropos-macro
   'apropos-label "Macro"
+  'apropos-short-label "<m>"
   'help-echo "mouse-2, RET: Display more help on this macro"
   'follow-link t
   'action (lambda (button)
@@ -204,6 +206,7 @@
 
 (define-button-type 'apropos-command
   'apropos-label "Command"
+  'apropos-short-label "<c>"
   'help-echo "mouse-2, RET: Display more help on this command"
   'follow-link t
   'action (lambda (button)
@@ -216,6 +219,7 @@
 ;; Likewise for `customize-face-other-window'.
 (define-button-type 'apropos-variable
   'apropos-label "Variable"
+  'apropos-short-label "<v>"
   'help-echo "mouse-2, RET: Display more help on this variable"
   'follow-link t
   'action (lambda (button)
@@ -223,6 +227,7 @@
 
 (define-button-type 'apropos-face
   'apropos-label "Face"
+  'apropos-short-label "<F>"
   'help-echo "mouse-2, RET: Display more help on this face"
   'follow-link t
   'action (lambda (button)
@@ -230,6 +235,7 @@
 
 (define-button-type 'apropos-group
   'apropos-label "Group"
+  'apropos-short-label "<g>"
   'help-echo "mouse-2, RET: Display more help on this group"
   'follow-link t
   'action (lambda (button)
@@ -238,6 +244,7 @@
 
 (define-button-type 'apropos-widget
   'apropos-label "Widget"
+  'apropos-short-label "<w>"
   'help-echo "mouse-2, RET: Display more help on this widget"
   'follow-link t
   'action (lambda (button)
@@ -245,6 +252,7 @@
 
 (define-button-type 'apropos-plist
   'apropos-label "Plist"
+  'apropos-short-label "<p>"
   'help-echo "mouse-2, RET: Display more help on this plist"
   'follow-link t
   'action (lambda (button)
@@ -402,6 +410,10 @@
 
 \\{apropos-mode-map}")
 
+(defvar apropos-multi-type t
+  "If non-nil, this apropos query concerns multiple types.
+This is used to decide whether to print the result's type or not.")
+
 ;;;###autoload
 (defun apropos-variable (pattern &optional do-all)
   "Show user variables that match PATTERN.
@@ -487,7 +499,8 @@
 					  (string-match "\n" doc)))))))
 	(setcar (cdr (car p)) score)
 	(setq p (cdr p))))
-    (and (apropos-print t nil nil t)
+    (and (let ((apropos-multi-type do-all))
+           (apropos-print t nil nil t))
 	 message
 	 (message "%s" message))))
 
@@ -617,7 +658,8 @@
 						     (apropos-score-str p))
 						  f v p)
 					    apropos-accumulator))))))
-  (apropos-print nil "\n----------------\n"))
+   (let ((apropos-multi-type do-all))
+     (apropos-print nil "\n----------------\n")))
 
 
 ;;;###autoload
@@ -844,6 +886,9 @@
       nil
     function))
 
+(defcustom apropos-compact-layout nil
+  "If non-nil, use a single line per binding."
+  :type 'boolean)
 
 (defun apropos-print (do-keys spacing &optional text nosubst)
   "Output result of apropos searching into buffer `*Apropos*'.
@@ -885,12 +930,10 @@
 		(substitute-command-keys
 		 "and type \\[apropos-follow] to get full documentation.\n\n"))
 	(if text (insert text "\n\n"))
-	(while (consp p)
+	(dolist (apropos-item p)
 	  (when (and spacing (not (bobp)))
 	    (princ spacing))
-	  (setq apropos-item (car p)
-		symbol (car apropos-item)
-		p (cdr p))
+	  (setq symbol (car apropos-item))
 	  ;; Insert dummy score element for backwards compatibility with 21.x
 	  ;; apropos-item format.
 	  (if (not (numberp (cadr apropos-item)))
@@ -905,22 +948,25 @@
 			      'face apropos-symbol-face)
 	  (if (and (eq apropos-sort-by-scores 'verbose)
 		   (cadr apropos-item))
-	      (insert " (" (number-to-string (cadr apropos-item)) ") "))
+	      (insert " (" (number-to-string (cadr apropos-item)) ")"))
 	  ;; Calculate key-bindings if we want them.
+          (unless apropos-compact-layout
 	  (and do-keys
 	       (commandp symbol)
 	       (not (eq symbol 'self-insert-command))
 	       (indent-to 30 1)
 	       (if (let ((keys
-			  (save-excursion
-			    (set-buffer old-buffer)
+                            (with-current-buffer old-buffer
 			    (where-is-internal symbol)))
 			 filtered)
 		     ;; Copy over the list of key sequences,
 		     ;; omitting any that contain a buffer or a frame.
-		     (while keys
-		       (let ((key (car keys))
-			     (i 0)
+                       ;; FIXME: Why omit keys that contain buffers and
+                       ;; frames?  This looks like a bad workaround rather
+                       ;; than a proper fix.  Does anybod know what problem
+                       ;; this is trying to address?  --Stef
+                       (dolist (key keys)
+                         (let ((i 0)
 			     loser)
 			 (while (< i (length key))
 			   (if (or (framep (aref key i))
@@ -928,8 +974,7 @@
 			       (setq loser t))
 			   (setq i (1+ i)))
 			 (or loser
-			     (setq filtered (cons key filtered))))
-		       (setq keys (cdr keys)))
+                               (push key filtered))))
 		     (setq item filtered))
 		   ;; Convert the remaining keys to a string and insert.
 		   (insert
@@ -950,7 +995,7 @@
 				      'face apropos-keybinding-face)
 		   (put-text-property (- (point) 3) (point)
 				      'face apropos-keybinding-face))))
-	  (terpri)
+            (terpri))
 	  (apropos-print-doc 2
 			     (if (commandp symbol)
 				 'apropos-command
@@ -963,11 +1008,12 @@
 	  (apropos-print-doc 6 'apropos-face t)
 	  (apropos-print-doc 5 'apropos-widget t)
 	  (apropos-print-doc 4 'apropos-plist nil))
+        (set (make-local-variable 'truncate-partial-width-windows) t)
+        (set (make-local-variable 'truncate-lines) t)
 	(setq buffer-read-only t))))
   (prog1 apropos-accumulator
     (setq apropos-accumulator ())))	; permit gc
 
-
 (defun apropos-macrop (symbol)
   "Return t if SYMBOL is a Lisp macro."
   (and (fboundp symbol)
@@ -980,20 +1026,26 @@
 
 
 (defun apropos-print-doc (i type do-keys)
-  (if (stringp (setq i (nth i apropos-item)))
-      (progn
-	(insert "  ")
-	(insert-text-button (button-type-get type 'apropos-label)
+  (when (stringp (setq i (nth i apropos-item)))
+    (if apropos-compact-layout
+        (insert (propertize "\t" 'display '(space :align-to 32)) " ")
+      (insert "  "))
+    ;; If the query is only for a single type, there's
+    ;; no point writing it over and over again.
+    (when apropos-multi-type
+      (insert-text-button (button-type-get type
+                                           (if apropos-compact-layout
+                                               'apropos-short-label
+                                             'apropos-label))
 			    'type type
 			    ;; Can't use the default button face, since
 			    ;; user may have changed the variable!
 			    ;; Just say `no' to variables containing faces!
 			    'face apropos-label-face
 			    'apropos-symbol (car apropos-item))
-	(insert ": ")
+      (insert (if apropos-compact-layout " " ": ")))
 	(insert (if do-keys (substitute-command-keys i) i))
-	(or (bolp) (terpri)))))
-
+    (or (bolp) (terpri))))
 
 (defun apropos-follow ()
   "Invokes any button at point, otherwise invokes the nearest label button."