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: SXEmacs Development Team
7 ;; Keywords: extensions, dumped
9 ;; This file is part of SXEmacs.
11 ;; SXEmacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; SXEmacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Synched up with: Not synched
28 ;; This file is dumped with SXEmacs.
30 ;; Cleanup, merging with FSF by Ben Wing, January 1996
34 (defvar list-mode-extent nil)
35 (make-variable-buffer-local 'list-mode-extent)
37 (defvar list-mode-map nil
38 "Local map for buffers containing lists of items.")
40 (let ((map (setq list-mode-map (make-sparse-keymap 'list-mode-map))))
42 (define-key map 'button2up 'list-mode-item-mouse-selected)
43 (define-key map 'button2 'undefined)
44 (define-key map "\C-m" 'list-mode-item-keyboard-selected)
46 ;; The following calls to `substitute-key-definition' losed because
47 ;; they were based on an incorrect assumption that `forward-char' and
48 ;; `backward-char' are bound to keys in the global map. This might not
49 ;; be the case if a user binds motion keys to different functions,
50 ;; and was not actually the case since 20.5 beta 28 or around.
52 ;; (substitute-key-definition 'forward-char 'next-list-mode-item map
54 ;; (substitute-key-definition 'backward-char 'previous-list-mode-item map
57 ;; We bind standard keys to motion commands instead.
59 (dolist (key '(kp-right right (control ?f)))
60 (define-key map key 'next-list-mode-item))
61 (dolist (key '(kp-left left (control ?b)))
62 (define-key map key 'previous-list-mode-item))))
64 ;; #### We make list-mode-hook, as well as completion-setup-hook and
65 ;; minibuffer-setup-hook, permanent-local so that it's possible to create
66 ;; buffers in these modes and then set up some buffer-specific
67 ;; customizations without resorting to awful kludges. (The problem here
68 ;; is that when you switch a buffer into a mode, reset-buffer is usually
69 ;; called, which destroys all buffer-local settings that you carefully
70 ;; tried to set up when you created the buffer. Therefore, the only way
71 ;; to set these variables is to use the setup hooks -- but if they are
72 ;; not declared permanent local, then any local hook functions that you
73 ;; put on them (which is exactly what you want to do) also get removed,
74 ;; so you would have to resort to putting a global hook function on the
75 ;; setup hook, and then making sure it gets removed later. I actually
76 ;; added some support for doing this with one-shot hooks, but this is
77 ;; clearly not the correct way to do things, and it fails in some cases,
78 ;; particularly when the buffer gets put into the mode more than once,
79 ;; which typically happens with completion buffers, for example.) In
80 ;; fact, all setup hooks should be made permanent local, but I didn't
81 ;; feel like making a global change like this quite yet. The proper way
82 ;; to do it would be to declare new def-style forms, such as defhook and
83 ;; define-local-setup-hook, which are used to initialize hooks in place
84 ;; of the current generic defvars. --ben
86 (put 'list-mode-hook 'permanent-local t)
87 (defvar list-mode-hook nil
88 "Normal hook run when entering List mode.")
91 "Major mode for buffer containing lists of items."
93 (kill-all-local-variables)
94 (use-local-map list-mode-map)
95 (setq mode-name "List")
96 (setq major-mode 'list-mode)
97 (add-local-hook 'post-command-hook 'set-list-mode-extent)
98 (add-local-hook 'pre-command-hook 'list-mode-extent-pre-hook)
99 (set (make-local-variable 'next-line-add-newlines) nil)
100 (setq list-mode-extent nil)
101 ;; It is visually disconcerting to have the text cursor disappear within list
102 ;; buffers, especially when moving from window to window, so leave it
103 ;; visible. -- Bob Weiner, 06/20/1999
104 ; (set-specifier text-cursor-visible-p nil (current-buffer))
105 (setq buffer-read-only t)
106 (goto-char (point-min))
107 (run-hooks 'list-mode-hook))
109 ;; List mode is suitable only for specially formatted data.
110 (put 'list-mode 'mode-class 'special)
112 (defvar list-mode-extent-old-point nil
113 "The value of point when pre-command-hook is called.
114 Used to determine the direction of motion.")
115 (make-variable-buffer-local 'list-mode-extent-old-point)
117 (defun list-mode-extent-pre-hook ()
118 (setq list-mode-extent-old-point (point))
119 ;(setq atomic-extent-goto-char-p nil)
122 (defun set-list-mode-extent ()
123 "Move to the closest list item and set up the extent for it.
124 This is called from `post-command-hook'."
125 (cond ((get-char-property (point) 'list-mode-item))
126 ((and (> (point) (point-min))
127 (get-char-property (1- (point)) 'list-mode-item))
128 (goto-char (1- (point))))
132 ;this fucks things up more than it helps.
133 ;atomic-extent-goto-char-p as currently defined is all broken,
134 ;since it will be triggered if the command *ever* runs goto-char!
135 ;(if atomic-extent-goto-char-p
137 (if (and list-mode-extent-old-point
138 (> pos list-mode-extent-old-point))
141 (next-list-mode-item dirflag)
142 (or (get-char-property (point) 'list-mode-item)
143 (next-list-mode-item (- dirflag))))))
144 (or (and list-mode-extent
145 (eq (current-buffer) (extent-object list-mode-extent)))
147 (setq list-mode-extent (make-extent nil nil (current-buffer)))
148 (set-extent-face list-mode-extent 'list-mode-item-selected)))
149 (let ((ex (extent-at (point) nil 'list-mode-item nil 'at)))
152 (set-extent-endpoints list-mode-extent
153 (extent-start-position ex)
154 (extent-end-position ex))
155 (auto-show-make-region-visible (extent-start-position ex)
156 (extent-end-position ex)))
157 (detach-extent list-mode-extent))))
159 (defun previous-list-mode-item (n)
160 "Move to the previous item in list-mode."
162 (next-list-mode-item (- n)))
164 (defun next-list-mode-item (n)
165 "Move to the next item in list-mode.
166 With prefix argument N, move N items (negative N means move backward)."
168 (while (and (> n 0) (not (eobp)))
169 (let ((extent (extent-at (point) (current-buffer) 'list-mode-item))
171 ;; If in a completion, move to the end of it.
172 (if extent (goto-char (extent-end-position extent)))
173 ;; Move to start of next one.
174 (or (extent-at (point) (current-buffer) 'list-mode-item)
175 (goto-char (next-single-property-change (point) 'list-mode-item
178 (while (and (< n 0) (not (bobp)))
179 (let ((extent (extent-at (point) (current-buffer) 'list-mode-item))
181 ;; If in a completion, move to the start of it.
182 (if extent (goto-char (extent-start-position extent)))
183 ;; Move to the start of that one.
184 (if (setq extent (extent-at (point) (current-buffer) 'list-mode-item
186 (goto-char (extent-start-position extent))
187 (goto-char (previous-single-property-change
188 (point) 'list-mode-item nil end))
189 (if (setq extent (extent-at (point) (current-buffer) 'list-mode-item
191 (goto-char (extent-start-position extent)))))
194 (defun list-mode-item-selected-1 (extent event)
195 (let ((func (extent-property extent 'list-mode-item-activate-callback))
196 (user-data (extent-property extent 'list-mode-item-user-data)))
198 (funcall func event extent user-data))))
200 ;; we could make these two be just one function, but we want to be
201 ;; able to refer to them in DOC strings.
203 (defun list-mode-item-keyboard-selected ()
205 (list-mode-item-selected-1 (extent-at (point) (current-buffer)
206 'list-mode-item nil 'at)
209 (defun list-mode-item-mouse-selected (event)
211 ;; Sometimes event-closest-point returns nil.
212 ;; So beep instead of bombing.
213 (let ((point (event-closest-point event)))
215 (list-mode-item-selected-1 (extent-at point
217 'list-mode-item nil 'at)
221 (defun add-list-mode-item (start end &optional buffer activate-callback
223 "Add a new list item in list-mode, from START to END in BUFFER.
224 BUFFER defaults to the current buffer.
225 This works by creating an extent for the span of text in question.
226 If ACTIVATE-CALLBACK is non-nil, it should be a function of three
227 arguments (EVENT EXTENT USER-DATA) that will be called when button2
228 is pressed on the extent. USER-DATA comes from the optional
230 (let ((extent (make-extent start end buffer)))
231 (set-extent-property extent 'list-mode-item t)
232 (set-extent-property extent 'start-open t)
233 (if activate-callback
235 (set-extent-property extent 'mouse-face 'highlight)
236 (set-extent-property extent 'list-mode-item-activate-callback
238 (set-extent-property extent 'list-mode-item-user-data user-data)))
242 ;; Define the major mode for lists of completions.
245 (defvar completion-highlight-first-word-only nil
246 "*Completion will only highlight the first blank delimited word if t.
247 If the variable in not t or nil, the string is taken as a regexp to match for end
250 ;; see comment at list-mode-hook.
251 (put 'completion-setup-hook 'permanent-local t)
252 (defvar completion-setup-hook nil
253 "Normal hook run at the end of setting up the text of a completion buffer.
254 When run, the completion buffer is the current buffer.")
256 ; Unnecessary FSFmacs crock. We frob the extents directly in
257 ; display-completion-list, so no "heuristics" like this are necessary.
258 ;(defvar completion-fixup-function nil
259 ; "A function to customize how completions are identified in completion lists.
260 ;`completion-setup-function' calls this function with no arguments
261 ;each time it has found what it thinks is one completion.
262 ;Point is at the end of the completion in the completion list buffer.
263 ;If this function moves point, it can alter the end of that completion.")
265 (defvar completion-default-help-string
267 (if (device-on-window-system-p)
268 (substitute-command-keys
269 "Click \\<list-mode-map>\\[list-mode-item-mouse-selected] on a completion to select it.\n") "")
270 (substitute-command-keys
271 "Type \\<minibuffer-local-completion-map>\\[advertised-switch-to-completions] or \\[switch-to-completions] to move to this buffer, for keyboard selection.\n\n"))
272 "Form the evaluate to get a help string for completion lists.
273 This string is inserted at the beginning of the buffer.
274 See `display-completion-list'.")
276 (defun display-completion-list (completions &rest cl-keys)
277 "Display the list of completions, COMPLETIONS, using `standard-output'.
278 Each element may be just a symbol or string or may be a list of two
279 strings to be printed as if concatenated.
280 Frob a mousable extent onto each completion. This extent has properties
281 'mouse-face (so it highlights when the mouse passes over it) and
282 'list-mode-item (so it can be located).
285 :activate-callback (default is `default-choose-completion')
286 See `add-list-mode-item'.
288 Value passed to activation callback.
290 If non-nil, width to use in displaying the list, instead of the
291 actual window's width.
293 If non-nil, use no more than this many lines, and extend line width as
295 :help-string (default is the value of `completion-default-help-string')
296 Form to evaluate to get a string to insert at the beginning of
297 the completion list buffer. This is evaluated when that buffer
298 is the current buffer and after it has been put into
299 completion-list-mode.
300 :reference-buffer (default is the current buffer)
301 This specifies the value of `completion-reference-buffer' in
302 the completion buffer. This specifies the buffer (normally a
303 minibuffer) that `default-choose-completion' will insert the
306 At the end, run the normal hook `completion-setup-hook'.
307 It can find the completion buffer in `standard-output'.
308 If `completion-highlight-first-word-only' is non-nil, then only the start
309 of the string is highlighted."
310 ;; #### I18N3 should set standard-output to be (temporarily)
311 ;; output-translating.
313 ((:activate-callback 'default-choose-completion)
316 (:help-string completion-default-help-string)
317 (:completion-string "Possible completions are:")
321 (let ((old-buffer (current-buffer))
322 (bufferp (bufferp standard-output)))
324 (set-buffer standard-output))
325 (if (null completions)
327 "There are no possible completions of what you have typed."))
331 ;; We have to use last-nonminibuf-frame here
332 ;; and not selected-frame because if a
333 ;; minibuffer-only frame is being used it will
334 ;; be the selected-frame at the point this is
335 ;; run. We keep the selected-frame call around
337 (window-width (get-lru-window (last-nonminibuf-frame)))
342 ;; Find longest completion
343 (let ((tail completions))
345 (let* ((elt (car tail))
346 (len (cond ((stringp elt)
350 (stringp (car (cdr elt))))
351 (+ (length (car elt))
352 (length (car (cdr elt)))))
354 (signal 'wrong-type-argument
355 (list 'stringp elt))))))
356 (if (> len max-width)
357 (setq max-width len))
358 (setq count (1+ count)
361 (setq max-width (+ 2 max-width)) ; at least two chars between cols
362 (setq old-max-width max-width)
363 (let ((rows (let ((cols (min (/ win-width max-width) count)))
367 ;; re-space the columns
368 (setq max-width (/ win-width cols))
369 (if (/= (% count cols) 0) ; want ceiling...
373 (and cl-window-height
374 (> rows cl-window-height))
375 (setq max-width old-max-width)
376 (setq rows cl-window-height))
377 (when (and (stringp cl-completion-string)
378 (> (length cl-completion-string) 0))
379 (princ (gettext cl-completion-string))
381 (let ((tail completions)
385 completion-highlight-first-word-only)
387 completion-highlight-first-word-only)))
389 (and (> r 0) (terpri))
394 (let ((elt (car tail2)))
398 (while (progn (write-char ?\ )
399 (setq column (1+ column))
400 (< column indent)))))
401 (setq indent (+ indent max-width))
402 (let ((start (point))
404 ;; Frob some mousable extents in there too!
408 (princ (car (cdr elt)))
413 (length (car (cdr elt)))))))
417 (setq column (+ column (length
424 (and completion-highlight-first-word-only
426 (re-search-forward regexp-string end t)
429 nil cl-activate-callback cl-user-data)
431 (setq tail2 (nthcdr rows tail2)))
432 (setq tail (cdr tail)
435 (set-buffer old-buffer)))
437 (let ((mainbuf (or cl-reference-buffer (current-buffer))))
438 (set-buffer standard-output)
439 (completion-list-mode)
440 (make-local-variable 'completion-reference-buffer)
441 (setq completion-reference-buffer mainbuf)
442 ;;; The value 0 is right in most cases, but not for file name completion.
443 ;;; so this has to be turned off.
444 ;;; (setq completion-base-size 0)
445 (goto-char (point-min))
446 (let ((buffer-read-only nil))
447 (insert (eval cl-help-string)))
448 ;; unnecessary FSFmacs crock
450 ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t)
451 ;; (let ((beg (match-beginning 0))
453 ;; (if completion-fixup-function
454 ;; (funcall completion-fixup-function))
455 ;; (put-text-property beg (point) 'mouse-face 'highlight)
456 ;; (put-text-property beg (point) 'list-mode-item t)
457 ;; (goto-char end)))))
460 (set-buffer standard-output)
461 (run-hooks 'completion-setup-hook))))
463 (defvar completion-display-completion-list-function 'display-completion-list
464 "Function to set up the list of completions in the completion buffer.
465 The function is called with one argument, the sorted list of completions.
466 Particular minibuffer interface functions (e.g. `read-file-name') may
467 want to change this. To do that, set a local value for this variable
468 in the minibuffer; that ensures that other minibuffer invocations will
471 (defun minibuffer-completion-help ()
472 "Display a list of possible completions of the current minibuffer contents.
473 The list of completions is determined by calling `all-completions',
474 passing it the current minibuffer contents, the value of
475 `minibuffer-completion-table', and the value of
476 `minibuffer-completion-predicate'. The list is displayed by calling
477 the value of `completion-display-completion-list-function' on the sorted
478 list of completions, with the standard output set to the completion
481 (message "Making completion list...")
482 (let ((completions (all-completions (buffer-string)
483 minibuffer-completion-table
484 minibuffer-completion-predicate)))
486 (if (null completions)
488 (ding nil 'no-completion)
489 (temp-minibuffer-message " [No completions]"))
490 (with-output-to-temp-buffer "*Completions*"
491 (funcall completion-display-completion-list-function
492 (sort completions #'string-lessp))))))
494 (define-derived-mode completion-list-mode list-mode
496 "Major mode for buffers showing lists of possible completions.
497 \\{completion-list-mode-map}"
498 (make-local-variable 'completion-base-size)
499 (setq completion-base-size nil))
501 (let ((map completion-list-mode-map))
502 (define-key map 'button2up 'mouse-choose-completion)
503 (define-key map 'button2 'undefined)
504 (define-key map "\C-m" 'choose-completion)
505 (define-key map "\e\e\e" 'delete-completion-window)
506 (define-key map "\C-g" 'minibuffer-keyboard-quit)
507 (define-key map "q" 'completion-list-mode-quit)
508 (define-key map " " 'completion-switch-to-minibuffer)
509 ;; [Tab] used to switch to the minibuffer but since [space] does that and
510 ;; since most applications in the world use [Tab] to select the next item
511 ;; in a list, do that in the *Completions* buffer too. -- Bob Weiner,
512 ;; BeOpen.com, 06/23/1999.
513 (define-key map "\t" 'next-list-mode-item))
515 (defvar completion-reference-buffer nil
516 "Record the buffer that was current when the completion list was requested.
517 This is a local variable in the completion list buffer.
518 Initial value is nil to avoid some compiler warnings.")
520 (defvar completion-base-size nil
521 "Number of chars at beginning of minibuffer not involved in completion.
522 This is a local variable in the completion list buffer
523 but it talks about the buffer in `completion-reference-buffer'.
524 If this is nil, it means to compare text to determine which part
525 of the tail end of the buffer's text is involved in completion.")
527 ;; These names are referenced in the doc string for `completion-list-mode'.
528 (defalias 'choose-completion 'list-mode-item-keyboard-selected)
529 (defalias 'mouse-choose-completion 'list-mode-item-mouse-selected)
531 (defun delete-completion-window ()
532 "Delete the completion list window.
533 Go to the window from which completion was requested."
535 (let ((buf completion-reference-buffer))
536 (delete-window (selected-window))
537 (if (get-buffer-window buf)
538 (select-window (get-buffer-window buf)))))
540 (defun completion-switch-to-minibuffer ()
541 "Move from a completions buffer to the active minibuffer window."
543 (select-window (minibuffer-window)))
545 (defun completion-list-mode-quit ()
546 "Abort any recursive edit and bury the completions buffer."
549 (abort-recursive-edit)
551 ;; If there was no recursive edit to abort, simply bury the completions
553 (if (eq major-mode 'completion-list-mode) (bury-buffer)))
555 (defun completion-do-in-minibuffer ()
558 (set-buffer (window-buffer (minibuffer-window)))
559 (call-interactively (key-binding (this-command-keys)))))
561 (defun default-choose-completion (event extent buffer)
562 "Click on an alternative in the `*Completions*' buffer to choose it."
563 (and (button-event-p event)
564 ;; Give temporary modes such as isearch a chance to turn off.
565 (run-hooks 'mouse-leave-buffer-hook))
566 (let ((list-buffer (or (and (button-event-p event)
567 (event-buffer event))
569 (or buffer (setq buffer (symbol-value-in-buffer
570 'completion-reference-buffer
572 (save-selected-window
573 (and (button-event-p event)
574 (select-window (event-window event)))
575 (if (and (one-window-p t 'selected-frame)
576 (window-dedicated-p (selected-window)))
577 ;; This is a special buffer's frame
578 (iconify-frame (selected-frame))
579 (or (window-dedicated-p (selected-window))
581 (choose-completion-string (extent-string extent)
583 (symbol-value-in-buffer 'completion-base-size
586 ;; Delete the longest partial match for STRING
587 ;; that can be found before POINT.
588 (defun choose-completion-delete-max-match (string)
589 (let ((len (min (length string)
590 (- (point) (point-min)))))
591 (goto-char (- (point) (length string)))
592 (if completion-ignore-case
593 (setq string (downcase string)))
594 (while (and (> len 0)
595 (let ((tail (buffer-substring (point)
597 (if completion-ignore-case
598 (setq tail (downcase tail)))
599 (not (string= tail (substring string 0 len)))))
604 ;; Switch to BUFFER and insert the completion choice CHOICE.
605 ;; BASE-SIZE, if non-nil, says how many characters of BUFFER's text
606 ;; to keep. If it is nil, use choose-completion-delete-max-match instead.
607 (defun choose-completion-string (choice &optional buffer base-size)
608 (let ((buffer (or buffer completion-reference-buffer)))
609 ;; If BUFFER is a minibuffer, barf unless it's the currently
610 ;; active minibuffer.
611 (if (and (string-match #r"\` \*Minibuf-[0-9]+\*\'" (buffer-name buffer))
612 (or (not (active-minibuffer-window))
614 (window-buffer (active-minibuffer-window))))))
615 (error "Minibuffer is not active for completion")
616 ;; Insert the completion into the buffer where completion was requested.
619 (delete-region (+ base-size (point-min)) (point))
620 (choose-completion-delete-max-match choice))
622 (remove-text-properties (- (point) (length choice)) (point)
624 ;; Update point in the window that BUFFER is showing in.
625 (let ((window (get-buffer-window buffer t)))
626 (set-window-point window (point)))
627 ;; If completing for the minibuffer, exit it with this choice.
628 (and (equal buffer (window-buffer (minibuffer-window)))
629 minibuffer-completion-table
630 (exit-minibuffer)))))
632 (define-key minibuffer-local-completion-map [prior]
633 'switch-to-completions)
634 (define-key minibuffer-local-must-match-map [prior]
635 'switch-to-completions)
636 (define-key minibuffer-local-completion-map "\M-v"
637 'advertised-switch-to-completions)
638 (define-key minibuffer-local-must-match-map "\M-v"
639 'advertised-switch-to-completions)
641 (defalias 'advertised-switch-to-completions 'switch-to-completions)
642 (defun switch-to-completions ()
643 "Select the completion list window."
645 ;; Make sure we have a completions window.
646 (or (get-buffer-window "*Completions*")
647 (minibuffer-completion-help))
648 (if (not (get-buffer-window "*Completions*"))
650 (select-window (get-buffer-window "*Completions*"))
651 (goto-char (next-single-property-change (point-min) 'list-mode-item nil
654 ;;; list-mode.el ends here