diff options
Diffstat (limited to 'elpa/popup-20200610.317/popup.el')
| -rw-r--r-- | elpa/popup-20200610.317/popup.el | 1435 |
1 files changed, 1435 insertions, 0 deletions
diff --git a/elpa/popup-20200610.317/popup.el b/elpa/popup-20200610.317/popup.el new file mode 100644 index 0000000..71aa3f6 --- /dev/null +++ b/elpa/popup-20200610.317/popup.el @@ -0,0 +1,1435 @@ +;;; popup.el --- Visual Popup User Interface + +;; Copyright (C) 2009-2015 Tomohiro Matsuyama + +;; Author: Tomohiro Matsuyama <m2ym.pub@gmail.com> +;; Keywords: lisp +;; Package-Version: 20200610.317 +;; Package-Commit: 9d104d4bbbcb37bbc9d9ce762e74d41174683f86 +;; Version: 0.5.8 +;; 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.8") + + + +;;; Utilities + +(defun popup-calculate-max-width (max-width) + "Determines whether the width with MAX-WIDTH desired is character or window \ +proportion based, And return 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 efficiently. +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'." + (when (bound-and-true-p display-line-numbers-mode) + (setq column (- column (line-number-display-width 'columns)))) + (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-text-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 |