1433 lines
54 KiB
EmacsLisp
1433 lines
54 KiB
EmacsLisp
;;; popup.el --- Visual Popup User Interface
|
||
|
||
;; Copyright (C) 2009-2015 Tomohiro Matsuyama
|
||
|
||
;; Author: Tomohiro Matsuyama <m2ym.pub@gmail.com>
|
||
;; Keywords: lisp
|
||
;; Package-Version: 20160709.729
|
||
;; Version: 0.5.3
|
||
;; Package-Requires: ((cl-lib "0.5"))
|
||
|
||
;; 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/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;; popup.el is a visual popup user interface library for Emacs. This
|
||
;; provides a basic API and common UI widgets such as popup tooltips
|
||
;; and popup menus.
|
||
;; See README.markdown for more information.
|
||
|
||
;;; Code:
|
||
|
||
(require 'cl-lib)
|
||
|
||
(defconst popup-version "0.5.3")
|
||
|
||
|
||
|
||
;;; Utilities
|
||
|
||
(defun popup-calculate-max-width (max-width)
|
||
"Determines whether the width desired is
|
||
character or window proportion based, And returns the result."
|
||
(cl-typecase max-width
|
||
(integer max-width)
|
||
(float (* (ceiling (/ (round (* max-width (window-width))) 10.0)) 10))))
|
||
|
||
(defvar popup-use-optimized-column-computation t
|
||
"Use the optimized column computation routine.
|
||
If there is a problem, please set it nil.")
|
||
|
||
(defmacro popup-aif (test then &rest else)
|
||
"Anaphoric if."
|
||
(declare (indent 2))
|
||
`(let ((it ,test))
|
||
(if it ,then ,@else)))
|
||
|
||
(defmacro popup-awhen (test &rest body)
|
||
"Anaphoric when."
|
||
(declare (indent 1))
|
||
`(let ((it ,test))
|
||
(when it ,@body)))
|
||
|
||
(defun popup-x-to-string (x)
|
||
"Convert any object to string effeciently.
|
||
This is faster than `prin1-to-string' in many cases."
|
||
(cl-typecase x
|
||
(string x)
|
||
(symbol (symbol-name x))
|
||
(integer (number-to-string x))
|
||
(float (number-to-string x))
|
||
(t (format "%s" x))))
|
||
|
||
(defun popup-substring-by-width (string width)
|
||
"Return a cons cell of substring and remaining string by
|
||
splitting with WIDTH."
|
||
;; Expand tabs into 4 spaces
|
||
(setq string (replace-regexp-in-string "\t" " " string))
|
||
(cl-loop with len = (length string)
|
||
with w = 0
|
||
for l from 0
|
||
for c in (append string nil)
|
||
while (<= (cl-incf w (char-width c)) width)
|
||
finally return
|
||
(if (< l len)
|
||
(cons (substring string 0 l) (substring string l))
|
||
(list string))))
|
||
|
||
(defun popup-fill-string (string &optional width max-width justify squeeze)
|
||
"Split STRING into fixed width strings and return a cons cell
|
||
like \(WIDTH . ROWS). Here, the car WIDTH indicates the actual
|
||
maxim width of ROWS.
|
||
|
||
The argument WIDTH specifies the width of filling each
|
||
paragraph. WIDTH nil means don't perform any justification and
|
||
word wrap. Note that this function doesn't add any padding
|
||
characters at the end of each row.
|
||
|
||
MAX-WIDTH, if WIDTH is nil, specifies the maximum number of
|
||
columns.
|
||
|
||
The optional fourth argument JUSTIFY specifies which kind of
|
||
justification to do: `full', `left', `right', `center', or
|
||
`none' (equivalent to nil). A value of t means handle each
|
||
paragraph as specified by its text properties.
|
||
|
||
SQUEEZE nil means leave whitespaces other than line breaks
|
||
untouched."
|
||
(if (eq width 0)
|
||
(error "Can't fill string with 0 width"))
|
||
(if width
|
||
(setq max-width width))
|
||
(with-temp-buffer
|
||
(let ((tab-width 4)
|
||
(fill-column width)
|
||
(left-margin 0)
|
||
(kinsoku-limit 1)
|
||
indent-tabs-mode
|
||
row rows)
|
||
(insert string)
|
||
(untabify (point-min) (point-max))
|
||
(if width
|
||
(fill-region (point-min) (point-max) justify (not squeeze)))
|
||
(goto-char (point-min))
|
||
(setq width 0)
|
||
(while (prog2
|
||
(let ((line (buffer-substring
|
||
(point) (progn (end-of-line) (point)))))
|
||
(if max-width
|
||
(while (progn
|
||
(setq row (truncate-string-to-width line max-width)
|
||
width (max width (string-width row)))
|
||
(push row rows)
|
||
(if (not (= (length row) (length line)))
|
||
(setq line (substring line (length row))))))
|
||
(setq width (max width (string-width line)))
|
||
(push line rows)))
|
||
(< (point) (point-max))
|
||
(beginning-of-line 2)))
|
||
(cons width (nreverse rows)))))
|
||
|
||
(defmacro popup-save-buffer-state (&rest body)
|
||
(declare (indent 0))
|
||
`(save-excursion
|
||
(let ((buffer-undo-list t)
|
||
(inhibit-read-only t)
|
||
(modified (buffer-modified-p)))
|
||
(unwind-protect
|
||
(progn ,@body)
|
||
(set-buffer-modified-p modified)))))
|
||
|
||
(defun popup-vertical-motion (column direction)
|
||
"A portable version of `vertical-motion'."
|
||
(if (>= emacs-major-version 23)
|
||
(vertical-motion (cons column direction))
|
||
(vertical-motion direction)
|
||
(move-to-column (+ (current-column) column))))
|
||
|
||
(defun popup-last-line-of-buffer-p ()
|
||
"Return non-nil if the cursor is at the last line of the
|
||
buffer."
|
||
(save-excursion (end-of-line) (/= (forward-line) 0)))
|
||
|
||
(defun popup-lookup-key-by-event (function event)
|
||
(or (funcall function (vector event))
|
||
(if (symbolp event)
|
||
(popup-aif (get event 'event-symbol-element-mask)
|
||
(funcall function
|
||
(vector (logior (or (get (car it) 'ascii-character)
|
||
0)
|
||
(cadr it))))))))
|
||
|
||
|
||
|
||
;;; Core
|
||
|
||
(defgroup popup nil
|
||
"Visual Popup User Interface"
|
||
:group 'lisp
|
||
:prefix "popup-")
|
||
|
||
(defface popup-face
|
||
'((t (:inherit default :background "lightgray" :foreground "black")))
|
||
"Face for popup."
|
||
:group 'popup)
|
||
|
||
(defface popup-summary-face
|
||
'((t (:inherit popup-face :foreground "dimgray")))
|
||
"Face for popup summary."
|
||
:group 'popup)
|
||
|
||
(defface popup-scroll-bar-foreground-face
|
||
'((t (:background "black")))
|
||
"Foreground face for scroll-bar."
|
||
:group 'popup)
|
||
|
||
(defface popup-scroll-bar-background-face
|
||
'((t (:background "gray")))
|
||
"Background face for scroll-bar."
|
||
:group 'popup)
|
||
|
||
(defvar popup-instances nil
|
||
"Popup instances.")
|
||
|
||
(defvar popup-scroll-bar-foreground-char
|
||
(propertize " " 'face 'popup-scroll-bar-foreground-face)
|
||
"Foreground character for scroll-bar.")
|
||
|
||
(defvar popup-scroll-bar-background-char
|
||
(propertize " " 'face 'popup-scroll-bar-background-face)
|
||
"Background character for scroll-bar.")
|
||
|
||
(cl-defstruct popup
|
||
point row column width height min-height direction overlays keymap
|
||
parent depth
|
||
face mouse-face selection-face summary-face
|
||
margin-left margin-right margin-left-cancel scroll-bar symbol
|
||
cursor offset scroll-top current-height list newlines
|
||
pattern original-list invis-overlays)
|
||
|
||
(defun popup-item-propertize (item &rest properties)
|
||
"Same as `propertize' except that this avoids overriding
|
||
existed value with `nil' property."
|
||
(cl-loop for (k v) on properties by 'cddr
|
||
if v append (list k v) into props
|
||
finally return
|
||
(apply 'propertize
|
||
(popup-x-to-string item)
|
||
props)))
|
||
|
||
(defun popup-item-property (item property)
|
||
"Same as `get-text-property' except that this returns nil if
|
||
ITEM is not string."
|
||
(if (stringp item)
|
||
(get-text-property 0 property item)))
|
||
|
||
(cl-defun popup-make-item (name
|
||
&key
|
||
value
|
||
face
|
||
mouse-face
|
||
selection-face
|
||
sublist
|
||
document
|
||
symbol
|
||
summary)
|
||
"Utility function to make popup item. See also
|
||
`popup-item-propertize'."
|
||
(popup-item-propertize name
|
||
'value value
|
||
'popup-face face
|
||
'popup-mouse-face mouse-face
|
||
'selection-face selection-face
|
||
'document document
|
||
'symbol symbol
|
||
'summary summary
|
||
'sublist sublist))
|
||
|
||
(defsubst popup-item-value (item) (popup-item-property item 'value))
|
||
(defsubst popup-item-value-or-self (item) (or (popup-item-value item) item))
|
||
(defsubst popup-item-face (item) (popup-item-property item 'popup-face))
|
||
(defsubst popup-item-mouse-face (item) (popup-item-property item 'popup-mouse-face))
|
||
(defsubst popup-item-selection-face (item) (popup-item-property item 'selection-face))
|
||
(defsubst popup-item-document (item) (popup-item-property item 'document))
|
||
(defsubst popup-item-summary (item) (popup-item-property item 'summary))
|
||
(defsubst popup-item-symbol (item) (popup-item-property item 'symbol))
|
||
(defsubst popup-item-sublist (item) (popup-item-property item 'sublist))
|
||
|
||
(defun popup-item-documentation (item)
|
||
(let ((doc (popup-item-document item)))
|
||
(if (functionp doc)
|
||
(setq doc (funcall doc (popup-item-value-or-self item))))
|
||
doc))
|
||
|
||
(defun popup-item-show-help-1 (item)
|
||
(let ((doc (popup-item-documentation item)))
|
||
(when doc
|
||
(with-current-buffer (get-buffer-create " *Popup Help*")
|
||
(erase-buffer)
|
||
(insert doc)
|
||
(goto-char (point-min))
|
||
(display-buffer (current-buffer)))
|
||
t)))
|
||
|
||
(defun popup-item-show-help-with-event-loop (item)
|
||
(save-window-excursion
|
||
(when (popup-item-show-help-1 item)
|
||
(cl-loop do (clear-this-command-keys)
|
||
for key = (read-key-sequence-vector nil)
|
||
do
|
||
(cl-case (key-binding key)
|
||
(scroll-other-window
|
||
(scroll-other-window))
|
||
(scroll-other-window-down
|
||
(scroll-other-window-down nil))
|
||
(otherwise
|
||
(setq unread-command-events (append key unread-command-events))
|
||
(cl-return)))))))
|
||
|
||
(defun popup-item-show-help (item &optional persist)
|
||
"Display the documentation of ITEM with `display-buffer'. If
|
||
PERSIST is nil, the documentation buffer will be closed
|
||
automatically, meaning interal event loop ensures the buffer to
|
||
be closed. Otherwise, the buffer will be just displayed as
|
||
usual."
|
||
(when item
|
||
(if (not persist)
|
||
(popup-item-show-help-with-event-loop item)
|
||
(popup-item-show-help-1 item))))
|
||
|
||
(defun popup-set-list (popup list)
|
||
(popup-set-filtered-list popup list)
|
||
(setf (popup-pattern popup) nil)
|
||
(setf (popup-original-list popup) list))
|
||
|
||
(defun popup-set-filtered-list (popup list)
|
||
(let ((offset
|
||
(if (> (popup-direction popup) 0)
|
||
0
|
||
(max (- (popup-height popup) (length list)) 0))))
|
||
(setf (popup-list popup) list
|
||
(popup-offset popup) offset)))
|
||
|
||
(defun popup-selected-item (popup)
|
||
(nth (popup-cursor popup) (popup-list popup)))
|
||
|
||
(defun popup-selected-line (popup)
|
||
(- (popup-cursor popup) (popup-scroll-top popup)))
|
||
|
||
(defun popup-line-overlay (popup line)
|
||
(aref (popup-overlays popup) line))
|
||
|
||
(defun popup-selected-line-overlay (popup)
|
||
(popup-line-overlay popup (popup-selected-line popup)))
|
||
|
||
(defun popup-hide-line (popup line)
|
||
(let ((overlay (popup-line-overlay popup line)))
|
||
(overlay-put overlay 'display nil)
|
||
(overlay-put overlay 'after-string nil)))
|
||
|
||
(defun popup-line-hidden-p (popup line)
|
||
(let ((overlay (popup-line-overlay popup line)))
|
||
(and (eq (overlay-get overlay 'display) nil)
|
||
(eq (overlay-get overlay 'after-string) nil))))
|
||
|
||
(cl-defun popup-set-line-item (popup
|
||
line
|
||
&key
|
||
item
|
||
face
|
||
mouse-face
|
||
margin-left
|
||
margin-right
|
||
scroll-bar-char
|
||
symbol
|
||
summary
|
||
summary-face
|
||
keymap)
|
||
(let* ((overlay (popup-line-overlay popup line))
|
||
(content (popup-create-line-string popup (popup-x-to-string item)
|
||
:margin-left margin-left
|
||
:margin-right margin-right
|
||
:symbol symbol
|
||
:summary summary
|
||
:summary-face summary-face))
|
||
(start 0)
|
||
(prefix (overlay-get overlay 'prefix))
|
||
(postfix (overlay-get overlay 'postfix))
|
||
end)
|
||
(put-text-property 0 (length content) 'popup-item item content)
|
||
(put-text-property 0 (length content) 'keymap keymap content)
|
||
;; Overlap face properties
|
||
(when (get-text-property start 'face content)
|
||
(setq start (next-single-property-change start 'face content)))
|
||
(while (and start (setq end (next-single-property-change start 'face content)))
|
||
(put-text-property start end 'face face content)
|
||
(setq start (next-single-property-change end 'face content)))
|
||
(when start
|
||
(put-text-property start (length content) 'face face content))
|
||
(when mouse-face
|
||
(put-text-property 0 (length content) 'mouse-face mouse-face content))
|
||
(let ((prop (if (overlay-get overlay 'dangle)
|
||
'after-string
|
||
'display)))
|
||
(overlay-put overlay
|
||
prop
|
||
(concat prefix
|
||
content
|
||
scroll-bar-char
|
||
postfix)))))
|
||
|
||
(cl-defun popup-create-line-string (popup
|
||
string
|
||
&key
|
||
margin-left
|
||
margin-right
|
||
symbol
|
||
summary
|
||
summary-face)
|
||
(let* ((popup-width (popup-width popup))
|
||
(summary-width (string-width summary))
|
||
(content-width (max
|
||
(min popup-width (string-width string))
|
||
(- popup-width
|
||
(if (> summary-width 0)
|
||
(+ summary-width 2)
|
||
0))))
|
||
(string (car (popup-substring-by-width string content-width)))
|
||
(string-width (string-width string))
|
||
(spacing (max (- popup-width string-width summary-width)
|
||
(if (> popup-width string-width) 1 0)))
|
||
(truncated-summary
|
||
(car (popup-substring-by-width
|
||
summary (max (- popup-width string-width spacing) 0)))))
|
||
(when summary-face
|
||
(put-text-property 0 (length truncated-summary)
|
||
'face summary-face truncated-summary))
|
||
(concat margin-left
|
||
string
|
||
(make-string spacing ? )
|
||
truncated-summary
|
||
symbol
|
||
margin-right)))
|
||
|
||
(defun popup-live-p (popup)
|
||
"Return non-nil if POPUP is alive."
|
||
(and popup (popup-overlays popup) t))
|
||
|
||
(defun popup-child-point (popup &optional offset)
|
||
(overlay-end
|
||
(popup-line-overlay
|
||
popup
|
||
(or offset
|
||
(popup-selected-line popup)))))
|
||
|
||
(defun popup-calculate-direction (height row)
|
||
"Return a proper direction when displaying a popup on this
|
||
window. HEIGHT is the a height of the popup, and ROW is a line
|
||
number at the point."
|
||
(let* ((remaining-rows (- (max 1 (- (window-height)
|
||
(if mode-line-format 1 0)
|
||
(if header-line-format 1 0)))
|
||
(count-lines (window-start) (point))))
|
||
(enough-space-above (> row height))
|
||
(enough-space-below (<= height remaining-rows)))
|
||
(if (and enough-space-above
|
||
(not enough-space-below))
|
||
-1
|
||
1)))
|
||
|
||
(cl-defun popup-create (point
|
||
width
|
||
height
|
||
&key
|
||
min-height
|
||
max-width
|
||
around
|
||
(face 'popup-face)
|
||
mouse-face
|
||
(selection-face face)
|
||
(summary-face 'popup-summary-face)
|
||
scroll-bar
|
||
margin-left
|
||
margin-right
|
||
symbol
|
||
parent
|
||
parent-offset
|
||
keymap)
|
||
"Create a popup instance at POINT with WIDTH and HEIGHT.
|
||
|
||
MIN-HEIGHT is a minimal height of the popup. The default value is
|
||
0.
|
||
|
||
MAX-WIDTH is the maximum width of the popup. The default value is
|
||
nil (no limit). If a floating point, the value refers to the ratio of
|
||
the window. If an integer, limit is in characters.
|
||
|
||
If AROUND is non-nil, the popup will be displayed around the
|
||
point but not at the point.
|
||
|
||
FACE is a background face of the popup. The default value is POPUP-FACE.
|
||
|
||
SELECTION-FACE is a foreground (selection) face of the popup The
|
||
default value is POPUP-FACE.
|
||
|
||
If SCROLL-BAR is non-nil, the popup will have a scroll bar at the
|
||
right.
|
||
|
||
If MARGIN-LEFT is non-nil, the popup will have a margin at the
|
||
left.
|
||
|
||
If MARGIN-RIGHT is non-nil, the popup will have a margin at the
|
||
right.
|
||
|
||
SYMBOL is a single character which indicates a kind of the item.
|
||
|
||
PARENT is a parent popup instance. If PARENT is omitted, the
|
||
popup will be a root instance.
|
||
|
||
PARENT-OFFSET is a row offset from the parent popup.
|
||
|
||
KEYMAP is a keymap that will be put on the popup contents."
|
||
(or margin-left (setq margin-left 0))
|
||
(or margin-right (setq margin-right 0))
|
||
(unless point
|
||
(setq point
|
||
(if parent (popup-child-point parent parent-offset) (point))))
|
||
(when max-width
|
||
(setq width (min width (popup-calculate-max-width max-width))))
|
||
(save-excursion
|
||
(goto-char point)
|
||
(let* ((col-row (posn-col-row (posn-at-point)))
|
||
(row (cdr col-row))
|
||
(column (car col-row))
|
||
(overlays (make-vector height nil))
|
||
(popup-width (+ width
|
||
(if scroll-bar 1 0)
|
||
margin-left
|
||
margin-right
|
||
(if symbol 2 0)))
|
||
margin-left-cancel
|
||
(window (selected-window))
|
||
(window-start (window-start))
|
||
(window-hscroll (window-hscroll))
|
||
(window-width (window-width))
|
||
(right (+ column popup-width))
|
||
(overflow (and (> right window-width)
|
||
(>= right popup-width)))
|
||
(foldable (and (null parent)
|
||
(>= column popup-width)))
|
||
(direction (or
|
||
;; Currently the direction of cascade popup won't be changed
|
||
(and parent (popup-direction parent))
|
||
|
||
;; Calculate direction
|
||
(popup-calculate-direction height row)))
|
||
(depth (if parent (1+ (popup-depth parent)) 0))
|
||
(newlines (max 0 (+ (- height (count-lines point (point-max))) (if around 1 0))))
|
||
invis-overlays
|
||
current-column)
|
||
;; Case: no newlines at the end of the buffer
|
||
(when (> newlines 0)
|
||
(popup-save-buffer-state
|
||
(goto-char (point-max))
|
||
(insert (make-string newlines ?\n))))
|
||
|
||
;; Case: the popup overflows
|
||
(if overflow
|
||
(if foldable
|
||
(progn
|
||
(cl-decf column (- popup-width margin-left margin-right))
|
||
(unless around (move-to-column column)))
|
||
(when (not truncate-lines)
|
||
;; Truncate.
|
||
(let ((d (1+ (- popup-width (- window-width column)))))
|
||
(cl-decf popup-width d)
|
||
(cl-decf width d)))
|
||
(cl-decf column margin-left))
|
||
(cl-decf column margin-left))
|
||
|
||
;; Case: no space at the left
|
||
(when (and (null parent)
|
||
(< column 0))
|
||
;; Cancel margin left
|
||
(setq column 0)
|
||
(cl-decf popup-width margin-left)
|
||
(setq margin-left-cancel t))
|
||
|
||
(dotimes (i height)
|
||
(let (overlay begin w (dangle t) (prefix "") (postfix ""))
|
||
(when around
|
||
(popup-vertical-motion column direction))
|
||
(cl-loop for ov in (overlays-in (save-excursion
|
||
(beginning-of-visual-line)
|
||
(point))
|
||
(save-excursion
|
||
(end-of-visual-line)
|
||
(point)))
|
||
when (and (not (overlay-get ov 'popup))
|
||
(not (overlay-get ov 'popup-item))
|
||
(or (overlay-get ov 'invisible)
|
||
(overlay-get ov 'display)))
|
||
do (progn
|
||
(push (list ov (overlay-get ov 'display)) invis-overlays)
|
||
(overlay-put ov 'display "")))
|
||
(setq around t)
|
||
(setq current-column (car (posn-col-row (posn-at-point))))
|
||
|
||
(when (< current-column column)
|
||
;; Extend short buffer lines by popup prefix (line of spaces)
|
||
(setq prefix (make-string
|
||
(+ (if (= current-column 0)
|
||
(- window-hscroll current-column)
|
||
0)
|
||
(- column current-column))
|
||
? )))
|
||
|
||
(setq begin (point))
|
||
(setq w (+ popup-width (length prefix)))
|
||
(while (and (not (eolp)) (> w 0))
|
||
(setq dangle nil)
|
||
(cl-decf w (char-width (char-after)))
|
||
(forward-char))
|
||
(if (< w 0)
|
||
(setq postfix (make-string (- w) ? )))
|
||
|
||
(setq overlay (make-overlay begin (point)))
|
||
(overlay-put overlay 'popup t)
|
||
(overlay-put overlay 'window window)
|
||
(overlay-put overlay 'dangle dangle)
|
||
(overlay-put overlay 'prefix prefix)
|
||
(overlay-put overlay 'postfix postfix)
|
||
(overlay-put overlay 'width width)
|
||
(aset overlays
|
||
(if (> direction 0) i (- height i 1))
|
||
overlay)))
|
||
(cl-loop for p from (- 10000 (* depth 1000))
|
||
for overlay in (nreverse (append overlays nil))
|
||
do (overlay-put overlay 'priority p))
|
||
(let ((it (make-popup :point point
|
||
:row row
|
||
:column column
|
||
:width width
|
||
:height height
|
||
:min-height min-height
|
||
:direction direction
|
||
:parent parent
|
||
:depth depth
|
||
:face face
|
||
:mouse-face mouse-face
|
||
:selection-face selection-face
|
||
:summary-face summary-face
|
||
:margin-left margin-left
|
||
:margin-right margin-right
|
||
:margin-left-cancel margin-left-cancel
|
||
:scroll-bar scroll-bar
|
||
:symbol symbol
|
||
:cursor 0
|
||
:offset 0
|
||
:scroll-top 0
|
||
:current-height 0
|
||
:list nil
|
||
:newlines newlines
|
||
:overlays overlays
|
||
:invis-overlays invis-overlays
|
||
:keymap keymap)))
|
||
(push it popup-instances)
|
||
it))))
|
||
|
||
(defun popup-delete (popup)
|
||
"Delete POPUP instance."
|
||
(when (popup-live-p popup)
|
||
(popup-hide popup)
|
||
(mapc 'delete-overlay (popup-overlays popup))
|
||
(setf (popup-overlays popup) nil)
|
||
(setq popup-instances (delq popup popup-instances))
|
||
;; Restore newlines state
|
||
(let ((newlines (popup-newlines popup)))
|
||
(when (> newlines 0)
|
||
(popup-save-buffer-state
|
||
(goto-char (point-max))
|
||
(dotimes (i newlines)
|
||
(if (and (char-before)
|
||
(= (char-before) ?\n))
|
||
(delete-char -1)))))))
|
||
nil)
|
||
|
||
(defun popup-draw (popup)
|
||
"Draw POPUP."
|
||
(cl-loop for (ov olddisplay) in (popup-invis-overlays popup)
|
||
do (overlay-put ov 'display ""))
|
||
|
||
(cl-loop with height = (popup-height popup)
|
||
with min-height = (popup-min-height popup)
|
||
with popup-face = (popup-face popup)
|
||
with mouse-face = (popup-mouse-face popup)
|
||
with selection-face = (popup-selection-face popup)
|
||
with summary-face-0 = (popup-summary-face popup)
|
||
with list = (popup-list popup)
|
||
with length = (length list)
|
||
with thum-size = (max (/ (* height height) (max length 1)) 1)
|
||
with page-size = (/ (+ 0.0 (max length 1)) height)
|
||
with scroll-bar = (popup-scroll-bar popup)
|
||
with margin-left = (make-string (if (popup-margin-left-cancel popup) 0 (popup-margin-left popup)) ? )
|
||
with margin-right = (make-string (popup-margin-right popup) ? )
|
||
with symbol = (popup-symbol popup)
|
||
with cursor = (popup-cursor popup)
|
||
with scroll-top = (popup-scroll-top popup)
|
||
with offset = (popup-offset popup)
|
||
with keymap = (popup-keymap popup)
|
||
for o from offset
|
||
for i from scroll-top
|
||
while (< o height)
|
||
for item in (nthcdr scroll-top list)
|
||
for page-index = (* thum-size (/ o thum-size))
|
||
for face = (if (= i cursor)
|
||
(or (popup-item-selection-face item) selection-face)
|
||
(or (popup-item-face item) popup-face))
|
||
for summary-face = (unless (= i cursor) summary-face-0)
|
||
for empty-char = (propertize " " 'face face)
|
||
for scroll-bar-char = (if scroll-bar
|
||
(cond
|
||
((and (not (eq scroll-bar :always))
|
||
(<= page-size 1))
|
||
empty-char)
|
||
((and (> page-size 1)
|
||
(>= cursor (* page-index page-size))
|
||
(< cursor (* (+ page-index thum-size) page-size)))
|
||
popup-scroll-bar-foreground-char)
|
||
(t
|
||
popup-scroll-bar-background-char))
|
||
"")
|
||
for sym = (if symbol
|
||
(concat " " (or (popup-item-symbol item) " "))
|
||
"")
|
||
for summary = (or (popup-item-summary item) "")
|
||
|
||
do
|
||
;; Show line and set item to the line
|
||
(popup-set-line-item popup o
|
||
:item item
|
||
:face face
|
||
:mouse-face mouse-face
|
||
:margin-left margin-left
|
||
:margin-right margin-right
|
||
:scroll-bar-char scroll-bar-char
|
||
:symbol sym
|
||
:summary summary
|
||
:summary-face summary-face
|
||
:keymap keymap)
|
||
|
||
finally
|
||
;; Remember current height
|
||
(setf (popup-current-height popup) (- o offset))
|
||
|
||
;; Hide remaining lines
|
||
(let ((scroll-bar-char (if scroll-bar (propertize " " 'face popup-face) ""))
|
||
(symbol (if symbol " " "")))
|
||
(if (> (popup-direction popup) 0)
|
||
(progn
|
||
(when min-height
|
||
(while (< o min-height)
|
||
(popup-set-line-item popup o
|
||
:item ""
|
||
:face popup-face
|
||
:margin-left margin-left
|
||
:margin-right margin-right
|
||
:scroll-bar-char scroll-bar-char
|
||
:symbol symbol
|
||
:summary "")
|
||
(cl-incf o)))
|
||
(while (< o height)
|
||
(popup-hide-line popup o)
|
||
(cl-incf o)))
|
||
(cl-loop with h = (if min-height (- height min-height) offset)
|
||
for o from 0 below offset
|
||
if (< o h)
|
||
do (popup-hide-line popup o)
|
||
if (>= o h)
|
||
do (popup-set-line-item popup o
|
||
:item ""
|
||
:face popup-face
|
||
:margin-left margin-left
|
||
:margin-right margin-right
|
||
:scroll-bar-char scroll-bar-char
|
||
:symbol symbol
|
||
:summary ""))))))
|
||
|
||
(defun popup-hide (popup)
|
||
"Hide POPUP."
|
||
(cl-loop for (ov olddisplay) in (popup-invis-overlays popup)
|
||
do (overlay-put ov 'display olddisplay))
|
||
(dotimes (i (popup-height popup))
|
||
(popup-hide-line popup i)))
|
||
|
||
(defun popup-hidden-p (popup)
|
||
"Return non-nil if POPUP is hidden."
|
||
(let ((hidden t))
|
||
(when (popup-live-p popup)
|
||
(dotimes (i (popup-height popup))
|
||
(unless (popup-line-hidden-p popup i)
|
||
(setq hidden nil))))
|
||
hidden))
|
||
|
||
(defun popup-jump (popup cursor)
|
||
"Jump to a position specified by CURSOR of POPUP and draw."
|
||
(let ((scroll-top (popup-scroll-top popup)))
|
||
;; Do not change page as much as possible.
|
||
(unless (and (<= scroll-top cursor)
|
||
(< cursor (+ scroll-top (popup-height popup))))
|
||
(setf (popup-scroll-top popup) cursor))
|
||
(setf (popup-cursor popup) cursor)
|
||
(popup-draw popup)))
|
||
|
||
(defun popup-select (popup i)
|
||
"Select the item at I of POPUP and draw."
|
||
(setq i (+ i (popup-offset popup)))
|
||
(when (and (<= 0 i) (< i (popup-height popup)))
|
||
(setf (popup-cursor popup) i)
|
||
(popup-draw popup)
|
||
t))
|
||
|
||
(defun popup-next (popup)
|
||
"Select the next item of POPUP and draw."
|
||
(let ((height (popup-height popup))
|
||
(cursor (1+ (popup-cursor popup)))
|
||
(scroll-top (popup-scroll-top popup))
|
||
(length (length (popup-list popup))))
|
||
(cond
|
||
((>= cursor length)
|
||
;; Back to first page
|
||
(setq cursor 0
|
||
scroll-top 0))
|
||
((= cursor (+ scroll-top height))
|
||
;; Go to next page
|
||
(setq scroll-top (min (1+ scroll-top) (max (- length height) 0)))))
|
||
(setf (popup-cursor popup) cursor
|
||
(popup-scroll-top popup) scroll-top)
|
||
(popup-draw popup)))
|
||
|
||
(defun popup-previous (popup)
|
||
"Select the previous item of POPUP and draw."
|
||
(let ((height (popup-height popup))
|
||
(cursor (1- (popup-cursor popup)))
|
||
(scroll-top (popup-scroll-top popup))
|
||
(length (length (popup-list popup))))
|
||
(cond
|
||
((< cursor 0)
|
||
;; Go to last page
|
||
(setq cursor (1- length)
|
||
scroll-top (max (- length height) 0)))
|
||
((= cursor (1- scroll-top))
|
||
;; Go to previous page
|
||
(cl-decf scroll-top)))
|
||
(setf (popup-cursor popup) cursor
|
||
(popup-scroll-top popup) scroll-top)
|
||
(popup-draw popup)))
|
||
|
||
(defun popup-page-next (popup)
|
||
"Select next item of POPUP per `popup-height' range.
|
||
Pages down through POPUP."
|
||
(dotimes (counter (1- (popup-height popup)))
|
||
(popup-next popup)))
|
||
|
||
(defun popup-page-previous (popup)
|
||
"Select previous item of POPUP per `popup-height' range.
|
||
Pages up through POPUP."
|
||
(dotimes (counter (1- (popup-height popup)))
|
||
(popup-previous popup)))
|
||
|
||
(defun popup-scroll-down (popup &optional n)
|
||
"Scroll down N of POPUP and draw."
|
||
(let ((scroll-top (min (+ (popup-scroll-top popup) (or n 1))
|
||
(- (length (popup-list popup)) (popup-height popup)))))
|
||
(setf (popup-cursor popup) scroll-top
|
||
(popup-scroll-top popup) scroll-top)
|
||
(popup-draw popup)))
|
||
|
||
(defun popup-scroll-up (popup &optional n)
|
||
"Scroll up N of POPUP and draw."
|
||
(let ((scroll-top (max (- (popup-scroll-top popup) (or n 1))
|
||
0)))
|
||
(setf (popup-cursor popup) scroll-top
|
||
(popup-scroll-top popup) scroll-top)
|
||
(popup-draw popup)))
|
||
|
||
|
||
|
||
;;; Popup Incremental Search
|
||
|
||
(defface popup-isearch-match
|
||
'((t (:inherit default :background "sky blue")))
|
||
"Popup isearch match face."
|
||
:group 'popup)
|
||
|
||
(defvar popup-isearch-cursor-color "blue")
|
||
|
||
(defvar popup-isearch-keymap
|
||
(let ((map (make-sparse-keymap)))
|
||
;(define-key map "\r" 'popup-isearch-done)
|
||
(define-key map "\C-g" 'popup-isearch-cancel)
|
||
(define-key map "\C-b" 'popup-isearch-close)
|
||
(define-key map [left] 'popup-isearch-close)
|
||
(define-key map "\C-h" 'popup-isearch-delete)
|
||
(define-key map (kbd "DEL") 'popup-isearch-delete)
|
||
(define-key map (kbd "C-y") 'popup-isearch-yank)
|
||
map))
|
||
|
||
(defvar popup-menu-show-quick-help-function 'popup-menu-show-quick-help
|
||
"Function used for showing quick help by `popup-menu*'.")
|
||
|
||
(defcustom popup-isearch-regexp-builder-function #'regexp-quote
|
||
"Function used to construct a regexp from a pattern. You may for instance
|
||
provide a function that replaces spaces by '.+' if you like helm or ivy style
|
||
of completion."
|
||
:type 'function)
|
||
|
||
(defsubst popup-isearch-char-p (char)
|
||
(and (integerp char)
|
||
(<= 32 char)
|
||
(<= char 126)))
|
||
|
||
(defun popup-isearch-filter-list (pattern list)
|
||
(cl-loop with regexp = (funcall popup-isearch-regexp-builder-function pattern)
|
||
for item in list
|
||
do
|
||
(unless (stringp item)
|
||
(setq item (popup-item-propertize (popup-x-to-string item)
|
||
'value item)))
|
||
if (string-match regexp item)
|
||
collect
|
||
(let ((beg (match-beginning 0))
|
||
(end (match-end 0)))
|
||
(alter-text-property 0 (length item) 'face
|
||
(lambda (prop)
|
||
(unless (eq prop 'popup-isearch-match)
|
||
prop))
|
||
item)
|
||
(put-text-property beg end
|
||
'face 'popup-isearch-match
|
||
item)
|
||
item)))
|
||
|
||
(defun popup-isearch-prompt (popup pattern)
|
||
(format "Pattern: %s" (if (= (length (popup-list popup)) 0)
|
||
(propertize pattern 'face 'isearch-fail)
|
||
pattern)))
|
||
|
||
(defun popup-isearch-update (popup filter pattern &optional callback)
|
||
(setf (popup-cursor popup) 0
|
||
(popup-scroll-top popup) 0
|
||
(popup-pattern popup) pattern)
|
||
(let ((list (funcall filter pattern (popup-original-list popup))))
|
||
(popup-set-filtered-list popup list)
|
||
(if callback
|
||
(funcall callback list)))
|
||
(popup-draw popup))
|
||
|
||
(cl-defun popup-isearch (popup
|
||
&key
|
||
(filter 'popup-isearch-filter-list)
|
||
(cursor-color popup-isearch-cursor-color)
|
||
(keymap popup-isearch-keymap)
|
||
callback
|
||
help-delay)
|
||
"Start isearch on POPUP. This function is synchronized, meaning
|
||
event loop waits for quiting of isearch.
|
||
|
||
FILTER is function with two argumenst to perform popup items filtering.
|
||
|
||
CURSOR-COLOR is a cursor color during isearch. The default value
|
||
is `popup-isearch-cursor-color'.
|
||
|
||
KEYMAP is a keymap which is used when processing events during
|
||
event loop. The default value is `popup-isearch-keymap'.
|
||
|
||
CALLBACK is a function taking one argument. `popup-isearch' calls
|
||
CALLBACK, if specified, after isearch finished or isearch
|
||
canceled. The arguments is whole filtered list of items.
|
||
|
||
HELP-DELAY is a delay of displaying helps."
|
||
(let ((list (popup-original-list popup))
|
||
(pattern (or (popup-pattern popup) ""))
|
||
(old-cursor-color (frame-parameter (selected-frame) 'cursor-color))
|
||
prompt key binding)
|
||
(unwind-protect
|
||
(cl-block nil
|
||
(if cursor-color
|
||
(set-cursor-color cursor-color))
|
||
(while t
|
||
(setq prompt (popup-isearch-prompt popup pattern))
|
||
(setq key (popup-menu-read-key-sequence keymap prompt help-delay))
|
||
(if (null key)
|
||
(unless (funcall popup-menu-show-quick-help-function popup nil :prompt prompt)
|
||
(clear-this-command-keys)
|
||
(push (read-event prompt) unread-command-events))
|
||
(setq binding (lookup-key keymap key))
|
||
(cond
|
||
((and (stringp key)
|
||
(popup-isearch-char-p (aref key 0)))
|
||
(setq pattern (concat pattern key)))
|
||
((eq binding 'popup-isearch-done)
|
||
(cl-return nil))
|
||
((eq binding 'popup-isearch-cancel)
|
||
(popup-isearch-update popup filter "" callback)
|
||
(cl-return t))
|
||
((eq binding 'popup-isearch-close)
|
||
(popup-isearch-update popup filter "" callback)
|
||
(setq unread-command-events
|
||
(append (listify-key-sequence key) unread-command-events))
|
||
(cl-return nil))
|
||
((eq binding 'popup-isearch-delete)
|
||
(if (> (length pattern) 0)
|
||
(setq pattern (substring pattern 0 (1- (length pattern))))))
|
||
((eq binding 'popup-isearch-yank)
|
||
(popup-isearch-update popup filter (car kill-ring) callback)
|
||
(cl-return nil))
|
||
(t
|
||
(setq unread-command-events
|
||
(append (listify-key-sequence key) unread-command-events))
|
||
(cl-return nil)))
|
||
(popup-isearch-update popup filter pattern callback))))
|
||
(if old-cursor-color
|
||
(set-cursor-color old-cursor-color)))))
|
||
|
||
|
||
|
||
;;; Popup Tip
|
||
|
||
(defface popup-tip-face
|
||
'((t (:background "khaki1" :foreground "black")))
|
||
"Face for popup tip."
|
||
:group 'popup)
|
||
|
||
(defvar popup-tip-max-width 80)
|
||
|
||
(cl-defun popup-tip (string
|
||
&key
|
||
point
|
||
(around t)
|
||
width
|
||
(height 15)
|
||
min-height
|
||
max-width
|
||
truncate
|
||
margin
|
||
margin-left
|
||
margin-right
|
||
scroll-bar
|
||
parent
|
||
parent-offset
|
||
nowait
|
||
nostrip
|
||
prompt
|
||
&aux tip lines)
|
||
"Show a tooltip of STRING at POINT. This function is
|
||
synchronized unless NOWAIT specified. Almost all arguments are
|
||
the same as in `popup-create', except for TRUNCATE, NOWAIT, and
|
||
PROMPT.
|
||
|
||
If TRUNCATE is non-nil, the tooltip can be truncated.
|
||
|
||
If NOWAIT is non-nil, this function immediately returns the
|
||
tooltip instance without entering event loop.
|
||
|
||
If `NOSTRIP` is non-nil, `STRING` properties are not stripped.
|
||
|
||
PROMPT is a prompt string when reading events during event loop."
|
||
(if (bufferp string)
|
||
(setq string (with-current-buffer string (buffer-string))))
|
||
|
||
(unless nostrip
|
||
;; TODO strip text (mainly face) properties
|
||
(setq string (substring-no-properties string)))
|
||
|
||
(and (eq margin t) (setq margin 1))
|
||
(or margin-left (setq margin-left margin))
|
||
(or margin-right (setq margin-right margin))
|
||
|
||
(let ((it (popup-fill-string string width popup-tip-max-width)))
|
||
(setq width (car it)
|
||
lines (cdr it)))
|
||
|
||
(setq tip (popup-create point width height
|
||
:min-height min-height
|
||
:max-width max-width
|
||
:around around
|
||
:margin-left margin-left
|
||
:margin-right margin-right
|
||
:scroll-bar scroll-bar
|
||
:face 'popup-tip-face
|
||
:parent parent
|
||
:parent-offset parent-offset))
|
||
|
||
(unwind-protect
|
||
(when (> (popup-width tip) 0) ; not to be corrupted
|
||
(when (and (not (eq width (popup-width tip))) ; truncated
|
||
(not truncate))
|
||
;; Refill once again to lines be fitted to popup width
|
||
(setq width (popup-width tip))
|
||
(setq lines (cdr (popup-fill-string string width width))))
|
||
|
||
(popup-set-list tip lines)
|
||
(popup-draw tip)
|
||
(if nowait
|
||
tip
|
||
(clear-this-command-keys)
|
||
(push (read-event prompt) unread-command-events)
|
||
t))
|
||
(unless nowait
|
||
(popup-delete tip))))
|
||
|
||
|
||
|
||
;;; Popup Menu
|
||
|
||
(defface popup-menu-face
|
||
'((t (:inherit popup-face)))
|
||
"Face for popup menu."
|
||
:group 'popup)
|
||
|
||
(defface popup-menu-mouse-face
|
||
'((t (:background "blue" :foreground "white")))
|
||
"Face for popup menu."
|
||
:group 'popup)
|
||
|
||
(defface popup-menu-selection-face
|
||
'((t (:inherit default :background "steelblue" :foreground "white")))
|
||
"Face for popup menu selection."
|
||
:group 'popup)
|
||
|
||
(defface popup-menu-summary-face
|
||
'((t (:inherit popup-summary-face)))
|
||
"Face for popup summary."
|
||
:group 'popup)
|
||
|
||
(defvar popup-menu-show-tip-function 'popup-tip
|
||
"Function used for showing tooltip by `popup-menu-show-quick-help'.")
|
||
|
||
(defun popup-menu-show-help (menu &optional persist item)
|
||
(popup-item-show-help (or item (popup-selected-item menu)) persist))
|
||
|
||
(defun popup-menu-documentation (menu &optional item)
|
||
(popup-item-documentation (or item (popup-selected-item menu))))
|
||
|
||
(defun popup-menu-show-quick-help (menu &optional item &rest args)
|
||
(let* ((point (plist-get args :point))
|
||
(height (or (plist-get args :height) (popup-height menu)))
|
||
(min-height (min height (popup-current-height menu)))
|
||
(around nil)
|
||
(parent-offset (popup-offset menu))
|
||
(doc (popup-menu-documentation menu item)))
|
||
(when (stringp doc)
|
||
(if (popup-hidden-p menu)
|
||
(setq around t
|
||
menu nil
|
||
parent-offset nil)
|
||
(setq point nil))
|
||
(let ((popup-use-optimized-column-computation nil)) ; To avoid wrong positioning
|
||
(apply popup-menu-show-tip-function
|
||
doc
|
||
:point point
|
||
:height height
|
||
:min-height min-height
|
||
:around around
|
||
:parent menu
|
||
:parent-offset parent-offset
|
||
args)))))
|
||
|
||
(defun popup-menu-item-of-mouse-event (event)
|
||
(when (and (consp event)
|
||
(memq (cl-first event) '(mouse-1 mouse-2 mouse-3 mouse-4 mouse-5)))
|
||
(let* ((position (cl-second event))
|
||
(object (elt position 4)))
|
||
(when (consp object)
|
||
(get-text-property (cdr object) 'popup-item (car object))))))
|
||
|
||
(defun popup-menu-read-key-sequence (keymap &optional prompt timeout)
|
||
(catch 'timeout
|
||
(let ((timer (and timeout
|
||
(run-with-timer timeout nil
|
||
(lambda ()
|
||
(if (zerop (length (this-command-keys)))
|
||
(throw 'timeout nil))))))
|
||
(old-global-map (current-global-map))
|
||
(temp-global-map (make-sparse-keymap))
|
||
(overriding-terminal-local-map (make-sparse-keymap)))
|
||
(substitute-key-definition 'keyboard-quit 'keyboard-quit
|
||
temp-global-map old-global-map)
|
||
(define-key temp-global-map [menu-bar] (lookup-key old-global-map [menu-bar]))
|
||
(define-key temp-global-map [tool-bar] (lookup-key old-global-map [tool-bar]))
|
||
(set-keymap-parent overriding-terminal-local-map keymap)
|
||
(if (current-local-map)
|
||
(define-key overriding-terminal-local-map [menu-bar]
|
||
(lookup-key (current-local-map) [menu-bar])))
|
||
(unwind-protect
|
||
(progn
|
||
(use-global-map temp-global-map)
|
||
(clear-this-command-keys)
|
||
(with-temp-message prompt
|
||
(read-key-sequence nil)))
|
||
(use-global-map old-global-map)
|
||
(if timer (cancel-timer timer))))))
|
||
|
||
(defun popup-menu-fallback (event default))
|
||
|
||
(cl-defun popup-menu-event-loop (menu
|
||
keymap
|
||
fallback
|
||
&key
|
||
prompt
|
||
help-delay
|
||
isearch
|
||
isearch-filter
|
||
isearch-cursor-color
|
||
isearch-keymap
|
||
isearch-callback
|
||
&aux key binding)
|
||
(cl-block nil
|
||
(while (popup-live-p menu)
|
||
(and isearch
|
||
(popup-isearch menu
|
||
:filter isearch-filter
|
||
:cursor-color isearch-cursor-color
|
||
:keymap isearch-keymap
|
||
:callback isearch-callback
|
||
:help-delay help-delay)
|
||
(keyboard-quit))
|
||
(setq key (popup-menu-read-key-sequence keymap prompt help-delay))
|
||
(setq binding (and key (lookup-key keymap key)))
|
||
(cond
|
||
((or (null key) (zerop (length key)))
|
||
(unless (funcall popup-menu-show-quick-help-function menu nil :prompt prompt)
|
||
(clear-this-command-keys)
|
||
(push (read-event prompt) unread-command-events)))
|
||
((eq (lookup-key (current-global-map) key) 'keyboard-quit)
|
||
(keyboard-quit)
|
||
(cl-return))
|
||
((eq binding 'popup-close)
|
||
(if (popup-parent menu)
|
||
(cl-return)))
|
||
((memq binding '(popup-select popup-open))
|
||
(let* ((item (or (popup-menu-item-of-mouse-event (elt key 0))
|
||
(popup-selected-item menu)))
|
||
(index (cl-position item (popup-list menu)))
|
||
(sublist (popup-item-sublist item)))
|
||
(unless index (cl-return))
|
||
(if sublist
|
||
(popup-aif (let (popup-use-optimized-column-computation)
|
||
(popup-cascade-menu sublist
|
||
:around nil
|
||
:margin-left (popup-margin-left menu)
|
||
:margin-right (popup-margin-right menu)
|
||
:scroll-bar (popup-scroll-bar menu)
|
||
:parent menu
|
||
:parent-offset index
|
||
:help-delay help-delay
|
||
:isearch isearch
|
||
:isearch-filter isearch-filter
|
||
:isearch-cursor-color isearch-cursor-color
|
||
:isearch-keymap isearch-keymap
|
||
:isearch-callback isearch-callback))
|
||
(and it (cl-return it)))
|
||
(if (eq binding 'popup-select)
|
||
(cl-return (popup-item-value-or-self item))))))
|
||
((eq binding 'popup-next)
|
||
(popup-next menu))
|
||
((eq binding 'popup-previous)
|
||
(popup-previous menu))
|
||
((eq binding 'popup-page-next)
|
||
(popup-page-next menu))
|
||
((eq binding 'popup-page-previous)
|
||
(popup-page-previous menu))
|
||
((eq binding 'popup-help)
|
||
(popup-menu-show-help menu))
|
||
((eq binding 'popup-isearch)
|
||
(popup-isearch menu
|
||
:filter isearch-filter
|
||
:cursor-color isearch-cursor-color
|
||
:keymap isearch-keymap
|
||
:callback isearch-callback
|
||
:help-delay help-delay))
|
||
((commandp binding)
|
||
(call-interactively binding))
|
||
(t
|
||
(funcall fallback key (key-binding key)))))))
|
||
|
||
(defun popup-preferred-width (list)
|
||
"Return the preferred width to show LIST beautifully."
|
||
(cl-loop with tab-width = 4
|
||
for item in list
|
||
for summary = (popup-item-summary item)
|
||
maximize (string-width (popup-x-to-string item)) into width
|
||
if (stringp summary)
|
||
maximize (+ (string-width summary) 2) into summary-width
|
||
finally return
|
||
(let ((total (+ (or width 0) (or summary-width 0))))
|
||
(* (ceiling (/ total 10.0)) 10))))
|
||
|
||
(defvar popup-menu-keymap
|
||
(let ((map (make-sparse-keymap)))
|
||
(define-key map "\r" 'popup-select)
|
||
(define-key map "\C-f" 'popup-open)
|
||
(define-key map [right] 'popup-open)
|
||
(define-key map "\C-b" 'popup-close)
|
||
(define-key map [left] 'popup-close)
|
||
|
||
(define-key map "\C-n" 'popup-next)
|
||
(define-key map [down] 'popup-next)
|
||
(define-key map "\C-p" 'popup-previous)
|
||
(define-key map [up] 'popup-previous)
|
||
|
||
(define-key map [next] 'popup-page-next)
|
||
(define-key map [prior] 'popup-page-previous)
|
||
|
||
(define-key map [f1] 'popup-help)
|
||
(define-key map (kbd "\C-?") 'popup-help)
|
||
|
||
(define-key map "\C-s" 'popup-isearch)
|
||
|
||
(define-key map [mouse-1] 'popup-select)
|
||
(define-key map [mouse-4] 'popup-previous)
|
||
(define-key map [mouse-5] 'popup-next)
|
||
map))
|
||
|
||
(cl-defun popup-menu* (list
|
||
&key
|
||
point
|
||
(around t)
|
||
(width (popup-preferred-width list))
|
||
(height 15)
|
||
max-width
|
||
margin
|
||
margin-left
|
||
margin-right
|
||
scroll-bar
|
||
symbol
|
||
parent
|
||
parent-offset
|
||
cursor
|
||
(keymap popup-menu-keymap)
|
||
(fallback 'popup-menu-fallback)
|
||
help-delay
|
||
nowait
|
||
prompt
|
||
isearch
|
||
(isearch-filter 'popup-isearch-filter-list)
|
||
(isearch-cursor-color popup-isearch-cursor-color)
|
||
(isearch-keymap popup-isearch-keymap)
|
||
isearch-callback
|
||
initial-index
|
||
&aux menu event)
|
||
"Show a popup menu of LIST at POINT. This function returns a
|
||
value of the selected item. Almost all arguments are the same as in
|
||
`popup-create', except for KEYMAP, FALLBACK, HELP-DELAY, PROMPT,
|
||
ISEARCH, ISEARCH-FILTER, ISEARCH-CURSOR-COLOR, ISEARCH-KEYMAP, and
|
||
ISEARCH-CALLBACK.
|
||
|
||
If KEYMAP is a keymap which is used when processing events during
|
||
event loop.
|
||
|
||
If FALLBACK is a function taking two arguments; a key and a
|
||
command. FALLBACK is called when no special operation is found on
|
||
the key. The default value is `popup-menu-fallback', which does
|
||
nothing.
|
||
|
||
HELP-DELAY is a delay of displaying helps.
|
||
|
||
If NOWAIT is non-nil, this function immediately returns the menu
|
||
instance without entering event loop.
|
||
|
||
PROMPT is a prompt string when reading events during event loop.
|
||
|
||
If ISEARCH is non-nil, do isearch as soon as displaying the popup
|
||
menu.
|
||
|
||
ISEARCH-FILTER is a filtering function taking two arguments:
|
||
search pattern and list of items. Returns a list of matching items.
|
||
|
||
ISEARCH-CURSOR-COLOR is a cursor color during isearch. The
|
||
default value is `popup-isearch-cursor-color'.
|
||
|
||
ISEARCH-KEYMAP is a keymap which is used when processing events
|
||
during event loop. The default value is `popup-isearch-keymap'.
|
||
|
||
ISEARCH-CALLBACK is a function taking one argument. `popup-menu'
|
||
calls ISEARCH-CALLBACK, if specified, after isearch finished or
|
||
isearch canceled. The arguments is whole filtered list of items.
|
||
|
||
If `INITIAL-INDEX' is non-nil, this is an initial index value for
|
||
`popup-select'. Only positive integer is valid."
|
||
(and (eq margin t) (setq margin 1))
|
||
(or margin-left (setq margin-left margin))
|
||
(or margin-right (setq margin-right margin))
|
||
(if (and scroll-bar
|
||
(integerp margin-right)
|
||
(> margin-right 0))
|
||
;; Make scroll-bar space as margin-right
|
||
(cl-decf margin-right))
|
||
(setq menu (popup-create point width height
|
||
:max-width max-width
|
||
:around around
|
||
:face 'popup-menu-face
|
||
:mouse-face 'popup-menu-mouse-face
|
||
:selection-face 'popup-menu-selection-face
|
||
:summary-face 'popup-menu-summary-face
|
||
:margin-left margin-left
|
||
:margin-right margin-right
|
||
:scroll-bar scroll-bar
|
||
:symbol symbol
|
||
:parent parent
|
||
:parent-offset parent-offset))
|
||
(unwind-protect
|
||
(progn
|
||
(popup-set-list menu list)
|
||
(if cursor
|
||
(popup-jump menu cursor)
|
||
(popup-draw menu))
|
||
(when initial-index
|
||
(dotimes (_i (min (- (length list) 1) initial-index))
|
||
(popup-next menu)))
|
||
(if nowait
|
||
menu
|
||
(popup-menu-event-loop menu keymap fallback
|
||
:prompt prompt
|
||
:help-delay help-delay
|
||
:isearch isearch
|
||
:isearch-filter isearch-filter
|
||
:isearch-cursor-color isearch-cursor-color
|
||
:isearch-keymap isearch-keymap
|
||
:isearch-callback isearch-callback)))
|
||
(unless nowait
|
||
(popup-delete menu))))
|
||
|
||
(defun popup-cascade-menu (list &rest args)
|
||
"Same as `popup-menu' except that an element of LIST can be
|
||
also a sub-menu if the element is a cons cell formed (ITEM
|
||
. SUBLIST) where ITEM is an usual item and SUBLIST is a list of
|
||
the sub menu."
|
||
(apply 'popup-menu*
|
||
(mapcar (lambda (item)
|
||
(if (consp item)
|
||
(popup-make-item (car item)
|
||
:sublist (cdr item)
|
||
:symbol ">")
|
||
item))
|
||
list)
|
||
:symbol t
|
||
args))
|
||
|
||
(provide 'popup)
|
||
;;; popup.el ends here
|