code.delx.au - gnu-emacs-elpa/blob - dropdown-list.el

   1 ;;; dropdown-list.el --- Drop-down menu interface
   2 ;;
   3 ;; Filename: dropdown-list.el
   4 ;; Description: Drop-down menu interface
   5 ;; Author: Jaeyoun Chung [jay.chung@gmail.com]
   6 ;; Maintainer:
   7 ;; Copyright (C) 2008 Jaeyoun Chung
   8 ;; Created: Sun Mar 16 11:20:45 2008 (Pacific Daylight Time)
   9 ;; Version:
  10 ;; Last-Updated: Sun Mar 16 12:19:49 2008 (Pacific Daylight Time)
  11 ;;           By: dradams
  12 ;;     Update #: 43
  13 ;; URL: http://www.emacswiki.org/cgi-bin/wiki/dropdown-list.el
  14 ;; Keywords: convenience menu
  15 ;; Compatibility: GNU Emacs 21.x, GNU Emacs 22.x
  16 ;;
  17 ;; Features that might be required by this library:
  18 ;;
  19 ;;   `cl'.
  20 ;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;
  23 ;;; Commentary:
  24 ;;
  25 ;;  According to Jaeyoun Chung, "overlay code stolen from company-mode.el."
  26 ;;
  27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28 ;;
  29 ;;; Change log:
  30 ;;
  31 ;; 2008/03/16 dadams
  32 ;;     Clean-up - e.g. use char-to-string for control chars removed by email posting.
  33 ;;     Moved example usage code (define-key*, command-selector) inside the library.
  34 ;;     Require cl.el at byte-compile time.
  35 ;;     Added GPL statement.
  36 ;; 2008/01/06 Jaeyoun Chung
  37 ;;     Posted to gnu-emacs-sources@gnu.org at 9:10 p.m.
  38 ;;
  39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40 ;;
  41 ;; This program is free software; you can redistribute it and/or
  42 ;; modify it under the terms of the GNU General Public License as
  43 ;; published by the Free Software Foundation; either version 3, or
  44 ;; (at your option) any later version.
  45 ;;
  46 ;; This program is distributed in the hope that it will be useful,
  47 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  48 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  49 ;; General Public License for more details.
  50 ;;
  51 ;; You should have received a copy of the GNU General Public License
  52 ;; along with this program; see the file COPYING.  If not, write to
  53 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  54 ;; Floor, Boston, MA 02110-1301, USA.
  55 ;;
  56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57 ;;
  58 ;;; Code:
  59
  60 (eval-when-compile (require 'cl)) ;; decf, fourth, incf, loop, mapcar*
  61
  62 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  63
  64 (defface dropdown-list-face
  65   '((t :inherit default :background "lightyellow" :foreground "black"))
  66   "*Bla." :group 'dropdown-list)
  67
  68 (defface dropdown-list-selection-face
  69   '((t :inherit dropdown-list-face :background "purple"))
  70   "*Bla." :group 'dropdown-list)
  71
  72 (defvar dropdown-list-overlays nil)
  73
  74 (defun dropdown-list-hide ()
  75   (while dropdown-list-overlays
  76     (delete-overlay (pop dropdown-list-overlays))))
  77
  78 (defun dropdown-list-put-overlay (beg end &optional prop value prop2 value2)
  79   (let ((ov (make-overlay beg end)))
  80     (overlay-put ov 'window t)
  81     (when prop
  82       (overlay-put ov prop value)
  83       (when prop2 (overlay-put ov prop2 value2)))
  84     ov))
  85
  86 (defun dropdown-list-line (start replacement &optional no-insert)
  87   ;; start might be in the middle of a tab, which means we need to hide the
  88   ;; tab and add spaces
  89   (let ((end (+ start (length replacement)))
  90         beg-point end-point
  91         before-string after-string)
  92     (goto-char (point-at-eol))
  93     (if (< (current-column) start)
  94         (progn (setq before-string (make-string (- start (current-column)) ? ))
  95                (setq beg-point (point)))
  96       (goto-char (point-at-bol)) ;; Emacs bug, move-to-column is wrong otherwise
  97       (move-to-column start)
  98       (setq beg-point (point))
  99       (when (> (current-column) start)
 100         (goto-char (1- (point)))
 101         (setq beg-point (point))
 102         (setq before-string (make-string (- start (current-column)) ? ))))
 103     (move-to-column end)
 104     (setq end-point (point))
 105     (let ((end-offset (- (current-column) end)))
 106       (when (> end-offset 0) (setq after-string (make-string end-offset ?b))))
 107     (when no-insert
 108       ;; prevent inheriting of faces
 109       (setq before-string (when before-string (propertize before-string 'face 'default)))
 110       (setq after-string (when after-string (propertize after-string 'face 'default))))
 111     (let ((string (concat before-string replacement after-string)))
 112       (if no-insert
 113           string
 114         (push (dropdown-list-put-overlay beg-point end-point 'invisible t
 115                                          'after-string string)
 116               dropdown-list-overlays)))))
 117
 118 (defun dropdown-list-start-column (display-width)
 119   (let ((column (mod (current-column) (window-width)))
 120         (width (window-width)))
 121     (cond ((<= (+ column display-width) width) column)
 122           ((> column display-width) (- column display-width))
 123           ((>= width display-width) (- width display-width))
 124           (t nil))))
 125
 126 (defun dropdown-list-move-to-start-line (candidate-count)
 127   (decf candidate-count)
 128   (let ((above-line-count (save-excursion (- (vertical-motion (- candidate-count)))))
 129         (below-line-count (save-excursion (vertical-motion candidate-count))))
 130     (cond ((= below-line-count candidate-count)
 131            t)
 132           ((= above-line-count candidate-count)
 133            (vertical-motion (- candidate-count))
 134            t)
 135           ((>= (+ below-line-count above-line-count) candidate-count)
 136            (vertical-motion (- (- candidate-count below-line-count)))
 137            t)
 138           (t nil))))
 139
 140 (defun dropdown-list-at-point (candidates &optional selidx)
 141   (dropdown-list-hide)
 142   (let* ((lengths (mapcar #'length candidates))
 143          (max-length (apply #'max lengths))
 144          (start (dropdown-list-start-column (+ max-length 3)))
 145          (i -1)
 146          (candidates (mapcar* (lambda (candidate length)
 147                                 (let ((diff (- max-length length)))
 148                                   (propertize
 149                                    (concat (if (> diff 0)
 150                                                (concat candidate (make-string diff ? ))
 151                                              (substring candidate 0 max-length))
 152                                            (format "%3d" (+ 2 i)))
 153                                    'face (if (eql (incf i) selidx)
 154                                              'dropdown-list-selection-face
 155                                            'dropdown-list-face))))
 156                               candidates
 157                               lengths)))
 158     (save-excursion
 159       (and start
 160            (dropdown-list-move-to-start-line (length candidates))
 161            (loop initially (vertical-motion 0)
 162                  for candidate in candidates
 163                  do (dropdown-list-line (+ (current-column) start) candidate)
 164                  while (/= (vertical-motion 1) 0)
 165                  finally return t)))))
 166
 167 (defun dropdown-list (candidates)
 168   (let ((selection)
 169         (temp-buffer))
 170     (save-window-excursion
 171       (unwind-protect
 172           (let ((candidate-count (length candidates))
 173                 done key (selidx 0))
 174             (while (not done)
 175               (unless (dropdown-list-at-point candidates selidx)
 176                 (switch-to-buffer (setq temp-buffer (get-buffer-create "*selection*"))
 177                                   'norecord)
 178                 (delete-other-windows)
 179                 (delete-region (point-min) (point-max))
 180                 (insert (make-string (length candidates) ?\n))
 181                 (goto-char (point-min))
 182                 (dropdown-list-at-point candidates selidx))
 183               (setq key (read-key-sequence ""))
 184               (cond ((and (stringp key)
 185                           (>= (aref key 0) ?1)
 186                           (<= (aref key 0) (+ ?0 (min 9 candidate-count))))
 187                      (setq selection (- (aref key 0) ?1)
 188                            done      t))
 189                     ((member key `(,(char-to-string ?\C-p) [up] "p"))
 190                      (setq selidx (mod (+ candidate-count (1- (or selidx 0)))
 191                                        candidate-count)))
 192                     ((member key `(,(char-to-string ?\C-n) [down] "n"))
 193                      (setq selidx (mod (1+ (or selidx -1)) candidate-count)))
 194                     ((member key `(,(char-to-string ?\f))))
 195                     ((member key `(,(char-to-string ?\r) [return]))
 196                      (setq selection selidx
 197                            done      t))
 198                     (t (setq done t)))))
 199         (dropdown-list-hide)
 200         (and temp-buffer (kill-buffer temp-buffer)))
 201       ;;     (when selection
 202       ;;       (message "your selection => %d: %s" selection (nth selection candidates))
 203       ;;       (sit-for 1))
 204       selection)))
 205
 206 (defun define-key* (keymap key command)
 207   "Add COMMAND to the multiple-command binding of KEY in KEYMAP.
 208 Use multiple times to bind different COMMANDs to the same KEY."
 209   (define-key keymap key (combine-command command (lookup-key keymap key))))
 210
 211 (defun combine-command (command defs)
 212   "$$$$$ FIXME - no doc string"
 213   (cond ((null defs) command)
 214         ((and (listp defs)
 215               (eq 'lambda (car defs))
 216               (= (length defs) 4)
 217               (listp (fourth defs))
 218               (eq 'command-selector (car (fourth defs))))
 219          (unless (member `',command (cdr (fourth defs)))
 220            (setcdr (fourth defs) (nconc (cdr (fourth defs)) `(',command))))
 221          defs)
 222         (t
 223          `(lambda () (interactive) (command-selector ',defs ',command)))))
 224
 225 (defvar command-selector-last-command nil "$$$$$ FIXME - no doc string")
 226
 227 (defun command-selector (&rest candidates)
 228   "$$$$$ FIXME - no doc string"
 229   (if (and (eq last-command this-command) command-selector-last-command)
 230       (call-interactively command-selector-last-command)
 231     (let* ((candidate-strings
 232             (mapcar (lambda (candidate)
 233                       (format "%s" (if (symbolp candidate)
 234                                        candidate
 235                                      (let ((s (format "%s" candidate)))
 236                                        (if (>= (length s) 7)
 237                                            (concat (substring s 0 7) "...")
 238                                          s)))))
 239                     candidates))
 240            (selection (dropdown-list candidate-strings)))
 241       (when selection
 242         (let ((cmd (nth selection candidates)))
 243           (call-interactively cmd)
 244           (setq command-selector-last-command cmd))))))
 245
 246 ;;;;;;;;;;;;;;;;;;;;
 247
 248 (provide 'dropdown-list)
 249
 250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 251 ;;; dropdown-list.el ends here