Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

254 lines (234 sloc) 10.518 kb
;;; dropdown-list.el --- Drop-down menu interface
;;
;; Filename: dropdown-list.el
;; Description: Drop-down menu interface
;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
;; Author: Jaeyoun Chung [jay.chung@gmail.com]
;; Maintainer:
;; Authors: pluskid <pluskid@gmail.com>, João Távora <joaotavora@gmail.com>
;; 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 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; 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
;; Local Variables:
;; coding: utf-8
;; End:
Jump to Line
Something went wrong with that request. Please try again.