diff options
| -rw-r--r-- | emacs.d/dropdown-list/dropdown-list.el | 258 |
1 files changed, 258 insertions, 0 deletions
diff --git a/emacs.d/dropdown-list/dropdown-list.el b/emacs.d/dropdown-list/dropdown-list.el new file mode 100644 index 0000000..452fcbc --- /dev/null +++ b/emacs.d/dropdown-list/dropdown-list.el @@ -0,0 +1,258 @@ +;;; 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: Fri Aug 14 11:46:34 2009 (Central European Time) +;; Version: +;; Last-Updated: Fri Aug 14 11:46:34 2009 (Central European Time) +;; By: Deniz Dogan +;; Update #: 44 +;; URL: http://www.emacswiki.org/cgi-bin/wiki/dropdown-list.el +;; Keywords: convenience menu +;; Compatibility: GNU Emacs 21.x, GNU Emacs 22.x, GNU Emacs 23.x +;; +;; Features that might be required by this library: +;; +;; `cl'. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; According to Jaeyoun Chung, "overlay code stolen from company-mode.el." +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; 2009/08/14 Deniz Dogan +;; Making TAB select the chosen option. If no option has been selected, chooses the +;; first one. +;; 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 :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) + (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])) + (setq selidx (mod (+ candidate-count (1- (or selidx 0))) + candidate-count))) + ((member key `(,(char-to-string ?\C-n) [down])) + (setq selidx (mod (1+ (or selidx -1)) candidate-count))) + ((member key `(,(char-to-string ?\C-i) [tab])) + (setq done t + selection (if (null selidx) 0 selidx))) + ((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 + |