251 lines
10 KiB
EmacsLisp
251 lines
10 KiB
EmacsLisp
|
;;; dropdown-list.el --- Drop-down menu interface
|
||
|
|
;;
|
||
|
|
;; Filename: dropdown-list.el
|
||
|
|
;; Description: Drop-down menu interface
|
||
|
|
;; Author: Jaeyoun Chung [jay.chung@gmail.com]
|
||
|
|
;; Maintainer:
|
||
|
|
;; Copyright (C) 2008 Jaeyoun Chung
|
||
|
|
;; Created: Sun Mar 16 11:20:45 2008 (Pacific Daylight Time)
|
||
|
|
;; Version:
|
||
|
|
;; Last-Updated: Sun Mar 16 12:19:49 2008 (Pacific Daylight Time)
|
||
|
|
;; By: dradams
|
||
|
|
;; Update #: 43
|
||
|
|
;; URL: http://www.emacswiki.org/cgi-bin/wiki/dropdown-list.el
|
||
|
|
;; Keywords: convenience menu
|
||
|
|
;; Compatibility: GNU Emacs 21.x, GNU Emacs 22.x
|
||
|
|
;;
|
||
|
|
;; Features that might be required by this library:
|
||
|
|
;;
|
||
|
|
;; `cl'.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Commentary:
|
||
|
|
;;
|
||
|
|
;; According to Jaeyoun Chung, "overlay code stolen from company-mode.el."
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Change log:
|
||
|
|
;;
|
||
|
|
;; 2008/03/16 dadams
|
||
|
|
;; Clean-up - e.g. use char-to-string for control chars removed by email posting.
|
||
|
|
;; Moved example usage code (define-key*, command-selector) inside the library.
|
||
|
|
;; Require cl.el at byte-compile time.
|
||
|
|
;; Added GPL statement.
|
||
|
|
;; 2008/01/06 Jaeyoun Chung
|
||
|
|
;; Posted to gnu-emacs-sources@gnu.org at 9:10 p.m.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;; This program is free software; you can redistribute it and/or
|
||
|
|
;; modify it under the terms of the GNU General Public License as
|
||
|
|
;; published by the Free Software Foundation; either version 3, or
|
||
|
|
;; (at your option) any later version.
|
||
|
|
;;
|
||
|
|
;; This program is distributed in the hope that it will be useful,
|
||
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
|
|
;; General Public License for more details.
|
||
|
|
;;
|
||
|
|
;; You should have received a copy of the GNU General Public License
|
||
|
|
;; along with this program; see the file COPYING. If not, write to
|
||
|
|
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
|
||
|
|
;; Floor, Boston, MA 02110-1301, USA.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(eval-when-compile (require 'cl)) ;; decf, fourth, incf, loop, mapcar*
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
(defface dropdown-list-face
|
||
|
|
'((t :inherit default :background "lightyellow" :foreground "black"))
|
||
|
|
"*Bla." :group 'dropdown-list)
|
||
|
|
|
||
|
|
(defface dropdown-list-selection-face
|
||
|
|
'((t :inherit dropdown-list-face :background "purple"))
|
||
|
|
"*Bla." :group 'dropdown-list)
|
||
|
|
|
||
|
|
(defvar dropdown-list-overlays nil)
|
||
|
|
|
||
|
|
(defun dropdown-list-hide ()
|
||
|
|
(while dropdown-list-overlays
|
||
|
|
(delete-overlay (pop dropdown-list-overlays))))
|
||
|
|
|
||
|
|
(defun dropdown-list-put-overlay (beg end &optional prop value prop2 value2)
|
||
|
|
(let ((ov (make-overlay beg end)))
|
||
|
|
(overlay-put ov 'window t)
|
||
|
|
(when prop
|
||
|
|
(overlay-put ov prop value)
|
||
|
|
(when prop2 (overlay-put ov prop2 value2)))
|
||
|
|
ov))
|
||
|
|
|
||
|
|
(defun dropdown-list-line (start replacement &optional no-insert)
|
||
|
|
;; start might be in the middle of a tab, which means we need to hide the
|
||
|
|
;; tab and add spaces
|
||
|
|
(let ((end (+ start (length replacement)))
|
||
|
|
beg-point end-point
|
||
|
|
before-string after-string)
|
||
|
|
(goto-char (point-at-eol))
|
||
|
|
(if (< (current-column) start)
|
||
|
|
(progn (setq before-string (make-string (- start (current-column)) ? ))
|
||
|
|
(setq beg-point (point)))
|
||
|
|
(goto-char (point-at-bol)) ;; Emacs bug, move-to-column is wrong otherwise
|
||
|
|
(move-to-column start)
|
||
|
|
(setq beg-point (point))
|
||
|
|
(when (> (current-column) start)
|
||
|
|
(goto-char (1- (point)))
|
||
|
|
(setq beg-point (point))
|
||
|
|
(setq before-string (make-string (- start (current-column)) ? ))))
|
||
|
|
(move-to-column end)
|
||
|
|
(setq end-point (point))
|
||
|
|
(let ((end-offset (- (current-column) end)))
|
||
|
|
(when (> end-offset 0) (setq after-string (make-string end-offset ?b))))
|
||
|
|
(when no-insert
|
||
|
|
;; prevent inheriting of faces
|
||
|
|
(setq before-string (when before-string (propertize before-string 'face 'default)))
|
||
|
|
(setq after-string (when after-string (propertize after-string 'face 'default))))
|
||
|
|
(let ((string (concat before-string replacement after-string)))
|
||
|
|
(if no-insert
|
||
|
|
string
|
||
|
|
(push (dropdown-list-put-overlay beg-point end-point 'invisible t
|
||
|
|
'after-string string)
|
||
|
|
dropdown-list-overlays)))))
|
||
|
|
|
||
|
|
(defun dropdown-list-start-column (display-width)
|
||
|
|
(let ((column (mod (current-column) (window-width)))
|
||
|
|
(width (window-width)))
|
||
|
|
(cond ((<= (+ column display-width) width) column)
|
||
|
|
((> column display-width) (- column display-width))
|
||
|
|
((>= width display-width) (- width display-width))
|
||
|
|
(t nil))))
|
||
|
|
|
||
|
|
(defun dropdown-list-move-to-start-line (candidate-count)
|
||
|
|
(decf candidate-count)
|
||
|
|
(let ((above-line-count (save-excursion (- (vertical-motion (- candidate-count)))))
|
||
|
|
(below-line-count (save-excursion (vertical-motion candidate-count))))
|
||
|
|
(cond ((= below-line-count candidate-count)
|
||
|
|
t)
|
||
|
|
((= above-line-count candidate-count)
|
||
|
|
(vertical-motion (- candidate-count))
|
||
|
|
t)
|
||
|
|
((>= (+ below-line-count above-line-count) candidate-count)
|
||
|
|
(vertical-motion (- (- candidate-count below-line-count)))
|
||
|
|
t)
|
||
|
|
(t nil))))
|
||
|
|
|
||
|
|
(defun dropdown-list-at-point (candidates &optional selidx)
|
||
|
|
(dropdown-list-hide)
|
||
|
|
(let* ((lengths (mapcar #'length candidates))
|
||
|
|
(max-length (apply #'max lengths))
|
||
|
|
(start (dropdown-list-start-column (+ max-length 3)))
|
||
|
|
(i -1)
|
||
|
|
(candidates (mapcar* (lambda (candidate length)
|
||
|
|
(let ((diff (- max-length length)))
|
||
|
|
(propertize
|
||
|
|
(concat (if (> diff 0)
|
||
|
|
(concat candidate (make-string diff ? ))
|
||
|
|
(substring candidate 0 max-length))
|
||
|
|
(format "%3d" (+ 2 i)))
|
||
|
|
'face (if (eql (incf i) selidx)
|
||
|
|
'dropdown-list-selection-face
|
||
|
|
'dropdown-list-face))))
|
||
|
|
candidates
|
||
|
|
lengths)))
|
||
|
|
(save-excursion
|
||
|
|
(and start
|
||
|
|
(dropdown-list-move-to-start-line (length candidates))
|
||
|
|
(loop initially (vertical-motion 0)
|
||
|
|
for candidate in candidates
|
||
|
|
do (dropdown-list-line (+ (current-column) start) candidate)
|
||
|
|
while (/= (vertical-motion 1) 0)
|
||
|
|
finally return t)))))
|
||
|
|
|
||
|
|
(defun dropdown-list (candidates)
|
||
|
|
(let ((selection)
|
||
|
|
(temp-buffer))
|
||
|
|
(save-window-excursion
|
||
|
|
(unwind-protect
|
||
|
|
(let ((candidate-count (length candidates))
|
||
|
|
done key (selidx 0))
|
||
|
|
(while (not done)
|
||
|
|
(unless (dropdown-list-at-point candidates selidx)
|
||
|
|
(switch-to-buffer (setq temp-buffer (get-buffer-create "*selection*"))
|
||
|
|
'norecord)
|
||
|
|
(delete-other-windows)
|
||
|
|
(delete-region (point-min) (point-max))
|
||
|
|
(insert (make-string (length candidates) ?\n))
|
||
|
|
(goto-char (point-min))
|
||
|
|
(dropdown-list-at-point candidates selidx))
|
||
|
|
(setq key (read-key-sequence ""))
|
||
|
|
(cond ((and (stringp key)
|
||
|
|
(>= (aref key 0) ?1)
|
||
|
|
(<= (aref key 0) (+ ?0 (min 9 candidate-count))))
|
||
|
|
(setq selection (- (aref key 0) ?1)
|
||
|
|
done t))
|
||
|
|
((member key `(,(char-to-string ?\C-p) [up] "p"))
|
||
|
|
(setq selidx (mod (+ candidate-count (1- (or selidx 0)))
|
||
|
|
candidate-count)))
|
||
|
|
((member key `(,(char-to-string ?\C-n) [down] "n"))
|
||
|
|
(setq selidx (mod (1+ (or selidx -1)) candidate-count)))
|
||
|
|
((member key `(,(char-to-string ?\f))))
|
||
|
|
((member key `(,(char-to-string ?\r) [return]))
|
||
|
|
(setq selection selidx
|
||
|
|
done t))
|
||
|
|
(t (setq done t)))))
|
||
|
|
(dropdown-list-hide)
|
||
|
|
(and temp-buffer (kill-buffer temp-buffer)))
|
||
|
|
;; (when selection
|
||
|
|
;; (message "your selection => %d: %s" selection (nth selection candidates))
|
||
|
|
;; (sit-for 1))
|
||
|
|
selection)))
|
||
|
|
|
||
|
|
(defun define-key* (keymap key command)
|
||
|
|
"Add COMMAND to the multiple-command binding of KEY in KEYMAP.
|
||
|
|
Use multiple times to bind different COMMANDs to the same KEY."
|
||
|
|
(define-key keymap key (combine-command command (lookup-key keymap key))))
|
||
|
|
|
||
|
|
(defun combine-command (command defs)
|
||
|
|
"$$$$$ FIXME - no doc string"
|
||
|
|
(cond ((null defs) command)
|
||
|
|
((and (listp defs)
|
||
|
|
(eq 'lambda (car defs))
|
||
|
|
(= (length defs) 4)
|
||
|
|
(listp (fourth defs))
|
||
|
|
(eq 'command-selector (car (fourth defs))))
|
||
|
|
(unless (member `',command (cdr (fourth defs)))
|
||
|
|
(setcdr (fourth defs) (nconc (cdr (fourth defs)) `(',command))))
|
||
|
|
defs)
|
||
|
|
(t
|
||
|
|
`(lambda () (interactive) (command-selector ',defs ',command)))))
|
||
|
|
|
||
|
|
(defvar command-selector-last-command nil "$$$$$ FIXME - no doc string")
|
||
|
|
|
||
|
|
(defun command-selector (&rest candidates)
|
||
|
|
"$$$$$ FIXME - no doc string"
|
||
|
|
(if (and (eq last-command this-command) command-selector-last-command)
|
||
|
|
(call-interactively command-selector-last-command)
|
||
|
|
(let* ((candidate-strings
|
||
|
|
(mapcar (lambda (candidate)
|
||
|
|
(format "%s" (if (symbolp candidate)
|
||
|
|
candidate
|
||
|
|
(let ((s (format "%s" candidate)))
|
||
|
|
(if (>= (length s) 7)
|
||
|
|
(concat (substring s 0 7) "...")
|
||
|
|
s)))))
|
||
|
|
candidates))
|
||
|
|
(selection (dropdown-list candidate-strings)))
|
||
|
|
(when selection
|
||
|
|
(let ((cmd (nth selection candidates)))
|
||
|
|
(call-interactively cmd)
|
||
|
|
(setq command-selector-last-command cmd))))))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
(provide 'dropdown-list)
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; dropdown-list.el ends here
|