| commit | author | age | ||
| 5cb5f7 | 1 | ;;; popup.el --- Visual Popup User Interface |
| C | 2 | |
| 3 | ;; Copyright (C) 2009-2015 Tomohiro Matsuyama | |
| 4 | ||
| 5 | ;; Author: Tomohiro Matsuyama <m2ym.pub@gmail.com> | |
| 6 | ;; Keywords: lisp | |
| 7 | ;; Package-Version: 20160709.1429 | |
| 8 | ;; Version: 0.5.3 | |
| 9 | ;; Package-Requires: ((cl-lib "0.5")) | |
| 10 | ||
| 11 | ;; This program is free software; you can redistribute it and/or modify | |
| 12 | ;; it under the terms of the GNU General Public License as published by | |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or | |
| 14 | ;; (at your option) any later version. | |
| 15 | ||
| 16 | ;; This program is distributed in the hope that it will be useful, | |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 19 | ;; GNU General Public License for more details. | |
| 20 | ||
| 21 | ;; You should have received a copy of the GNU General Public License | |
| 22 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
| 23 | ||
| 24 | ;;; Commentary: | |
| 25 | ||
| 26 | ;; popup.el is a visual popup user interface library for Emacs. This | |
| 27 | ;; provides a basic API and common UI widgets such as popup tooltips | |
| 28 | ;; and popup menus. | |
| 29 | ;; See README.markdown for more information. | |
| 30 | ||
| 31 | ;;; Code: | |
| 32 | ||
| 33 | (require 'cl-lib) | |
| 34 | ||
| 35 | (defconst popup-version "0.5.3") | |
| 36 | ||
| 37 | ||
| 38 | ||
| 39 | ;;; Utilities | |
| 40 | ||
| 41 | (defun popup-calculate-max-width (max-width) | |
| 42 | "Determines whether the width desired is | |
| 43 | character or window proportion based, And returns the result." | |
| 44 | (cl-typecase max-width | |
| 45 | (integer max-width) | |
| 46 | (float (* (ceiling (/ (round (* max-width (window-width))) 10.0)) 10)))) | |
| 47 | ||
| 48 | (defvar popup-use-optimized-column-computation t | |
| 49 | "Use the optimized column computation routine. | |
| 50 | If there is a problem, please set it nil.") | |
| 51 | ||
| 52 | (defmacro popup-aif (test then &rest else) | |
| 53 | "Anaphoric if." | |
| 54 | (declare (indent 2)) | |
| 55 | `(let ((it ,test)) | |
| 56 | (if it ,then ,@else))) | |
| 57 | ||
| 58 | (defmacro popup-awhen (test &rest body) | |
| 59 | "Anaphoric when." | |
| 60 | (declare (indent 1)) | |
| 61 | `(let ((it ,test)) | |
| 62 | (when it ,@body))) | |
| 63 | ||
| 64 | (defun popup-x-to-string (x) | |
| 65 | "Convert any object to string effeciently. | |
| 66 | This is faster than `prin1-to-string' in many cases." | |
| 67 | (cl-typecase x | |
| 68 | (string x) | |
| 69 | (symbol (symbol-name x)) | |
| 70 | (integer (number-to-string x)) | |
| 71 | (float (number-to-string x)) | |
| 72 | (t (format "%s" x)))) | |
| 73 | ||
| 74 | (defun popup-substring-by-width (string width) | |
| 75 | "Return a cons cell of substring and remaining string by | |
| 76 | splitting with WIDTH." | |
| 77 | ;; Expand tabs into 4 spaces | |
| 78 | (setq string (replace-regexp-in-string "\t" " " string)) | |
| 79 | (cl-loop with len = (length string) | |
| 80 | with w = 0 | |
| 81 | for l from 0 | |
| 82 | for c in (append string nil) | |
| 83 | while (<= (cl-incf w (char-width c)) width) | |
| 84 | finally return | |
| 85 | (if (< l len) | |
| 86 | (cons (substring string 0 l) (substring string l)) | |
| 87 | (list string)))) | |
| 88 | ||
| 89 | (defun popup-fill-string (string &optional width max-width justify squeeze) | |
| 90 | "Split STRING into fixed width strings and return a cons cell | |
| 91 | like \(WIDTH . ROWS). Here, the car WIDTH indicates the actual | |
| 92 | maxim width of ROWS. | |
| 93 | ||
| 94 | The argument WIDTH specifies the width of filling each | |
| 95 | paragraph. WIDTH nil means don't perform any justification and | |
| 96 | word wrap. Note that this function doesn't add any padding | |
| 97 | characters at the end of each row. | |
| 98 | ||
| 99 | MAX-WIDTH, if WIDTH is nil, specifies the maximum number of | |
| 100 | columns. | |
| 101 | ||
| 102 | The optional fourth argument JUSTIFY specifies which kind of | |
| 103 | justification to do: `full', `left', `right', `center', or | |
| 104 | `none' (equivalent to nil). A value of t means handle each | |
| 105 | paragraph as specified by its text properties. | |
| 106 | ||
| 107 | SQUEEZE nil means leave whitespaces other than line breaks | |
| 108 | untouched." | |
| 109 | (if (eq width 0) | |
| 110 | (error "Can't fill string with 0 width")) | |
| 111 | (if width | |
| 112 | (setq max-width width)) | |
| 113 | (with-temp-buffer | |
| 114 | (let ((tab-width 4) | |
| 115 | (fill-column width) | |
| 116 | (left-margin 0) | |
| 117 | (kinsoku-limit 1) | |
| 118 | indent-tabs-mode | |
| 119 | row rows) | |
| 120 | (insert string) | |
| 121 | (untabify (point-min) (point-max)) | |
| 122 | (if width | |
| 123 | (fill-region (point-min) (point-max) justify (not squeeze))) | |
| 124 | (goto-char (point-min)) | |
| 125 | (setq width 0) | |
| 126 | (while (prog2 | |
| 127 | (let ((line (buffer-substring | |
| 128 | (point) (progn (end-of-line) (point))))) | |
| 129 | (if max-width | |
| 130 | (while (progn | |
| 131 | (setq row (truncate-string-to-width line max-width) | |
| 132 | width (max width (string-width row))) | |
| 133 | (push row rows) | |
| 134 | (if (not (= (length row) (length line))) | |
| 135 | (setq line (substring line (length row)))))) | |
| 136 | (setq width (max width (string-width line))) | |
| 137 | (push line rows))) | |
| 138 | (< (point) (point-max)) | |
| 139 | (beginning-of-line 2))) | |
| 140 | (cons width (nreverse rows))))) | |
| 141 | ||
| 142 | (defmacro popup-save-buffer-state (&rest body) | |
| 143 | (declare (indent 0)) | |
| 144 | `(save-excursion | |
| 145 | (let ((buffer-undo-list t) | |
| 146 | (inhibit-read-only t) | |
| 147 | (modified (buffer-modified-p))) | |
| 148 | (unwind-protect | |
| 149 | (progn ,@body) | |
| 150 | (set-buffer-modified-p modified))))) | |
| 151 | ||
| 152 | (defun popup-vertical-motion (column direction) | |
| 153 | "A portable version of `vertical-motion'." | |
| 154 | (if (>= emacs-major-version 23) | |
| 155 | (vertical-motion (cons column direction)) | |
| 156 | (vertical-motion direction) | |
| 157 | (move-to-column (+ (current-column) column)))) | |
| 158 | ||
| 159 | (defun popup-last-line-of-buffer-p () | |
| 160 | "Return non-nil if the cursor is at the last line of the | |
| 161 | buffer." | |
| 162 | (save-excursion (end-of-line) (/= (forward-line) 0))) | |
| 163 | ||
| 164 | (defun popup-lookup-key-by-event (function event) | |
| 165 | (or (funcall function (vector event)) | |
| 166 | (if (symbolp event) | |
| 167 | (popup-aif (get event 'event-symbol-element-mask) | |
| 168 | (funcall function | |
| 169 | (vector (logior (or (get (car it) 'ascii-character) | |
| 170 | 0) | |
| 171 | (cadr it)))))))) | |
| 172 | ||
| 173 | ||
| 174 | ||
| 175 | ;;; Core | |
| 176 | ||
| 177 | (defgroup popup nil | |
| 178 | "Visual Popup User Interface" | |
| 179 | :group 'lisp | |
| 180 | :prefix "popup-") | |
| 181 | ||
| 182 | (defface popup-face | |
| 183 | '((t (:inherit default :background "lightgray" :foreground "black"))) | |
| 184 | "Face for popup." | |
| 185 | :group 'popup) | |
| 186 | ||
| 187 | (defface popup-summary-face | |
| 188 | '((t (:inherit popup-face :foreground "dimgray"))) | |
| 189 | "Face for popup summary." | |
| 190 | :group 'popup) | |
| 191 | ||
| 192 | (defface popup-scroll-bar-foreground-face | |
| 193 | '((t (:background "black"))) | |
| 194 | "Foreground face for scroll-bar." | |
| 195 | :group 'popup) | |
| 196 | ||
| 197 | (defface popup-scroll-bar-background-face | |
| 198 | '((t (:background "gray"))) | |
| 199 | "Background face for scroll-bar." | |
| 200 | :group 'popup) | |
| 201 | ||
| 202 | (defvar popup-instances nil | |
| 203 | "Popup instances.") | |
| 204 | ||
| 205 | (defvar popup-scroll-bar-foreground-char | |
| 206 | (propertize " " 'face 'popup-scroll-bar-foreground-face) | |
| 207 | "Foreground character for scroll-bar.") | |
| 208 | ||
| 209 | (defvar popup-scroll-bar-background-char | |
| 210 | (propertize " " 'face 'popup-scroll-bar-background-face) | |
| 211 | "Background character for scroll-bar.") | |
| 212 | ||
| 213 | (cl-defstruct popup | |
| 214 | point row column width height min-height direction overlays keymap | |
| 215 | parent depth | |
| 216 | face mouse-face selection-face summary-face | |
| 217 | margin-left margin-right margin-left-cancel scroll-bar symbol | |
| 218 | cursor offset scroll-top current-height list newlines | |
| 219 | pattern original-list invis-overlays) | |
| 220 | ||
| 221 | (defun popup-item-propertize (item &rest properties) | |
| 222 | "Same as `propertize' except that this avoids overriding | |
| 223 | existed value with `nil' property." | |
| 224 | (cl-loop for (k v) on properties by 'cddr | |
| 225 | if v append (list k v) into props | |
| 226 | finally return | |
| 227 | (apply 'propertize | |
| 228 | (popup-x-to-string item) | |
| 229 | props))) | |
| 230 | ||
| 231 | (defun popup-item-property (item property) | |
| 232 | "Same as `get-text-property' except that this returns nil if | |
| 233 | ITEM is not string." | |
| 234 | (if (stringp item) | |
| 235 | (get-text-property 0 property item))) | |
| 236 | ||
| 237 | (cl-defun popup-make-item (name | |
| 238 | &key | |
| 239 | value | |
| 240 | face | |
| 241 | mouse-face | |
| 242 | selection-face | |
| 243 | sublist | |
| 244 | document | |
| 245 | symbol | |
| 246 | summary) | |
| 247 | "Utility function to make popup item. See also | |
| 248 | `popup-item-propertize'." | |
| 249 | (popup-item-propertize name | |
| 250 | 'value value | |
| 251 | 'popup-face face | |
| 252 | 'popup-mouse-face mouse-face | |
| 253 | 'selection-face selection-face | |
| 254 | 'document document | |
| 255 | 'symbol symbol | |
| 256 | 'summary summary | |
| 257 | 'sublist sublist)) | |
| 258 | ||
| 259 | (defsubst popup-item-value (item) (popup-item-property item 'value)) | |
| 260 | (defsubst popup-item-value-or-self (item) (or (popup-item-value item) item)) | |
| 261 | (defsubst popup-item-face (item) (popup-item-property item 'popup-face)) | |
| 262 | (defsubst popup-item-mouse-face (item) (popup-item-property item 'popup-mouse-face)) | |
| 263 | (defsubst popup-item-selection-face (item) (popup-item-property item 'selection-face)) | |
| 264 | (defsubst popup-item-document (item) (popup-item-property item 'document)) | |
| 265 | (defsubst popup-item-summary (item) (popup-item-property item 'summary)) | |
| 266 | (defsubst popup-item-symbol (item) (popup-item-property item 'symbol)) | |
| 267 | (defsubst popup-item-sublist (item) (popup-item-property item 'sublist)) | |
| 268 | ||
| 269 | (defun popup-item-documentation (item) | |
| 270 | (let ((doc (popup-item-document item))) | |
| 271 | (if (functionp doc) | |
| 272 | (setq doc (funcall doc (popup-item-value-or-self item)))) | |
| 273 | doc)) | |
| 274 | ||
| 275 | (defun popup-item-show-help-1 (item) | |
| 276 | (let ((doc (popup-item-documentation item))) | |
| 277 | (when doc | |
| 278 | (with-current-buffer (get-buffer-create " *Popup Help*") | |
| 279 | (erase-buffer) | |
| 280 | (insert doc) | |
| 281 | (goto-char (point-min)) | |
| 282 | (display-buffer (current-buffer))) | |
| 283 | t))) | |
| 284 | ||
| 285 | (defun popup-item-show-help-with-event-loop (item) | |
| 286 | (save-window-excursion | |
| 287 | (when (popup-item-show-help-1 item) | |
| 288 | (cl-loop do (clear-this-command-keys) | |
| 289 | for key = (read-key-sequence-vector nil) | |
| 290 | do | |
| 291 | (cl-case (key-binding key) | |
| 292 | (scroll-other-window | |
| 293 | (scroll-other-window)) | |
| 294 | (scroll-other-window-down | |
| 295 | (scroll-other-window-down nil)) | |
| 296 | (otherwise | |
| 297 | (setq unread-command-events (append key unread-command-events)) | |
| 298 | (cl-return))))))) | |
| 299 | ||
| 300 | (defun popup-item-show-help (item &optional persist) | |
| 301 | "Display the documentation of ITEM with `display-buffer'. If | |
| 302 | PERSIST is nil, the documentation buffer will be closed | |
| 303 | automatically, meaning interal event loop ensures the buffer to | |
| 304 | be closed. Otherwise, the buffer will be just displayed as | |
| 305 | usual." | |
| 306 | (when item | |
| 307 | (if (not persist) | |
| 308 | (popup-item-show-help-with-event-loop item) | |
| 309 | (popup-item-show-help-1 item)))) | |
| 310 | ||
| 311 | (defun popup-set-list (popup list) | |
| 312 | (popup-set-filtered-list popup list) | |
| 313 | (setf (popup-pattern popup) nil) | |
| 314 | (setf (popup-original-list popup) list)) | |
| 315 | ||
| 316 | (defun popup-set-filtered-list (popup list) | |
| 317 | (let ((offset | |
| 318 | (if (> (popup-direction popup) 0) | |
| 319 | 0 | |
| 320 | (max (- (popup-height popup) (length list)) 0)))) | |
| 321 | (setf (popup-list popup) list | |
| 322 | (popup-offset popup) offset))) | |
| 323 | ||
| 324 | (defun popup-selected-item (popup) | |
| 325 | (nth (popup-cursor popup) (popup-list popup))) | |
| 326 | ||
| 327 | (defun popup-selected-line (popup) | |
| 328 | (- (popup-cursor popup) (popup-scroll-top popup))) | |
| 329 | ||
| 330 | (defun popup-line-overlay (popup line) | |
| 331 | (aref (popup-overlays popup) line)) | |
| 332 | ||
| 333 | (defun popup-selected-line-overlay (popup) | |
| 334 | (popup-line-overlay popup (popup-selected-line popup))) | |
| 335 | ||
| 336 | (defun popup-hide-line (popup line) | |
| 337 | (let ((overlay (popup-line-overlay popup line))) | |
| 338 | (overlay-put overlay 'display nil) | |
| 339 | (overlay-put overlay 'after-string nil))) | |
| 340 | ||
| 341 | (defun popup-line-hidden-p (popup line) | |
| 342 | (let ((overlay (popup-line-overlay popup line))) | |
| 343 | (and (eq (overlay-get overlay 'display) nil) | |
| 344 | (eq (overlay-get overlay 'after-string) nil)))) | |
| 345 | ||
| 346 | (cl-defun popup-set-line-item (popup | |
| 347 | line | |
| 348 | &key | |
| 349 | item | |
| 350 | face | |
| 351 | mouse-face | |
| 352 | margin-left | |
| 353 | margin-right | |
| 354 | scroll-bar-char | |
| 355 | symbol | |
| 356 | summary | |
| 357 | summary-face | |
| 358 | keymap) | |
| 359 | (let* ((overlay (popup-line-overlay popup line)) | |
| 360 | (content (popup-create-line-string popup (popup-x-to-string item) | |
| 361 | :margin-left margin-left | |
| 362 | :margin-right margin-right | |
| 363 | :symbol symbol | |
| 364 | :summary summary | |
| 365 | :summary-face summary-face)) | |
| 366 | (start 0) | |
| 367 | (prefix (overlay-get overlay 'prefix)) | |
| 368 | (postfix (overlay-get overlay 'postfix)) | |
| 369 | end) | |
| 370 | (put-text-property 0 (length content) 'popup-item item content) | |
| 371 | (put-text-property 0 (length content) 'keymap keymap content) | |
| 372 | ;; Overlap face properties | |
| 373 | (when (get-text-property start 'face content) | |
| 374 | (setq start (next-single-property-change start 'face content))) | |
| 375 | (while (and start (setq end (next-single-property-change start 'face content))) | |
| 376 | (put-text-property start end 'face face content) | |
| 377 | (setq start (next-single-property-change end 'face content))) | |
| 378 | (when start | |
| 379 | (put-text-property start (length content) 'face face content)) | |
| 380 | (when mouse-face | |
| 381 | (put-text-property 0 (length content) 'mouse-face mouse-face content)) | |
| 382 | (let ((prop (if (overlay-get overlay 'dangle) | |
| 383 | 'after-string | |
| 384 | 'display))) | |
| 385 | (overlay-put overlay | |
| 386 | prop | |
| 387 | (concat prefix | |
| 388 | content | |
| 389 | scroll-bar-char | |
| 390 | postfix))))) | |
| 391 | ||
| 392 | (cl-defun popup-create-line-string (popup | |
| 393 | string | |
| 394 | &key | |
| 395 | margin-left | |
| 396 | margin-right | |
| 397 | symbol | |
| 398 | summary | |
| 399 | summary-face) | |
| 400 | (let* ((popup-width (popup-width popup)) | |
| 401 | (summary-width (string-width summary)) | |
| 402 | (content-width (max | |
| 403 | (min popup-width (string-width string)) | |
| 404 | (- popup-width | |
| 405 | (if (> summary-width 0) | |
| 406 | (+ summary-width 2) | |
| 407 | 0)))) | |
| 408 | (string (car (popup-substring-by-width string content-width))) | |
| 409 | (string-width (string-width string)) | |
| 410 | (spacing (max (- popup-width string-width summary-width) | |
| 411 | (if (> popup-width string-width) 1 0))) | |
| 412 | (truncated-summary | |
| 413 | (car (popup-substring-by-width | |
| 414 | summary (max (- popup-width string-width spacing) 0))))) | |
| 415 | (when summary-face | |
| 416 | (put-text-property 0 (length truncated-summary) | |
| 417 | 'face summary-face truncated-summary)) | |
| 418 | (concat margin-left | |
| 419 | string | |
| 420 | (make-string spacing ? ) | |
| 421 | truncated-summary | |
| 422 | symbol | |
| 423 | margin-right))) | |
| 424 | ||
| 425 | (defun popup-live-p (popup) | |
| 426 | "Return non-nil if POPUP is alive." | |
| 427 | (and popup (popup-overlays popup) t)) | |
| 428 | ||
| 429 | (defun popup-child-point (popup &optional offset) | |
| 430 | (overlay-end | |
| 431 | (popup-line-overlay | |
| 432 | popup | |
| 433 | (or offset | |
| 434 | (popup-selected-line popup))))) | |
| 435 | ||
| 436 | (defun popup-calculate-direction (height row) | |
| 437 | "Return a proper direction when displaying a popup on this | |
| 438 | window. HEIGHT is the a height of the popup, and ROW is a line | |
| 439 | number at the point." | |
| 440 | (let* ((remaining-rows (- (max 1 (- (window-height) | |
| 441 | (if mode-line-format 1 0) | |
| 442 | (if header-line-format 1 0))) | |
| 443 | (count-lines (window-start) (point)))) | |
| 444 | (enough-space-above (> row height)) | |
| 445 | (enough-space-below (<= height remaining-rows))) | |
| 446 | (if (and enough-space-above | |
| 447 | (not enough-space-below)) | |
| 448 | -1 | |
| 449 | 1))) | |
| 450 | ||
| 451 | (cl-defun popup-create (point | |
| 452 | width | |
| 453 | height | |
| 454 | &key | |
| 455 | min-height | |
| 456 | max-width | |
| 457 | around | |
| 458 | (face 'popup-face) | |
| 459 | mouse-face | |
| 460 | (selection-face face) | |
| 461 | (summary-face 'popup-summary-face) | |
| 462 | scroll-bar | |
| 463 | margin-left | |
| 464 | margin-right | |
| 465 | symbol | |
| 466 | parent | |
| 467 | parent-offset | |
| 468 | keymap) | |
| 469 | "Create a popup instance at POINT with WIDTH and HEIGHT. | |
| 470 | ||
| 471 | MIN-HEIGHT is a minimal height of the popup. The default value is | |
| 472 | 0. | |
| 473 | ||
| 474 | MAX-WIDTH is the maximum width of the popup. The default value is | |
| 475 | nil (no limit). If a floating point, the value refers to the ratio of | |
| 476 | the window. If an integer, limit is in characters. | |
| 477 | ||
| 478 | If AROUND is non-nil, the popup will be displayed around the | |
| 479 | point but not at the point. | |
| 480 | ||
| 481 | FACE is a background face of the popup. The default value is POPUP-FACE. | |
| 482 | ||
| 483 | SELECTION-FACE is a foreground (selection) face of the popup The | |
| 484 | default value is POPUP-FACE. | |
| 485 | ||
| 486 | If SCROLL-BAR is non-nil, the popup will have a scroll bar at the | |
| 487 | right. | |
| 488 | ||
| 489 | If MARGIN-LEFT is non-nil, the popup will have a margin at the | |
| 490 | left. | |
| 491 | ||
| 492 | If MARGIN-RIGHT is non-nil, the popup will have a margin at the | |
| 493 | right. | |
| 494 | ||
| 495 | SYMBOL is a single character which indicates a kind of the item. | |
| 496 | ||
| 497 | PARENT is a parent popup instance. If PARENT is omitted, the | |
| 498 | popup will be a root instance. | |
| 499 | ||
| 500 | PARENT-OFFSET is a row offset from the parent popup. | |
| 501 | ||
| 502 | KEYMAP is a keymap that will be put on the popup contents." | |
| 503 | (or margin-left (setq margin-left 0)) | |
| 504 | (or margin-right (setq margin-right 0)) | |
| 505 | (unless point | |
| 506 | (setq point | |
| 507 | (if parent (popup-child-point parent parent-offset) (point)))) | |
| 508 | (when max-width | |
| 509 | (setq width (min width (popup-calculate-max-width max-width)))) | |
| 510 | (save-excursion | |
| 511 | (goto-char point) | |
| 512 | (let* ((col-row (posn-col-row (posn-at-point))) | |
| 513 | (row (cdr col-row)) | |
| 514 | (column (car col-row)) | |
| 515 | (overlays (make-vector height nil)) | |
| 516 | (popup-width (+ width | |
| 517 | (if scroll-bar 1 0) | |
| 518 | margin-left | |
| 519 | margin-right | |
| 520 | (if symbol 2 0))) | |
| 521 | margin-left-cancel | |
| 522 | (window (selected-window)) | |
| 523 | (window-start (window-start)) | |
| 524 | (window-hscroll (window-hscroll)) | |
| 525 | (window-width (window-width)) | |
| 526 | (right (+ column popup-width)) | |
| 527 | (overflow (and (> right window-width) | |
| 528 | (>= right popup-width))) | |
| 529 | (foldable (and (null parent) | |
| 530 | (>= column popup-width))) | |
| 531 | (direction (or | |
| 532 | ;; Currently the direction of cascade popup won't be changed | |
| 533 | (and parent (popup-direction parent)) | |
| 534 | ||
| 535 | ;; Calculate direction | |
| 536 | (popup-calculate-direction height row))) | |
| 537 | (depth (if parent (1+ (popup-depth parent)) 0)) | |
| 538 | (newlines (max 0 (+ (- height (count-lines point (point-max))) (if around 1 0)))) | |
| 539 | invis-overlays | |
| 540 | current-column) | |
| 541 | ;; Case: no newlines at the end of the buffer | |
| 542 | (when (> newlines 0) | |
| 543 | (popup-save-buffer-state | |
| 544 | (goto-char (point-max)) | |
| 545 | (insert (make-string newlines ?\n)))) | |
| 546 | ||
| 547 | ;; Case: the popup overflows | |
| 548 | (if overflow | |
| 549 | (if foldable | |
| 550 | (progn | |
| 551 | (cl-decf column (- popup-width margin-left margin-right)) | |
| 552 | (unless around (move-to-column column))) | |
| 553 | (when (not truncate-lines) | |
| 554 | ;; Truncate. | |
| 555 | (let ((d (1+ (- popup-width (- window-width column))))) | |
| 556 | (cl-decf popup-width d) | |
| 557 | (cl-decf width d))) | |
| 558 | (cl-decf column margin-left)) | |
| 559 | (cl-decf column margin-left)) | |
| 560 | ||
| 561 | ;; Case: no space at the left | |
| 562 | (when (and (null parent) | |
| 563 | (< column 0)) | |
| 564 | ;; Cancel margin left | |
| 565 | (setq column 0) | |
| 566 | (cl-decf popup-width margin-left) | |
| 567 | (setq margin-left-cancel t)) | |
| 568 | ||
| 569 | (dotimes (i height) | |
| 570 | (let (overlay begin w (dangle t) (prefix "") (postfix "")) | |
| 571 | (when around | |
| 572 | (popup-vertical-motion column direction)) | |
| 573 | (cl-loop for ov in (overlays-in (save-excursion | |
| 574 | (beginning-of-visual-line) | |
| 575 | (point)) | |
| 576 | (save-excursion | |
| 577 | (end-of-visual-line) | |
| 578 | (point))) | |
| 579 | when (and (not (overlay-get ov 'popup)) | |
| 580 | (not (overlay-get ov 'popup-item)) | |
| 581 | (or (overlay-get ov 'invisible) | |
| 582 | (overlay-get ov 'display))) | |
| 583 | do (progn | |
| 584 | (push (list ov (overlay-get ov 'display)) invis-overlays) | |
| 585 | (overlay-put ov 'display ""))) | |
| 586 | (setq around t) | |
| 587 | (setq current-column (car (posn-col-row (posn-at-point)))) | |
| 588 | ||
| 589 | (when (< current-column column) | |
| 590 | ;; Extend short buffer lines by popup prefix (line of spaces) | |
| 591 | (setq prefix (make-string | |
| 592 | (+ (if (= current-column 0) | |
| 593 | (- window-hscroll current-column) | |
| 594 | 0) | |
| 595 | (- column current-column)) | |
| 596 | ? ))) | |
| 597 | ||
| 598 | (setq begin (point)) | |
| 599 | (setq w (+ popup-width (length prefix))) | |
| 600 | (while (and (not (eolp)) (> w 0)) | |
| 601 | (setq dangle nil) | |
| 602 | (cl-decf w (char-width (char-after))) | |
| 603 | (forward-char)) | |
| 604 | (if (< w 0) | |
| 605 | (setq postfix (make-string (- w) ? ))) | |
| 606 | ||
| 607 | (setq overlay (make-overlay begin (point))) | |
| 608 | (overlay-put overlay 'popup t) | |
| 609 | (overlay-put overlay 'window window) | |
| 610 | (overlay-put overlay 'dangle dangle) | |
| 611 | (overlay-put overlay 'prefix prefix) | |
| 612 | (overlay-put overlay 'postfix postfix) | |
| 613 | (overlay-put overlay 'width width) | |
| 614 | (aset overlays | |
| 615 | (if (> direction 0) i (- height i 1)) | |
| 616 | overlay))) | |
| 617 | (cl-loop for p from (- 10000 (* depth 1000)) | |
| 618 | for overlay in (nreverse (append overlays nil)) | |
| 619 | do (overlay-put overlay 'priority p)) | |
| 620 | (let ((it (make-popup :point point | |
| 621 | :row row | |
| 622 | :column column | |
| 623 | :width width | |
| 624 | :height height | |
| 625 | :min-height min-height | |
| 626 | :direction direction | |
| 627 | :parent parent | |
| 628 | :depth depth | |
| 629 | :face face | |
| 630 | :mouse-face mouse-face | |
| 631 | :selection-face selection-face | |
| 632 | :summary-face summary-face | |
| 633 | :margin-left margin-left | |
| 634 | :margin-right margin-right | |
| 635 | :margin-left-cancel margin-left-cancel | |
| 636 | :scroll-bar scroll-bar | |
| 637 | :symbol symbol | |
| 638 | :cursor 0 | |
| 639 | :offset 0 | |
| 640 | :scroll-top 0 | |
| 641 | :current-height 0 | |
| 642 | :list nil | |
| 643 | :newlines newlines | |
| 644 | :overlays overlays | |
| 645 | :invis-overlays invis-overlays | |
| 646 | :keymap keymap))) | |
| 647 | (push it popup-instances) | |
| 648 | it)))) | |
| 649 | ||
| 650 | (defun popup-delete (popup) | |
| 651 | "Delete POPUP instance." | |
| 652 | (when (popup-live-p popup) | |
| 653 | (popup-hide popup) | |
| 654 | (mapc 'delete-overlay (popup-overlays popup)) | |
| 655 | (setf (popup-overlays popup) nil) | |
| 656 | (setq popup-instances (delq popup popup-instances)) | |
| 657 | ;; Restore newlines state | |
| 658 | (let ((newlines (popup-newlines popup))) | |
| 659 | (when (> newlines 0) | |
| 660 | (popup-save-buffer-state | |
| 661 | (goto-char (point-max)) | |
| 662 | (dotimes (i newlines) | |
| 663 | (if (and (char-before) | |
| 664 | (= (char-before) ?\n)) | |
| 665 | (delete-char -1))))))) | |
| 666 | nil) | |
| 667 | ||
| 668 | (defun popup-draw (popup) | |
| 669 | "Draw POPUP." | |
| 670 | (cl-loop for (ov olddisplay) in (popup-invis-overlays popup) | |
| 671 | do (overlay-put ov 'display "")) | |
| 672 | ||
| 673 | (cl-loop with height = (popup-height popup) | |
| 674 | with min-height = (popup-min-height popup) | |
| 675 | with popup-face = (popup-face popup) | |
| 676 | with mouse-face = (popup-mouse-face popup) | |
| 677 | with selection-face = (popup-selection-face popup) | |
| 678 | with summary-face-0 = (popup-summary-face popup) | |
| 679 | with list = (popup-list popup) | |
| 680 | with length = (length list) | |
| 681 | with thum-size = (max (/ (* height height) (max length 1)) 1) | |
| 682 | with page-size = (/ (+ 0.0 (max length 1)) height) | |
| 683 | with scroll-bar = (popup-scroll-bar popup) | |
| 684 | with margin-left = (make-string (if (popup-margin-left-cancel popup) 0 (popup-margin-left popup)) ? ) | |
| 685 | with margin-right = (make-string (popup-margin-right popup) ? ) | |
| 686 | with symbol = (popup-symbol popup) | |
| 687 | with cursor = (popup-cursor popup) | |
| 688 | with scroll-top = (popup-scroll-top popup) | |
| 689 | with offset = (popup-offset popup) | |
| 690 | with keymap = (popup-keymap popup) | |
| 691 | for o from offset | |
| 692 | for i from scroll-top | |
| 693 | while (< o height) | |
| 694 | for item in (nthcdr scroll-top list) | |
| 695 | for page-index = (* thum-size (/ o thum-size)) | |
| 696 | for face = (if (= i cursor) | |
| 697 | (or (popup-item-selection-face item) selection-face) | |
| 698 | (or (popup-item-face item) popup-face)) | |
| 699 | for summary-face = (unless (= i cursor) summary-face-0) | |
| 700 | for empty-char = (propertize " " 'face face) | |
| 701 | for scroll-bar-char = (if scroll-bar | |
| 702 | (cond | |
| 703 | ((and (not (eq scroll-bar :always)) | |
| 704 | (<= page-size 1)) | |
| 705 | empty-char) | |
| 706 | ((and (> page-size 1) | |
| 707 | (>= cursor (* page-index page-size)) | |
| 708 | (< cursor (* (+ page-index thum-size) page-size))) | |
| 709 | popup-scroll-bar-foreground-char) | |
| 710 | (t | |
| 711 | popup-scroll-bar-background-char)) | |
| 712 | "") | |
| 713 | for sym = (if symbol | |
| 714 | (concat " " (or (popup-item-symbol item) " ")) | |
| 715 | "") | |
| 716 | for summary = (or (popup-item-summary item) "") | |
| 717 | ||
| 718 | do | |
| 719 | ;; Show line and set item to the line | |
| 720 | (popup-set-line-item popup o | |
| 721 | :item item | |
| 722 | :face face | |
| 723 | :mouse-face mouse-face | |
| 724 | :margin-left margin-left | |
| 725 | :margin-right margin-right | |
| 726 | :scroll-bar-char scroll-bar-char | |
| 727 | :symbol sym | |
| 728 | :summary summary | |
| 729 | :summary-face summary-face | |
| 730 | :keymap keymap) | |
| 731 | ||
| 732 | finally | |
| 733 | ;; Remember current height | |
| 734 | (setf (popup-current-height popup) (- o offset)) | |
| 735 | ||
| 736 | ;; Hide remaining lines | |
| 737 | (let ((scroll-bar-char (if scroll-bar (propertize " " 'face popup-face) "")) | |
| 738 | (symbol (if symbol " " ""))) | |
| 739 | (if (> (popup-direction popup) 0) | |
| 740 | (progn | |
| 741 | (when min-height | |
| 742 | (while (< o min-height) | |
| 743 | (popup-set-line-item popup o | |
| 744 | :item "" | |
| 745 | :face popup-face | |
| 746 | :margin-left margin-left | |
| 747 | :margin-right margin-right | |
| 748 | :scroll-bar-char scroll-bar-char | |
| 749 | :symbol symbol | |
| 750 | :summary "") | |
| 751 | (cl-incf o))) | |
| 752 | (while (< o height) | |
| 753 | (popup-hide-line popup o) | |
| 754 | (cl-incf o))) | |
| 755 | (cl-loop with h = (if min-height (- height min-height) offset) | |
| 756 | for o from 0 below offset | |
| 757 | if (< o h) | |
| 758 | do (popup-hide-line popup o) | |
| 759 | if (>= o h) | |
| 760 | do (popup-set-line-item popup o | |
| 761 | :item "" | |
| 762 | :face popup-face | |
| 763 | :margin-left margin-left | |
| 764 | :margin-right margin-right | |
| 765 | :scroll-bar-char scroll-bar-char | |
| 766 | :symbol symbol | |
| 767 | :summary "")))))) | |
| 768 | ||
| 769 | (defun popup-hide (popup) | |
| 770 | "Hide POPUP." | |
| 771 | (cl-loop for (ov olddisplay) in (popup-invis-overlays popup) | |
| 772 | do (overlay-put ov 'display olddisplay)) | |
| 773 | (dotimes (i (popup-height popup)) | |
| 774 | (popup-hide-line popup i))) | |
| 775 | ||
| 776 | (defun popup-hidden-p (popup) | |
| 777 | "Return non-nil if POPUP is hidden." | |
| 778 | (let ((hidden t)) | |
| 779 | (when (popup-live-p popup) | |
| 780 | (dotimes (i (popup-height popup)) | |
| 781 | (unless (popup-line-hidden-p popup i) | |
| 782 | (setq hidden nil)))) | |
| 783 | hidden)) | |
| 784 | ||
| 785 | (defun popup-jump (popup cursor) | |
| 786 | "Jump to a position specified by CURSOR of POPUP and draw." | |
| 787 | (let ((scroll-top (popup-scroll-top popup))) | |
| 788 | ;; Do not change page as much as possible. | |
| 789 | (unless (and (<= scroll-top cursor) | |
| 790 | (< cursor (+ scroll-top (popup-height popup)))) | |
| 791 | (setf (popup-scroll-top popup) cursor)) | |
| 792 | (setf (popup-cursor popup) cursor) | |
| 793 | (popup-draw popup))) | |
| 794 | ||
| 795 | (defun popup-select (popup i) | |
| 796 | "Select the item at I of POPUP and draw." | |
| 797 | (setq i (+ i (popup-offset popup))) | |
| 798 | (when (and (<= 0 i) (< i (popup-height popup))) | |
| 799 | (setf (popup-cursor popup) i) | |
| 800 | (popup-draw popup) | |
| 801 | t)) | |
| 802 | ||
| 803 | (defun popup-next (popup) | |
| 804 | "Select the next item of POPUP and draw." | |
| 805 | (let ((height (popup-height popup)) | |
| 806 | (cursor (1+ (popup-cursor popup))) | |
| 807 | (scroll-top (popup-scroll-top popup)) | |
| 808 | (length (length (popup-list popup)))) | |
| 809 | (cond | |
| 810 | ((>= cursor length) | |
| 811 | ;; Back to first page | |
| 812 | (setq cursor 0 | |
| 813 | scroll-top 0)) | |
| 814 | ((= cursor (+ scroll-top height)) | |
| 815 | ;; Go to next page | |
| 816 | (setq scroll-top (min (1+ scroll-top) (max (- length height) 0))))) | |
| 817 | (setf (popup-cursor popup) cursor | |
| 818 | (popup-scroll-top popup) scroll-top) | |
| 819 | (popup-draw popup))) | |
| 820 | ||
| 821 | (defun popup-previous (popup) | |
| 822 | "Select the previous item of POPUP and draw." | |
| 823 | (let ((height (popup-height popup)) | |
| 824 | (cursor (1- (popup-cursor popup))) | |
| 825 | (scroll-top (popup-scroll-top popup)) | |
| 826 | (length (length (popup-list popup)))) | |
| 827 | (cond | |
| 828 | ((< cursor 0) | |
| 829 | ;; Go to last page | |
| 830 | (setq cursor (1- length) | |
| 831 | scroll-top (max (- length height) 0))) | |
| 832 | ((= cursor (1- scroll-top)) | |
| 833 | ;; Go to previous page | |
| 834 | (cl-decf scroll-top))) | |
| 835 | (setf (popup-cursor popup) cursor | |
| 836 | (popup-scroll-top popup) scroll-top) | |
| 837 | (popup-draw popup))) | |
| 838 | ||
| 839 | (defun popup-page-next (popup) | |
| 840 | "Select next item of POPUP per `popup-height' range. | |
| 841 | Pages down through POPUP." | |
| 842 | (dotimes (counter (1- (popup-height popup))) | |
| 843 | (popup-next popup))) | |
| 844 | ||
| 845 | (defun popup-page-previous (popup) | |
| 846 | "Select previous item of POPUP per `popup-height' range. | |
| 847 | Pages up through POPUP." | |
| 848 | (dotimes (counter (1- (popup-height popup))) | |
| 849 | (popup-previous popup))) | |
| 850 | ||
| 851 | (defun popup-scroll-down (popup &optional n) | |
| 852 | "Scroll down N of POPUP and draw." | |
| 853 | (let ((scroll-top (min (+ (popup-scroll-top popup) (or n 1)) | |
| 854 | (- (length (popup-list popup)) (popup-height popup))))) | |
| 855 | (setf (popup-cursor popup) scroll-top | |
| 856 | (popup-scroll-top popup) scroll-top) | |
| 857 | (popup-draw popup))) | |
| 858 | ||
| 859 | (defun popup-scroll-up (popup &optional n) | |
| 860 | "Scroll up N of POPUP and draw." | |
| 861 | (let ((scroll-top (max (- (popup-scroll-top popup) (or n 1)) | |
| 862 | 0))) | |
| 863 | (setf (popup-cursor popup) scroll-top | |
| 864 | (popup-scroll-top popup) scroll-top) | |
| 865 | (popup-draw popup))) | |
| 866 | ||
| 867 | ||
| 868 | ||
| 869 | ;;; Popup Incremental Search | |
| 870 | ||
| 871 | (defface popup-isearch-match | |
| 872 | '((t (:inherit default :background "sky blue"))) | |
| 873 | "Popup isearch match face." | |
| 874 | :group 'popup) | |
| 875 | ||
| 876 | (defvar popup-isearch-cursor-color "blue") | |
| 877 | ||
| 878 | (defvar popup-isearch-keymap | |
| 879 | (let ((map (make-sparse-keymap))) | |
| 880 | ;(define-key map "\r" 'popup-isearch-done) | |
| 881 | (define-key map "\C-g" 'popup-isearch-cancel) | |
| 882 | (define-key map "\C-b" 'popup-isearch-close) | |
| 883 | (define-key map [left] 'popup-isearch-close) | |
| 884 | (define-key map "\C-h" 'popup-isearch-delete) | |
| 885 | (define-key map (kbd "DEL") 'popup-isearch-delete) | |
| 886 | (define-key map (kbd "C-y") 'popup-isearch-yank) | |
| 887 | map)) | |
| 888 | ||
| 889 | (defvar popup-menu-show-quick-help-function 'popup-menu-show-quick-help | |
| 890 | "Function used for showing quick help by `popup-menu*'.") | |
| 891 | ||
| 892 | (defcustom popup-isearch-regexp-builder-function #'regexp-quote | |
| 893 | "Function used to construct a regexp from a pattern. You may for instance | |
| 894 | provide a function that replaces spaces by '.+' if you like helm or ivy style | |
| 895 | of completion." | |
| 896 | :type 'function) | |
| 897 | ||
| 898 | (defsubst popup-isearch-char-p (char) | |
| 899 | (and (integerp char) | |
| 900 | (<= 32 char) | |
| 901 | (<= char 126))) | |
| 902 | ||
| 903 | (defun popup-isearch-filter-list (pattern list) | |
| 904 | (cl-loop with regexp = (funcall popup-isearch-regexp-builder-function pattern) | |
| 905 | for item in list | |
| 906 | do | |
| 907 | (unless (stringp item) | |
| 908 | (setq item (popup-item-propertize (popup-x-to-string item) | |
| 909 | 'value item))) | |
| 910 | if (string-match regexp item) | |
| 911 | collect | |
| 912 | (let ((beg (match-beginning 0)) | |
| 913 | (end (match-end 0))) | |
| 914 | (alter-text-property 0 (length item) 'face | |
| 915 | (lambda (prop) | |
| 916 | (unless (eq prop 'popup-isearch-match) | |
| 917 | prop)) | |
| 918 | item) | |
| 919 | (put-text-property beg end | |
| 920 | 'face 'popup-isearch-match | |
| 921 | item) | |
| 922 | item))) | |
| 923 | ||
| 924 | (defun popup-isearch-prompt (popup pattern) | |
| 925 | (format "Pattern: %s" (if (= (length (popup-list popup)) 0) | |
| 926 | (propertize pattern 'face 'isearch-fail) | |
| 927 | pattern))) | |
| 928 | ||
| 929 | (defun popup-isearch-update (popup filter pattern &optional callback) | |
| 930 | (setf (popup-cursor popup) 0 | |
| 931 | (popup-scroll-top popup) 0 | |
| 932 | (popup-pattern popup) pattern) | |
| 933 | (let ((list (funcall filter pattern (popup-original-list popup)))) | |
| 934 | (popup-set-filtered-list popup list) | |
| 935 | (if callback | |
| 936 | (funcall callback list))) | |
| 937 | (popup-draw popup)) | |
| 938 | ||
| 939 | (cl-defun popup-isearch (popup | |
| 940 | &key | |
| 941 | (filter 'popup-isearch-filter-list) | |
| 942 | (cursor-color popup-isearch-cursor-color) | |
| 943 | (keymap popup-isearch-keymap) | |
| 944 | callback | |
| 945 | help-delay) | |
| 946 | "Start isearch on POPUP. This function is synchronized, meaning | |
| 947 | event loop waits for quiting of isearch. | |
| 948 | ||
| 949 | FILTER is function with two argumenst to perform popup items filtering. | |
| 950 | ||
| 951 | CURSOR-COLOR is a cursor color during isearch. The default value | |
| 952 | is `popup-isearch-cursor-color'. | |
| 953 | ||
| 954 | KEYMAP is a keymap which is used when processing events during | |
| 955 | event loop. The default value is `popup-isearch-keymap'. | |
| 956 | ||
| 957 | CALLBACK is a function taking one argument. `popup-isearch' calls | |
| 958 | CALLBACK, if specified, after isearch finished or isearch | |
| 959 | canceled. The arguments is whole filtered list of items. | |
| 960 | ||
| 961 | HELP-DELAY is a delay of displaying helps." | |
| 962 | (let ((list (popup-original-list popup)) | |
| 963 | (pattern (or (popup-pattern popup) "")) | |
| 964 | (old-cursor-color (frame-parameter (selected-frame) 'cursor-color)) | |
| 965 | prompt key binding) | |
| 966 | (unwind-protect | |
| 967 | (cl-block nil | |
| 968 | (if cursor-color | |
| 969 | (set-cursor-color cursor-color)) | |
| 970 | (while t | |
| 971 | (setq prompt (popup-isearch-prompt popup pattern)) | |
| 972 | (setq key (popup-menu-read-key-sequence keymap prompt help-delay)) | |
| 973 | (if (null key) | |
| 974 | (unless (funcall popup-menu-show-quick-help-function popup nil :prompt prompt) | |
| 975 | (clear-this-command-keys) | |
| 976 | (push (read-event prompt) unread-command-events)) | |
| 977 | (setq binding (lookup-key keymap key)) | |
| 978 | (cond | |
| 979 | ((and (stringp key) | |
| 980 | (popup-isearch-char-p (aref key 0))) | |
| 981 | (setq pattern (concat pattern key))) | |
| 982 | ((eq binding 'popup-isearch-done) | |
| 983 | (cl-return nil)) | |
| 984 | ((eq binding 'popup-isearch-cancel) | |
| 985 | (popup-isearch-update popup filter "" callback) | |
| 986 | (cl-return t)) | |
| 987 | ((eq binding 'popup-isearch-close) | |
| 988 | (popup-isearch-update popup filter "" callback) | |
| 989 | (setq unread-command-events | |
| 990 | (append (listify-key-sequence key) unread-command-events)) | |
| 991 | (cl-return nil)) | |
| 992 | ((eq binding 'popup-isearch-delete) | |
| 993 | (if (> (length pattern) 0) | |
| 994 | (setq pattern (substring pattern 0 (1- (length pattern)))))) | |
| 995 | ((eq binding 'popup-isearch-yank) | |
| 996 | (popup-isearch-update popup filter (car kill-ring) callback) | |
| 997 | (cl-return nil)) | |
| 998 | (t | |
| 999 | (setq unread-command-events | |
| 1000 | (append (listify-key-sequence key) unread-command-events)) | |
| 1001 | (cl-return nil))) | |
| 1002 | (popup-isearch-update popup filter pattern callback)))) | |
| 1003 | (if old-cursor-color | |
| 1004 | (set-cursor-color old-cursor-color))))) | |
| 1005 | ||
| 1006 | ||
| 1007 | ||
| 1008 | ;;; Popup Tip | |
| 1009 | ||
| 1010 | (defface popup-tip-face | |
| 1011 | '((t (:background "khaki1" :foreground "black"))) | |
| 1012 | "Face for popup tip." | |
| 1013 | :group 'popup) | |
| 1014 | ||
| 1015 | (defvar popup-tip-max-width 80) | |
| 1016 | ||
| 1017 | (cl-defun popup-tip (string | |
| 1018 | &key | |
| 1019 | point | |
| 1020 | (around t) | |
| 1021 | width | |
| 1022 | (height 15) | |
| 1023 | min-height | |
| 1024 | max-width | |
| 1025 | truncate | |
| 1026 | margin | |
| 1027 | margin-left | |
| 1028 | margin-right | |
| 1029 | scroll-bar | |
| 1030 | parent | |
| 1031 | parent-offset | |
| 1032 | nowait | |
| 1033 | nostrip | |
| 1034 | prompt | |
| 1035 | &aux tip lines) | |
| 1036 | "Show a tooltip of STRING at POINT. This function is | |
| 1037 | synchronized unless NOWAIT specified. Almost all arguments are | |
| 1038 | the same as in `popup-create', except for TRUNCATE, NOWAIT, and | |
| 1039 | PROMPT. | |
| 1040 | ||
| 1041 | If TRUNCATE is non-nil, the tooltip can be truncated. | |
| 1042 | ||
| 1043 | If NOWAIT is non-nil, this function immediately returns the | |
| 1044 | tooltip instance without entering event loop. | |
| 1045 | ||
| 1046 | If `NOSTRIP` is non-nil, `STRING` properties are not stripped. | |
| 1047 | ||
| 1048 | PROMPT is a prompt string when reading events during event loop." | |
| 1049 | (if (bufferp string) | |
| 1050 | (setq string (with-current-buffer string (buffer-string)))) | |
| 1051 | ||
| 1052 | (unless nostrip | |
| 1053 | ;; TODO strip text (mainly face) properties | |
| 1054 | (setq string (substring-no-properties string))) | |
| 1055 | ||
| 1056 | (and (eq margin t) (setq margin 1)) | |
| 1057 | (or margin-left (setq margin-left margin)) | |
| 1058 | (or margin-right (setq margin-right margin)) | |
| 1059 | ||
| 1060 | (let ((it (popup-fill-string string width popup-tip-max-width))) | |
| 1061 | (setq width (car it) | |
| 1062 | lines (cdr it))) | |
| 1063 | ||
| 1064 | (setq tip (popup-create point width height | |
| 1065 | :min-height min-height | |
| 1066 | :max-width max-width | |
| 1067 | :around around | |
| 1068 | :margin-left margin-left | |
| 1069 | :margin-right margin-right | |
| 1070 | :scroll-bar scroll-bar | |
| 1071 | :face 'popup-tip-face | |
| 1072 | :parent parent | |
| 1073 | :parent-offset parent-offset)) | |
| 1074 | ||
| 1075 | (unwind-protect | |
| 1076 | (when (> (popup-width tip) 0) ; not to be corrupted | |
| 1077 | (when (and (not (eq width (popup-width tip))) ; truncated | |
| 1078 | (not truncate)) | |
| 1079 | ;; Refill once again to lines be fitted to popup width | |
| 1080 | (setq width (popup-width tip)) | |
| 1081 | (setq lines (cdr (popup-fill-string string width width)))) | |
| 1082 | ||
| 1083 | (popup-set-list tip lines) | |
| 1084 | (popup-draw tip) | |
| 1085 | (if nowait | |
| 1086 | tip | |
| 1087 | (clear-this-command-keys) | |
| 1088 | (push (read-event prompt) unread-command-events) | |
| 1089 | t)) | |
| 1090 | (unless nowait | |
| 1091 | (popup-delete tip)))) | |
| 1092 | ||
| 1093 | ||
| 1094 | ||
| 1095 | ;;; Popup Menu | |
| 1096 | ||
| 1097 | (defface popup-menu-face | |
| 1098 | '((t (:inherit popup-face))) | |
| 1099 | "Face for popup menu." | |
| 1100 | :group 'popup) | |
| 1101 | ||
| 1102 | (defface popup-menu-mouse-face | |
| 1103 | '((t (:background "blue" :foreground "white"))) | |
| 1104 | "Face for popup menu." | |
| 1105 | :group 'popup) | |
| 1106 | ||
| 1107 | (defface popup-menu-selection-face | |
| 1108 | '((t (:inherit default :background "steelblue" :foreground "white"))) | |
| 1109 | "Face for popup menu selection." | |
| 1110 | :group 'popup) | |
| 1111 | ||
| 1112 | (defface popup-menu-summary-face | |
| 1113 | '((t (:inherit popup-summary-face))) | |
| 1114 | "Face for popup summary." | |
| 1115 | :group 'popup) | |
| 1116 | ||
| 1117 | (defvar popup-menu-show-tip-function 'popup-tip | |
| 1118 | "Function used for showing tooltip by `popup-menu-show-quick-help'.") | |
| 1119 | ||
| 1120 | (defun popup-menu-show-help (menu &optional persist item) | |
| 1121 | (popup-item-show-help (or item (popup-selected-item menu)) persist)) | |
| 1122 | ||
| 1123 | (defun popup-menu-documentation (menu &optional item) | |
| 1124 | (popup-item-documentation (or item (popup-selected-item menu)))) | |
| 1125 | ||
| 1126 | (defun popup-menu-show-quick-help (menu &optional item &rest args) | |
| 1127 | (let* ((point (plist-get args :point)) | |
| 1128 | (height (or (plist-get args :height) (popup-height menu))) | |
| 1129 | (min-height (min height (popup-current-height menu))) | |
| 1130 | (around nil) | |
| 1131 | (parent-offset (popup-offset menu)) | |
| 1132 | (doc (popup-menu-documentation menu item))) | |
| 1133 | (when (stringp doc) | |
| 1134 | (if (popup-hidden-p menu) | |
| 1135 | (setq around t | |
| 1136 | menu nil | |
| 1137 | parent-offset nil) | |
| 1138 | (setq point nil)) | |
| 1139 | (let ((popup-use-optimized-column-computation nil)) ; To avoid wrong positioning | |
| 1140 | (apply popup-menu-show-tip-function | |
| 1141 | doc | |
| 1142 | :point point | |
| 1143 | :height height | |
| 1144 | :min-height min-height | |
| 1145 | :around around | |
| 1146 | :parent menu | |
| 1147 | :parent-offset parent-offset | |
| 1148 | args))))) | |
| 1149 | ||
| 1150 | (defun popup-menu-item-of-mouse-event (event) | |
| 1151 | (when (and (consp event) | |
| 1152 | (memq (cl-first event) '(mouse-1 mouse-2 mouse-3 mouse-4 mouse-5))) | |
| 1153 | (let* ((position (cl-second event)) | |
| 1154 | (object (elt position 4))) | |
| 1155 | (when (consp object) | |
| 1156 | (get-text-property (cdr object) 'popup-item (car object)))))) | |
| 1157 | ||
| 1158 | (defun popup-menu-read-key-sequence (keymap &optional prompt timeout) | |
| 1159 | (catch 'timeout | |
| 1160 | (let ((timer (and timeout | |
| 1161 | (run-with-timer timeout nil | |
| 1162 | (lambda () | |
| 1163 | (if (zerop (length (this-command-keys))) | |
| 1164 | (throw 'timeout nil)))))) | |
| 1165 | (old-global-map (current-global-map)) | |
| 1166 | (temp-global-map (make-sparse-keymap)) | |
| 1167 | (overriding-terminal-local-map (make-sparse-keymap))) | |
| 1168 | (substitute-key-definition 'keyboard-quit 'keyboard-quit | |
| 1169 | temp-global-map old-global-map) | |
| 1170 | (define-key temp-global-map [menu-bar] (lookup-key old-global-map [menu-bar])) | |
| 1171 | (define-key temp-global-map [tool-bar] (lookup-key old-global-map [tool-bar])) | |
| 1172 | (set-keymap-parent overriding-terminal-local-map keymap) | |
| 1173 | (if (current-local-map) | |
| 1174 | (define-key overriding-terminal-local-map [menu-bar] | |
| 1175 | (lookup-key (current-local-map) [menu-bar]))) | |
| 1176 | (unwind-protect | |
| 1177 | (progn | |
| 1178 | (use-global-map temp-global-map) | |
| 1179 | (clear-this-command-keys) | |
| 1180 | (with-temp-message prompt | |
| 1181 | (read-key-sequence nil))) | |
| 1182 | (use-global-map old-global-map) | |
| 1183 | (if timer (cancel-timer timer)))))) | |
| 1184 | ||
| 1185 | (defun popup-menu-fallback (event default)) | |
| 1186 | ||
| 1187 | (cl-defun popup-menu-event-loop (menu | |
| 1188 | keymap | |
| 1189 | fallback | |
| 1190 | &key | |
| 1191 | prompt | |
| 1192 | help-delay | |
| 1193 | isearch | |
| 1194 | isearch-filter | |
| 1195 | isearch-cursor-color | |
| 1196 | isearch-keymap | |
| 1197 | isearch-callback | |
| 1198 | &aux key binding) | |
| 1199 | (cl-block nil | |
| 1200 | (while (popup-live-p menu) | |
| 1201 | (and isearch | |
| 1202 | (popup-isearch menu | |
| 1203 | :filter isearch-filter | |
| 1204 | :cursor-color isearch-cursor-color | |
| 1205 | :keymap isearch-keymap | |
| 1206 | :callback isearch-callback | |
| 1207 | :help-delay help-delay) | |
| 1208 | (keyboard-quit)) | |
| 1209 | (setq key (popup-menu-read-key-sequence keymap prompt help-delay)) | |
| 1210 | (setq binding (and key (lookup-key keymap key))) | |
| 1211 | (cond | |
| 1212 | ((or (null key) (zerop (length key))) | |
| 1213 | (unless (funcall popup-menu-show-quick-help-function menu nil :prompt prompt) | |
| 1214 | (clear-this-command-keys) | |
| 1215 | (push (read-event prompt) unread-command-events))) | |
| 1216 | ((eq (lookup-key (current-global-map) key) 'keyboard-quit) | |
| 1217 | (keyboard-quit) | |
| 1218 | (cl-return)) | |
| 1219 | ((eq binding 'popup-close) | |
| 1220 | (if (popup-parent menu) | |
| 1221 | (cl-return))) | |
| 1222 | ((memq binding '(popup-select popup-open)) | |
| 1223 | (let* ((item (or (popup-menu-item-of-mouse-event (elt key 0)) | |
| 1224 | (popup-selected-item menu))) | |
| 1225 | (index (cl-position item (popup-list menu))) | |
| 1226 | (sublist (popup-item-sublist item))) | |
| 1227 | (unless index (cl-return)) | |
| 1228 | (if sublist | |
| 1229 | (popup-aif (let (popup-use-optimized-column-computation) | |
| 1230 | (popup-cascade-menu sublist | |
| 1231 | :around nil | |
| 1232 | :margin-left (popup-margin-left menu) | |
| 1233 | :margin-right (popup-margin-right menu) | |
| 1234 | :scroll-bar (popup-scroll-bar menu) | |
| 1235 | :parent menu | |
| 1236 | :parent-offset index | |
| 1237 | :help-delay help-delay | |
| 1238 | :isearch isearch | |
| 1239 | :isearch-filter isearch-filter | |
| 1240 | :isearch-cursor-color isearch-cursor-color | |
| 1241 | :isearch-keymap isearch-keymap | |
| 1242 | :isearch-callback isearch-callback)) | |
| 1243 | (and it (cl-return it))) | |
| 1244 | (if (eq binding 'popup-select) | |
| 1245 | (cl-return (popup-item-value-or-self item)))))) | |
| 1246 | ((eq binding 'popup-next) | |
| 1247 | (popup-next menu)) | |
| 1248 | ((eq binding 'popup-previous) | |
| 1249 | (popup-previous menu)) | |
| 1250 | ((eq binding 'popup-page-next) | |
| 1251 | (popup-page-next menu)) | |
| 1252 | ((eq binding 'popup-page-previous) | |
| 1253 | (popup-page-previous menu)) | |
| 1254 | ((eq binding 'popup-help) | |
| 1255 | (popup-menu-show-help menu)) | |
| 1256 | ((eq binding 'popup-isearch) | |
| 1257 | (popup-isearch menu | |
| 1258 | :filter isearch-filter | |
| 1259 | :cursor-color isearch-cursor-color | |
| 1260 | :keymap isearch-keymap | |
| 1261 | :callback isearch-callback | |
| 1262 | :help-delay help-delay)) | |
| 1263 | ((commandp binding) | |
| 1264 | (call-interactively binding)) | |
| 1265 | (t | |
| 1266 | (funcall fallback key (key-binding key))))))) | |
| 1267 | ||
| 1268 | (defun popup-preferred-width (list) | |
| 1269 | "Return the preferred width to show LIST beautifully." | |
| 1270 | (cl-loop with tab-width = 4 | |
| 1271 | for item in list | |
| 1272 | for summary = (popup-item-summary item) | |
| 1273 | maximize (string-width (popup-x-to-string item)) into width | |
| 1274 | if (stringp summary) | |
| 1275 | maximize (+ (string-width summary) 2) into summary-width | |
| 1276 | finally return | |
| 1277 | (let ((total (+ (or width 0) (or summary-width 0)))) | |
| 1278 | (* (ceiling (/ total 10.0)) 10)))) | |
| 1279 | ||
| 1280 | (defvar popup-menu-keymap | |
| 1281 | (let ((map (make-sparse-keymap))) | |
| 1282 | (define-key map "\r" 'popup-select) | |
| 1283 | (define-key map "\C-f" 'popup-open) | |
| 1284 | (define-key map [right] 'popup-open) | |
| 1285 | (define-key map "\C-b" 'popup-close) | |
| 1286 | (define-key map [left] 'popup-close) | |
| 1287 | ||
| 1288 | (define-key map "\C-n" 'popup-next) | |
| 1289 | (define-key map [down] 'popup-next) | |
| 1290 | (define-key map "\C-p" 'popup-previous) | |
| 1291 | (define-key map [up] 'popup-previous) | |
| 1292 | ||
| 1293 | (define-key map [next] 'popup-page-next) | |
| 1294 | (define-key map [prior] 'popup-page-previous) | |
| 1295 | ||
| 1296 | (define-key map [f1] 'popup-help) | |
| 1297 | (define-key map (kbd "\C-?") 'popup-help) | |
| 1298 | ||
| 1299 | (define-key map "\C-s" 'popup-isearch) | |
| 1300 | ||
| 1301 | (define-key map [mouse-1] 'popup-select) | |
| 1302 | (define-key map [mouse-4] 'popup-previous) | |
| 1303 | (define-key map [mouse-5] 'popup-next) | |
| 1304 | map)) | |
| 1305 | ||
| 1306 | (cl-defun popup-menu* (list | |
| 1307 | &key | |
| 1308 | point | |
| 1309 | (around t) | |
| 1310 | (width (popup-preferred-width list)) | |
| 1311 | (height 15) | |
| 1312 | max-width | |
| 1313 | margin | |
| 1314 | margin-left | |
| 1315 | margin-right | |
| 1316 | scroll-bar | |
| 1317 | symbol | |
| 1318 | parent | |
| 1319 | parent-offset | |
| 1320 | cursor | |
| 1321 | (keymap popup-menu-keymap) | |
| 1322 | (fallback 'popup-menu-fallback) | |
| 1323 | help-delay | |
| 1324 | nowait | |
| 1325 | prompt | |
| 1326 | isearch | |
| 1327 | (isearch-filter 'popup-isearch-filter-list) | |
| 1328 | (isearch-cursor-color popup-isearch-cursor-color) | |
| 1329 | (isearch-keymap popup-isearch-keymap) | |
| 1330 | isearch-callback | |
| 1331 | initial-index | |
| 1332 | &aux menu event) | |
| 1333 | "Show a popup menu of LIST at POINT. This function returns a | |
| 1334 | value of the selected item. Almost all arguments are the same as in | |
| 1335 | `popup-create', except for KEYMAP, FALLBACK, HELP-DELAY, PROMPT, | |
| 1336 | ISEARCH, ISEARCH-FILTER, ISEARCH-CURSOR-COLOR, ISEARCH-KEYMAP, and | |
| 1337 | ISEARCH-CALLBACK. | |
| 1338 | ||
| 1339 | If KEYMAP is a keymap which is used when processing events during | |
| 1340 | event loop. | |
| 1341 | ||
| 1342 | If FALLBACK is a function taking two arguments; a key and a | |
| 1343 | command. FALLBACK is called when no special operation is found on | |
| 1344 | the key. The default value is `popup-menu-fallback', which does | |
| 1345 | nothing. | |
| 1346 | ||
| 1347 | HELP-DELAY is a delay of displaying helps. | |
| 1348 | ||
| 1349 | If NOWAIT is non-nil, this function immediately returns the menu | |
| 1350 | instance without entering event loop. | |
| 1351 | ||
| 1352 | PROMPT is a prompt string when reading events during event loop. | |
| 1353 | ||
| 1354 | If ISEARCH is non-nil, do isearch as soon as displaying the popup | |
| 1355 | menu. | |
| 1356 | ||
| 1357 | ISEARCH-FILTER is a filtering function taking two arguments: | |
| 1358 | search pattern and list of items. Returns a list of matching items. | |
| 1359 | ||
| 1360 | ISEARCH-CURSOR-COLOR is a cursor color during isearch. The | |
| 1361 | default value is `popup-isearch-cursor-color'. | |
| 1362 | ||
| 1363 | ISEARCH-KEYMAP is a keymap which is used when processing events | |
| 1364 | during event loop. The default value is `popup-isearch-keymap'. | |
| 1365 | ||
| 1366 | ISEARCH-CALLBACK is a function taking one argument. `popup-menu' | |
| 1367 | calls ISEARCH-CALLBACK, if specified, after isearch finished or | |
| 1368 | isearch canceled. The arguments is whole filtered list of items. | |
| 1369 | ||
| 1370 | If `INITIAL-INDEX' is non-nil, this is an initial index value for | |
| 1371 | `popup-select'. Only positive integer is valid." | |
| 1372 | (and (eq margin t) (setq margin 1)) | |
| 1373 | (or margin-left (setq margin-left margin)) | |
| 1374 | (or margin-right (setq margin-right margin)) | |
| 1375 | (if (and scroll-bar | |
| 1376 | (integerp margin-right) | |
| 1377 | (> margin-right 0)) | |
| 1378 | ;; Make scroll-bar space as margin-right | |
| 1379 | (cl-decf margin-right)) | |
| 1380 | (setq menu (popup-create point width height | |
| 1381 | :max-width max-width | |
| 1382 | :around around | |
| 1383 | :face 'popup-menu-face | |
| 1384 | :mouse-face 'popup-menu-mouse-face | |
| 1385 | :selection-face 'popup-menu-selection-face | |
| 1386 | :summary-face 'popup-menu-summary-face | |
| 1387 | :margin-left margin-left | |
| 1388 | :margin-right margin-right | |
| 1389 | :scroll-bar scroll-bar | |
| 1390 | :symbol symbol | |
| 1391 | :parent parent | |
| 1392 | :parent-offset parent-offset)) | |
| 1393 | (unwind-protect | |
| 1394 | (progn | |
| 1395 | (popup-set-list menu list) | |
| 1396 | (if cursor | |
| 1397 | (popup-jump menu cursor) | |
| 1398 | (popup-draw menu)) | |
| 1399 | (when initial-index | |
| 1400 | (dotimes (_i (min (- (length list) 1) initial-index)) | |
| 1401 | (popup-next menu))) | |
| 1402 | (if nowait | |
| 1403 | menu | |
| 1404 | (popup-menu-event-loop menu keymap fallback | |
| 1405 | :prompt prompt | |
| 1406 | :help-delay help-delay | |
| 1407 | :isearch isearch | |
| 1408 | :isearch-filter isearch-filter | |
| 1409 | :isearch-cursor-color isearch-cursor-color | |
| 1410 | :isearch-keymap isearch-keymap | |
| 1411 | :isearch-callback isearch-callback))) | |
| 1412 | (unless nowait | |
| 1413 | (popup-delete menu)))) | |
| 1414 | ||
| 1415 | (defun popup-cascade-menu (list &rest args) | |
| 1416 | "Same as `popup-menu' except that an element of LIST can be | |
| 1417 | also a sub-menu if the element is a cons cell formed (ITEM | |
| 1418 | . SUBLIST) where ITEM is an usual item and SUBLIST is a list of | |
| 1419 | the sub menu." | |
| 1420 | (apply 'popup-menu* | |
| 1421 | (mapcar (lambda (item) | |
| 1422 | (if (consp item) | |
| 1423 | (popup-make-item (car item) | |
| 1424 | :sublist (cdr item) | |
| 1425 | :symbol ">") | |
| 1426 | item)) | |
| 1427 | list) | |
| 1428 | :symbol t | |
| 1429 | args)) | |
| 1430 | ||
| 1431 | (provide 'popup) | |
| 1432 | ;;; popup.el ends here | |
