1 ;;; list-mode.el --- Major mode for buffers containing lists of items
3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1996, 2000 Ben Wing.
6 ;; Maintainer: XEmacs Development Team
7 ;; Keywords: extensions, dumped
9 ;; This file is part of XEmacs.
11 ;; XEmacs is free software; you can redistribute it and/or modify it
12 ;; under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; XEmacs is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
26 ;;; Synched up with: Not synched
30 ;; This file is dumped with XEmacs.
32 ;; Cleanup, merging with FSF by Ben Wing, January 1996
36 (defvar list-mode-extent nil)
37 (make-variable-buffer-local 'list-mode-extent)
39 (defvar list-mode-map nil
40 "Local map for buffers containing lists of items.")
42 (let ((map (setq list-mode-map (make-sparse-keymap 'list-mode-map))))
44 (define-key map 'button2up 'list-mode-item-mouse-selected)
45 (define-key map 'button2 'undefined)
46 (define-key map "\C-m" 'list-mode-item-keyboard-selected)
48 ;; The following calls to `substitute-key-definition' losed because
49 ;; they were based on an incorrect assumption that `forward-char' and
50 ;; `backward-char' are bound to keys in the global map. This might not
51 ;; be the case if a user binds motion keys to different functions,
52 ;; and was not actually the case since 20.5 beta 28 or around.
54 ;; (substitute-key-definition 'forward-char 'next-list-mode-item map
56 ;; (substitute-key-definition 'backward-char 'previous-list-mode-item map
59 ;; We bind standard keys to motion commands instead.
61 (dolist (key '(kp-right right (control ?f)))
62 (define-key map key 'next-list-mode-item))
63 (dolist (key '(kp-left left (control ?b)))
64 (define-key map key 'previous-list-mode-item))))
66 ;; #### We make list-mode-hook, as well as completion-setup-hook and
67 ;; minibuffer-setup-hook, permanent-local so that it's possible to create
68 ;; buffers in these modes and then set up some buffer-specific
69 ;; customizations without resorting to awful kludges. (The problem here
70 ;; is that when you switch a buffer into a mode, reset-buffer is usually
71 ;; called, which destroys all buffer-local settings that you carefully
72 ;; tried to set up when you created the buffer. Therefore, the only way
73 ;; to set these variables is to use the setup hooks -- but if they are
74 ;; not declared permanent local, then any local hook functions that you
75 ;; put on them (which is exactly what you want to do) also get removed,
76 ;; so you would have to resort to putting a global hook function on the
77 ;; setup hook, and then making sure it gets removed later. I actually
78 ;; added some support for doing this with one-shot hooks, but this is
79 ;; clearly not the correct way to do things, and it fails in some cases,
80 ;; particularly when the buffer gets put into the mode more than once,
81 ;; which typically happens with completion buffers, for example.) In
82 ;; fact, all setup hooks should be made permanent local, but I didn't
83 ;; feel like making a global change like this quite yet. The proper way
84 ;; to do it would be to declare new def-style forms, such as defhook and
85 ;; define-local-setup-hook, which are used to initialize hooks in place
86 ;; of the current generic defvars. --ben
88 (put 'list-mode-hook 'permanent-local t)
89 (defvar list-mode-hook nil
90 "Normal hook run when entering List mode.")
93 "Major mode for buffer containing lists of items."
95 (kill-all-local-variables)
96 (use-local-map list-mode-map)
97 (setq mode-name "List")
98 (setq major-mode 'list-mode)
99 (add-local-hook 'post-command-hook 'set-list-mode-extent)
100 (add-local-hook 'pre-command-hook 'list-mode-extent-pre-hook)
101 (set (make-local-variable 'next-line-add-newlines) nil)
102 (setq list-mode-extent nil)
103 ;; It is visually disconcerting to have the text cursor disappear within list
104 ;; buffers, especially when moving from window to window, so leave it
105 ;; visible. -- Bob Weiner, 06/20/1999
106 ; (set-specifier text-cursor-visible-p nil (current-buffer))
107 (setq buffer-read-only t)
108 (goto-char (point-min))
109 (run-hooks 'list-mode-hook))
111 ;; List mode is suitable only for specially formatted data.
112 (put 'list-mode 'mode-class 'special)
114 (defvar list-mode-extent-old-point nil
115 "The value of point when pre-command-hook is called.
116 Used to determine the direction of motion.")
117 (make-variable-buffer-local 'list-mode-extent-old-point)
119 (defun list-mode-extent-pre-hook ()
120 (setq list-mode-extent-old-point (point))
121 ;(setq atomic-extent-goto-char-p nil)
124 (defun set-list-mode-extent ()
125 "Move to the closest list item and set up the extent for it.
126 This is called from `post-command-hook'."
127 (cond ((get-char-property (point) 'list-mode-item))
128 ((and (> (point) (point-min))
129 (get-char-property (1- (point)) 'list-mode-item))
130 (goto-char (1- (point))))
134 ;this fucks things up more than it helps.
135 ;atomic-extent-goto-char-p as currently defined is all broken,
136 ;since it will be triggered if the command *ever* runs goto-char!
137 ;(if atomic-extent-goto-char-p
139 (if (and list-mode-extent-old-point
140 (> pos list-mode-extent-old-point))
143 (next-list-mode-item dirflag)
144 (or (get-char-property (point) 'list-mode-item)
145 (next-list-mode-item (- dirflag))))))
146 (or (and list-mode-extent
147 (eq (current-buffer) (extent-object list-mode-extent)))
149 (setq list-mode-extent (make-extent nil nil (current-buffer)))
150 (set-extent-face list-mode-extent 'list-mode-item-selected)))
151 (let ((ex (extent-at (point) nil 'list-mode-item nil 'at)))
154 (set-extent-endpoints list-mode-extent
155 (extent-start-position ex)
156 (extent-end-position ex))
157 (auto-show-make-region-visible (extent-start-position ex)
158 (extent-end-position ex)))
159 (detach-extent list-mode-extent))))
161 (defun previous-list-mode-item (n)
162 "Move to the previous item in list-mode."
164 (next-list-mode-item (- n)))
166 (defun next-list-mode-item (n)
167 "Move to the next item in list-mode.
168 With prefix argument N, move N items (negative N means move backward)."
170 (while (and (> n 0) (not (eobp)))
171 (let ((extent (extent-at (point) (current-buffer) 'list-mode-item))
173 ;; If in a completion, move to the end of it.
174 (if extent (goto-char (extent-end-position extent)))
175 ;; Move to start of next one.
176 (or (extent-at (point) (current-buffer) 'list-mode-item)
177 (goto-char (next-single-property-change (point) 'list-mode-item
180 (while (and (< n 0) (not (bobp)))
181 (let ((extent (extent-at (point) (current-buffer) 'list-mode-item))
183 ;; If in a completion, move to the start of it.
184 (if extent (goto-char (extent-start-position extent)))
185 ;; Move to the start of that one.
186 (if (setq extent (extent-at (point) (current-buffer) 'list-mode-item
188 (goto-char (extent-start-position extent))
189 (goto-char (previous-single-property-change
190 (point) 'list-mode-item nil end))
191 (if (setq extent (extent-at (point) (current-buffer) 'list-mode-item
193 (goto-char (extent-start-position extent)))))
196 (defun list-mode-item-selected-1 (extent event)
197 (let ((func (extent-property extent 'list-mode-item-activate-callback))
198 (user-data (extent-property extent 'list-mode-item-user-data)))
200 (funcall func event extent user-data))))
202 ;; we could make these two be just one function, but we want to be
203 ;; able to refer to them in DOC strings.
205 (defun list-mode-item-keyboard-selected ()
207 (list-mode-item-selected-1 (extent-at (point) (current-buffer)
208 'list-mode-item nil 'at)
211 (defun list-mode-item-mouse-selected (event)
213 ;; Sometimes event-closest-point returns nil.
214 ;; So beep instead of bombing.
215 (let ((point (event-closest-point event)))
217 (list-mode-item-selected-1 (extent-at point
219 'list-mode-item nil 'at)
223 (defun add-list-mode-item (start end &optional buffer activate-callback
225 "Add a new list item in list-mode, from START to END in BUFFER.
226 BUFFER defaults to the current buffer.
227 This works by creating an extent for the span of text in question.
228 If ACTIVATE-CALLBACK is non-nil, it should be a function of three
229 arguments (EVENT EXTENT USER-DATA) that will be called when button2
230 is pressed on the extent. USER-DATA comes from the optional
232 (let ((extent (make-extent start end buffer)))
233 (set-extent-property extent 'list-mode-item t)
234 (set-extent-property extent 'start-open t)
235 (if activate-callback
237 (set-extent-property extent 'mouse-face 'highlight)
238 (set-extent-property extent 'list-mode-item-activate-callback
240 (set-extent-property extent 'list-mode-item-user-data user-data)))
244 ;; Define the major mode for lists of completions.
247 (defvar completion-highlight-first-word-only nil
248 "*Completion will only highlight the first blank delimited word if t.
249 If the variable in not t or nil, the string is taken as a regexp to match for end
252 ;; see comment at list-mode-hook.
253 (put 'completion-setup-hook 'permanent-local t)
254 (defvar completion-setup-hook nil
255 "Normal hook run at the end of setting up the text of a completion buffer.
256 When run, the completion buffer is the current buffer.")
258 ; Unnecessary FSFmacs crock. We frob the extents directly in
259 ; display-completion-list, so no "heuristics" like this are necessary.
260 ;(defvar completion-fixup-function nil
261 ; "A function to customize how completions are identified in completion lists.
262 ;`completion-setup-function' calls this function with no arguments
263 ;each time it has found what it thinks is one completion.
264 ;Point is at the end of the completion in the completion list buffer.
265 ;If this function moves point, it can alter the end of that completion.")
267 (defvar completion-default-help-string
269 (if (device-on-window-system-p)
270 (substitute-command-keys
271 "Click \\<list-mode-map>\\[list-mode-item-mouse-selected] on a completion to select it.\n") "")
272 (substitute-command-keys
273 "Type \\<minibuffer-local-completion-map>\\[advertised-switch-to-completions] or \\[switch-to-completions] to move to this buffer, for keyboard selection.\n\n"))
274 "Form the evaluate to get a help string for completion lists.
275 This string is inserted at the beginning of the buffer.
276 See `display-completion-list'.")
278 (defun display-completion-list (completions &rest cl-keys)
279 "Display the list of completions, COMPLETIONS, using `standard-output'.
280 Each element may be just a symbol or string or may be a list of two
281 strings to be printed as if concatenated.
282 Frob a mousable extent onto each completion. This extent has properties
283 'mouse-face (so it highlights when the mouse passes over it) and
284 'list-mode-item (so it can be located).
287 :activate-callback (default is `default-choose-completion')
288 See `add-list-mode-item'.
290 Value passed to activation callback.
292 If non-nil, width to use in displaying the list, instead of the
293 actual window's width.
295 If non-nil, use no more than this many lines, and extend line width as
297 :help-string (default is the value of `completion-default-help-string')
298 Form to evaluate to get a string to insert at the beginning of
299 the completion list buffer. This is evaluated when that buffer
300 is the current buffer and after it has been put into
301 completion-list-mode.
302 :reference-buffer (default is the current buffer)
303 This specifies the value of `completion-reference-buffer' in
304 the completion buffer. This specifies the buffer (normally a
305 minibuffer) that `default-choose-completion' will insert the
308 At the end, run the normal hook `completion-setup-hook'.
309 It can find the completion buffer in `standard-output'.
310 If `completion-highlight-first-word-only' is non-nil, then only the start
311 of the string is highlighted."
312 ;; #### I18N3 should set standard-output to be (temporarily)
313 ;; output-translating.
315 ((:activate-callback 'default-choose-completion)
318 (:help-string completion-default-help-string)
319 (:completion-string "Possible completions are:")
323 (let ((old-buffer (current-buffer))
324 (bufferp (bufferp standard-output)))
326 (set-buffer standard-output))
327 (if (null completions)
329 "There are no possible completions of what you have typed."))
333 ;; This needs fixing for the case of windows
334 ;; that aren't the same width's the frame.
335 ;; Sadly, the window it will appear in is not known
336 ;; until after the text has been made.
338 ;; We have to use last-nonminibuf-frame here
339 ;; and not selected-frame because if a
340 ;; minibuffer-only frame is being used it will
341 ;; be the selected-frame at the point this is
342 ;; run. We keep the selected-frame call around
344 (frame-width (or (last-nonminibuf-frame)
350 ;; Find longest completion
351 (let ((tail completions))
353 (let* ((elt (car tail))
354 (len (cond ((stringp elt)
358 (stringp (car (cdr elt))))
359 (+ (length (car elt))
360 (length (car (cdr elt)))))
362 (signal 'wrong-type-argument
363 (list 'stringp elt))))))
364 (if (> len max-width)
365 (setq max-width len))
366 (setq count (1+ count)
369 (setq max-width (+ 2 max-width)) ; at least two chars between cols
370 (setq old-max-width max-width)
371 (let ((rows (let ((cols (min (/ win-width max-width) count)))
375 ;; re-space the columns
376 (setq max-width (/ win-width cols))
377 (if (/= (% count cols) 0) ; want ceiling...
381 (and cl-window-height
382 (> rows cl-window-height))
383 (setq max-width old-max-width)
384 (setq rows cl-window-height))
385 (when (and (stringp cl-completion-string)
386 (> (length cl-completion-string) 0))
387 (princ (gettext cl-completion-string))
389 (let ((tail completions)
393 completion-highlight-first-word-only)
395 completion-highlight-first-word-only)))
397 (and (> r 0) (terpri))
402 (let ((elt (car tail2)))
406 (while (progn (write-char ?\ )
407 (setq column (1+ column))
408 (< column indent)))))
409 (setq indent (+ indent max-width))
410 (let ((start (point))
412 ;; Frob some mousable extents in there too!
416 (princ (car (cdr elt)))
421 (length (car (cdr elt)))))))
425 (setq column (+ column (length
432 (and completion-highlight-first-word-only
434 (re-search-forward regexp-string end t)
437 nil cl-activate-callback cl-user-data)
439 (setq tail2 (nthcdr rows tail2)))
440 (setq tail (cdr tail)
443 (set-buffer old-buffer)))
445 (let ((mainbuf (or cl-reference-buffer (current-buffer))))
446 (set-buffer standard-output)
447 (completion-list-mode)
448 (make-local-variable 'completion-reference-buffer)
449 (setq completion-reference-buffer mainbuf)
450 ;;; The value 0 is right in most cases, but not for file name completion.
451 ;;; so this has to be turned off.
452 ;;; (setq completion-base-size 0)
453 (goto-char (point-min))
454 (let ((buffer-read-only nil))
455 (insert (eval cl-help-string)))
456 ;; unnecessary FSFmacs crock
458 ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t)
459 ;; (let ((beg (match-beginning 0))
461 ;; (if completion-fixup-function
462 ;; (funcall completion-fixup-function))
463 ;; (put-text-property beg (point) 'mouse-face 'highlight)
464 ;; (put-text-property beg (point) 'list-mode-item t)
465 ;; (goto-char end)))))
468 (set-buffer standard-output)
469 (run-hooks 'completion-setup-hook))))
471 (defvar completion-display-completion-list-function 'display-completion-list
472 "Function to set up the list of completions in the completion buffer.
473 The function is called with one argument, the sorted list of completions.
474 Particular minibuffer interface functions (e.g. `read-file-name') may
475 want to change this. To do that, set a local value for this variable
476 in the minibuffer; that ensures that other minibuffer invocations will
479 (defun minibuffer-completion-help ()
480 "Display a list of possible completions of the current minibuffer contents.
481 The list of completions is determined by calling `all-completions',
482 passing it the current minibuffer contents, the value of
483 `minibuffer-completion-table', and the value of
484 `minibuffer-completion-predicate'. The list is displayed by calling
485 the value of `completion-display-completion-list-function' on the sorted
486 list of completions, with the standard output set to the completion
489 (message "Making completion list...")
490 (let ((completions (all-completions (buffer-string)
491 minibuffer-completion-table
492 minibuffer-completion-predicate)))
494 (if (null completions)
496 (ding nil 'no-completion)
497 (temp-minibuffer-message " [No completions]"))
498 (with-output-to-temp-buffer "*Completions*"
499 (funcall completion-display-completion-list-function
500 (sort completions #'string-lessp))))))
502 (define-derived-mode completion-list-mode list-mode
504 "Major mode for buffers showing lists of possible completions.
505 \\{completion-list-mode-map}"
506 (make-local-variable 'completion-base-size)
507 (setq completion-base-size nil))
509 (let ((map completion-list-mode-map))
510 (define-key map 'button2up 'mouse-choose-completion)
511 (define-key map 'button2 'undefined)
512 (define-key map "\C-m" 'choose-completion)
513 (define-key map "\e\e\e" 'delete-completion-window)
514 (define-key map "\C-g" 'minibuffer-keyboard-quit)
515 (define-key map "q" 'completion-list-mode-quit)
516 (define-key map " " 'completion-switch-to-minibuffer)
517 ;; [Tab] used to switch to the minibuffer but since [space] does that and
518 ;; since most applications in the world use [Tab] to select the next item
519 ;; in a list, do that in the *Completions* buffer too. -- Bob Weiner,
520 ;; BeOpen.com, 06/23/1999.
521 (define-key map "\t" 'next-list-mode-item))
523 (defvar completion-reference-buffer nil
524 "Record the buffer that was current when the completion list was requested.
525 This is a local variable in the completion list buffer.
526 Initial value is nil to avoid some compiler warnings.")
528 (defvar completion-base-size nil
529 "Number of chars at beginning of minibuffer not involved in completion.
530 This is a local variable in the completion list buffer
531 but it talks about the buffer in `completion-reference-buffer'.
532 If this is nil, it means to compare text to determine which part
533 of the tail end of the buffer's text is involved in completion.")
535 ;; These names are referenced in the doc string for `completion-list-mode'.
536 (defalias 'choose-completion 'list-mode-item-keyboard-selected)
537 (defalias 'mouse-choose-completion 'list-mode-item-mouse-selected)
539 (defun delete-completion-window ()
540 "Delete the completion list window.
541 Go to the window from which completion was requested."
543 (let ((buf completion-reference-buffer))
544 (delete-window (selected-window))
545 (if (get-buffer-window buf)
546 (select-window (get-buffer-window buf)))))
548 (defun completion-switch-to-minibuffer ()
549 "Move from a completions buffer to the active minibuffer window."
551 (select-window (minibuffer-window)))
553 (defun completion-list-mode-quit ()
554 "Abort any recursive edit and bury the completions buffer."
557 (abort-recursive-edit)
559 ;; If there was no recursive edit to abort, simply bury the completions
561 (if (eq major-mode 'completion-list-mode) (bury-buffer)))
563 (defun completion-do-in-minibuffer ()
566 (set-buffer (window-buffer (minibuffer-window)))
567 (call-interactively (key-binding (this-command-keys)))))
569 (defun default-choose-completion (event extent buffer)
570 "Click on an alternative in the `*Completions*' buffer to choose it."
571 (and (button-event-p event)
572 ;; Give temporary modes such as isearch a chance to turn off.
573 (run-hooks 'mouse-leave-buffer-hook))
574 (or buffer (setq buffer (symbol-value-in-buffer
575 'completion-reference-buffer
576 (or (and (button-event-p event)
577 (event-buffer event))
579 (save-selected-window
580 (and (button-event-p event)
581 (select-window (event-window event)))
582 (if (and (one-window-p t 'selected-frame)
583 (window-dedicated-p (selected-window)))
584 ;; This is a special buffer's frame
585 (iconify-frame (selected-frame))
586 (or (window-dedicated-p (selected-window))
588 (choose-completion-string (extent-string extent)
590 completion-base-size))
592 ;; Delete the longest partial match for STRING
593 ;; that can be found before POINT.
594 (defun choose-completion-delete-max-match (string)
595 (let ((len (min (length string)
596 (- (point) (point-min)))))
597 (goto-char (- (point) (length string)))
598 (if completion-ignore-case
599 (setq string (downcase string)))
600 (while (and (> len 0)
601 (let ((tail (buffer-substring (point)
603 (if completion-ignore-case
604 (setq tail (downcase tail)))
605 (not (string= tail (substring string 0 len)))))
610 ;; Switch to BUFFER and insert the completion choice CHOICE.
611 ;; BASE-SIZE, if non-nil, says how many characters of BUFFER's text
612 ;; to keep. If it is nil, use choose-completion-delete-max-match instead.
613 (defun choose-completion-string (choice &optional buffer base-size)
614 (let ((buffer (or buffer completion-reference-buffer)))
615 ;; If BUFFER is a minibuffer, barf unless it's the currently
616 ;; active minibuffer.
617 (if (and (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer))
618 (or (not (active-minibuffer-window))
620 (window-buffer (active-minibuffer-window))))))
621 (error "Minibuffer is not active for completion")
622 ;; Insert the completion into the buffer where completion was requested.
625 (delete-region (+ base-size (point-min)) (point))
626 (choose-completion-delete-max-match choice))
628 (remove-text-properties (- (point) (length choice)) (point)
630 ;; Update point in the window that BUFFER is showing in.
631 (let ((window (get-buffer-window buffer t)))
632 (set-window-point window (point)))
633 ;; If completing for the minibuffer, exit it with this choice.
634 (and (equal buffer (window-buffer (minibuffer-window)))
635 minibuffer-completion-table
636 (exit-minibuffer)))))
638 (define-key minibuffer-local-completion-map [prior]
639 'switch-to-completions)
640 (define-key minibuffer-local-must-match-map [prior]
641 'switch-to-completions)
642 (define-key minibuffer-local-completion-map "\M-v"
643 'advertised-switch-to-completions)
644 (define-key minibuffer-local-must-match-map "\M-v"
645 'advertised-switch-to-completions)
647 (defalias 'advertised-switch-to-completions 'switch-to-completions)
648 (defun switch-to-completions ()
649 "Select the completion list window."
651 ;; Make sure we have a completions window.
652 (or (get-buffer-window "*Completions*")
653 (minibuffer-completion-help))
654 (if (not (get-buffer-window "*Completions*"))
656 (select-window (get-buffer-window "*Completions*"))
657 (goto-char (next-single-property-change (point-min) 'list-mode-item nil
660 ;;; list-mode.el ends here
662 ;; [tomo] ad-hoc method to avoid slowness of the first completion
663 (if (featurep 'utf-2000)
665 (completion-list-mode)))