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

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