From ab71b0be808bb0fb6199d7ca6433f6ac2bbc4cff Mon Sep 17 00:00:00 2001 From: John Miller Date: Fri, 9 Sep 2016 09:44:43 -0500 Subject: [PATCH] Squashed 'lib/popup/' content from commit 80829dd git-subtree-dir: lib/popup git-subtree-split: 80829dd46381754639fb764da11c67235fe63282 --- .gitignore | 2 + .travis.yml | 13 + Cask | 7 + Makefile | 27 + README.md | 356 ++++++++ etc/images/popup1.png | Bin 0 -> 2176 bytes etc/images/popup2.png | Bin 0 -> 2099 bytes etc/images/popup3.png | Bin 0 -> 2246 bytes popup.el | 1431 +++++++++++++++++++++++++++++++ tests/popup-interactive-test.el | 124 +++ tests/popup-test.el | 664 ++++++++++++++ tests/run-test.el | 32 + 12 files changed, 2656 insertions(+) create mode 100644 .gitignore create mode 100644 .travis.yml create mode 100644 Cask create mode 100644 Makefile create mode 100644 README.md create mode 100644 etc/images/popup1.png create mode 100644 etc/images/popup2.png create mode 100644 etc/images/popup3.png create mode 100644 popup.el create mode 100644 tests/popup-interactive-test.el create mode 100644 tests/popup-test.el create mode 100644 tests/run-test.el diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e15865d --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +/.cask/ +*.elc diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..62d1878 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,13 @@ +language: generic +sudo: false +before_install: + - curl -fsSkL https://gist.github.com/rejeep/ebcd57c3af83b049833b/raw > x.sh && source ./x.sh + - evm install $EVM_EMACS --use --skip + - cask +env: + - EVM_EMACS=emacs-24.3-travis + - EVM_EMACS=emacs-24.4-travis + - EVM_EMACS=emacs-24.5-travis +script: + - emacs --version + - make travis-ci diff --git a/Cask b/Cask new file mode 100644 index 0000000..c7b2ddb --- /dev/null +++ b/Cask @@ -0,0 +1,7 @@ +(source gnu) +(source melpa) + +(package-file "popup.el") + +(development + (depends-on "ert")) diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..d26c0ef --- /dev/null +++ b/Makefile @@ -0,0 +1,27 @@ +EMACS ?= emacs +CASK ?= cask +EMACS23=emacs23 + +ELPA_DIR = $(shell EMACS=$(EMACS) $(CASK) package-directory) + +.PHONY: test test-nw test-emacs23 test-emacs23-nw travis-ci + +test: + $(CASK) exec $(EMACS) -Q -L . -l tests/run-test.el + +test-nw: + $(CASK) exec $(EMACS) -Q -nw -L . -l tests/run-test.el + +test-emacs23: tests/ert.el + ${EMACS23} -Q -L . -l test/ert.el -l tests/run-test.el + +test-emacs23-nw: tests/ert.el + $(EMACS23) -Q -nw -L . -l test/ert.el -l tests/run-test.el + +travis-ci: elpa + $(CASK) exec $(EMACS) -batch -Q -l tests/run-test.el + +elpa: $(ELPA_DIR) +$(ELPA_DIR): Cask + $(CASK) install + touch $@ diff --git a/README.md b/README.md new file mode 100644 index 0000000..e0e68b9 --- /dev/null +++ b/README.md @@ -0,0 +1,356 @@ +popup.el +======== + +[![Build Status](https://secure.travis-ci.org/auto-complete/popup-el.svg)](http://travis-ci.org/auto-complete/popup-el) [![melpa badge][melpa-badge]][melpa-link] [![melpa stable badge][melpa-stable-badge]][melpa-stable-link] + +Overview +-------- + +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. + +Screenshots +----------- + +**Tooltip** + +![](https://raw.githubusercontent.com/auto-complete/popup-el/master/etc/images/popup1.png) + +**Popup Menu** + +![](https://raw.githubusercontent.com/auto-complete/popup-el/master/etc/images/popup2.png) + +**Popup Cascade Menu** + +![](https://raw.githubusercontent.com/auto-complete/popup-el/master/etc/images/popup3.png) + +Installation +------------ + +You can install `popup.el` from [MELPA](https://melpa.org/) with package.el. +popwin is tested under GNU Emacs 24 or later. + +Alternatively, users of Debian 9 or later or Ubuntu 16.04 or later may +simply `apt-get install elpa-popup`. + +Popup Items +----------- + +Elements of `popup-list` have to be popup items. A popup item is +substantially a string but it may involve some text-properties. There +are two ways to make popup items. One is just using strings. Another +is to use the `popup-make-item` function, which just returns the string +after adding text-properties of its keywords. Effective text-properties +are: + +* `value` -- This represents the **real** value of the item. This will + be used when returning the value but not the item (or string) from + some synchronous functions such as `popup-menu*`. +* `face` -- The background face of the item. The value of `popup-face` + will be overridden. +* `selection-face` -- The selection face of the item. The value of + `popup-selection-face` will be overridden. +* `document` -- The documentation string or function of the item. +* `summary` -- The summary string of the item. This will be shown + inline with the item. +* `symbol` -- The symbol character of the item. +* `sublist` -- The sublist of the item. This is effective only with + `popup-cascade-menu`. + +All of properties can be accessed by `popup-item-` utility function. + +### Function: `popup-item-propertize` + + popup-item-propertize item &rest properties => item + +Same as `propertize` except that this avoids overriding existed value +with `nil` property. + +### Function: `popup-make-item` + + popup-make-item name &key value popup-face selection-face sublist + document symbol summary => item + +The utility function of `popup-item-propertize`. + +Popups +------ + +This section describes the basic data structures and operations of +popups. + +### Struct: `popup` + +Any instance of `popup` structure has the following fields (some +unimportant fields are not listed): + +* `point` +* `row` -- The line number. +* `column` +* `width` -- Max width of `popup` instance. +* `height` -- Max height of `popup` instance. +* `min-height` +* `current-height` +* `direction` -- Positive number means forward, negative number means + backward. +* `parent` -- The parent of `popup` instance. +* `face` -- The background face. +* `selection-face` +* `margin-left` +* `margin-right` +* `scroll-bar` -- Non-nil means `popup` instance has a scroll bar. +* `symbol` -- Non-nil means `popup` instance has a space for + displaying symbols of item. +* `cursor` -- The current position of `list`. +* `scroll-top` -- The offset of scrolling. +* `list` -- The contents of `popup` instance in a list of items + (strings). +* `original-list` -- Same as `list` except that this is not filtered. + +All of these fields can be accessed by `popup-` function. + +### Function: `popup-create` + + popup-create point width height &key min-height max-width around face + selection-face scroll-bar margin-left margin-right symbol parent + parent-offset => popup + +Create a popup instance at `POINT` with `WIDTH` and `HEIGHT`. + +`MIN-HEIGHT` is the 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 the background face of the popup. The default value is +`popup-face`. + +`SELECTION-FACE` is the 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 the kind of the item. + +`PARENT` is the parent popup instance. If `PARENT` is omitted, the popup +will be a root instance. + +`PARENT-OFFSET` is a row offset from the parent popup. + +Here is an example: + + (setq popup (popup-create (point) 10 10)) + (popup-set-list popup '("Foo" "Bar" "Baz")) + (popup-draw popup) + ;; do something here + (popup-delete popup) + +### Function: `popup-delete` + + popup-delete popup + +Delete the `POPUP`. + +### Function: `popup-live-p` + + popup-live-p popup => boolean + +### Function: `popup-set-list` + + popup-set-list popup list + +Set the contents of the `POPUP`. `LIST` has to be popup items. + +### Function: `popup-draw` + + popup-draw popup + +Draw the contents of the `POPUP`. + +### Function: `popup-hide` + + popup-hide popup + +Hide the `POPUP`. To show again, call `popup-draw`. + +### Function: `popup-hidden-p` + + popup-hidden-p popup + +Return non-nil if the `POPUP` is hidden. + +### Function: `popup-select` + + popup-select popup index + +Select the item of `INDEX` of the `POPUP`. + +### Function: `popup-selected-item` + + popup-selected-item popup => item + +Return the selected item of the `POPUP`. + +Return non-nil if the `POPUP` is still alive. + +### Function: `popup-next` + + popup-next popup + +Select the next item of the `POPUP`. + +### Function: `popup-previous` + + popup-previous popup + +Select the next item of the `POPUP`. + +### Function: `popup-scroll-down` + + popup-scroll-down popup n + +Scroll down `N` items of the `POPUP`. This won't wrap. + +### Function: `popup-scroll-up` + + popup-scroll-up popup n + +Scroll up `N` items of the `POPUP`. This won't wrap. + +### Function: `popup-isearch` + + popup-isearch popup &key cursor-color keymap callback help-delay + => boolean + +Enter incremental search event loop of `POPUP`. + +Tooltips +-------- + +A tooltip is an useful visual UI widget for displaying information +something about what cursor points to. + +### Function: `popup-tip` + + popup-tip string &key point around width height min-height max-width + truncate margin margin-left margin-right scroll-bar parent + parent-offset nowait nostrip prompt + +Show a tooltip with message `STRING` at `POINT`. This function is +synchronized unless `NOWAIT` specified. Almost all arguments are same as +`popup-create` except for `TRUNCATE`, `NOWAIT`, `NOSTRIP` 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 used when reading events during the event +loop. + +Here is an example: + + (popup-tip "Hello, World!") + ;; reach here after the tooltip disappeared + +Popup Menus +----------- + +Popup menu is an useful visual UI widget for prompting users to +select an item of a list. + +### Function: `popup-menu*` + + popup-menu* list &key point around width height margin margin-left + margin-right scroll-bar symbol parent parent-offset keymap + fallback help-delay nowait prompt isearch isearch-filter isearch-cursor-color + isearch-keymap isearch-callback initial-index => selected-value + +Show a popup menu of `LIST` at `POINT`. This function returns the value +of the selected item. Almost all arguments are same as `popup-create` +except for `KEYMAP`, `FALLBACK`, `HELP-DELAY`, `PROMPT`, `ISEARCH`, +`ISEARCH-FILTER`, `ISEARCH-CURSOR-COLOR`, `ISEARCH-KEYMAP` +and `ISEARCH-CALLBACK`. + +If `KEYMAP` is provided, it is a keymap which is used when processing +events during event loop. + +If `FALLBACK` is provided, it 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. + +Here is an example: + + (popup-menu* '("Foo" "Bar" "Baz")) + ;; => "Baz" if you select Baz + (popup-menu* (list (popup-make-item "Yes" :value t) + (popup-make-item "No" :value nil))) + ;; => t if you select Yes + +### Function: `popup-cascade-menu` + +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. + +Here is an example: + + (popup-cascade-menu '(("Top1" "Sub1" "Sub2") "Top2")) + + +### Customize Variables + +#### `popup-isearch-regexp-builder-function` + +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. Default value is `#'regexp-quote`. + +---- + +Copyright (C) 2011-2015 Tomohiro Matsuyama <> + +[melpa-link]: https://melpa.org/#/popup +[melpa-stable-link]: https://stable.melpa.org/#/popup +[melpa-badge]: https://melpa.org/packages/popup-badge.svg +[melpa-stable-badge]: https://stable.melpa.org/packages/popup-badge.svg diff --git a/etc/images/popup1.png b/etc/images/popup1.png new file mode 100644 index 0000000000000000000000000000000000000000..c1a81c911390d0d685ca888fde7c46fa2e759769 GIT binary patch literal 2176 zcmeH|X*3&%7ROV@sM=m<@GK>?NaBfV+pVVZ_4c9aDrjW{oWG=Ez`yP5{xt93lHX?dB>&zG z5O%cl0RYXK6MjCSxCx1fLo#p$a4%xo3`5-g@|x-bOl-aKl0r?Fo?X}I^iX{x<-h_PGW2Cl0HRwJI2KKOEAaNL4VC8Y5)E~o1N4E>Y) z%3C6&YER=IxpczC+mq*JejZ7qd1yshevo2js}}e|fl$6`rFbtR6E~Jq?`3w%6Y)Zm zANZ~qu@#fdek|=MsewI245O%TmV(xN?e?IaUoaw;r-K-@rdf`K;{du*^kvycGKNW( zSeGR2=#UJ76NzPm=$OIU>S$MXLQi8~WH_?YH003PzSurZuYnJC7!cZ8yzq=d+&gl8 zG}pw~j1w0W)zDf!P4SsU6QbIr;Wic)V&*I#<(Z@G1$Ltet>#VidtV`{bf>iQBW$=t zVWA>w2zWTyWTNnJ>~*Q$X+mOI$?UTTqW(W2oTM9JzM?HbOPxIOx=b`V1#Xh71`U(=w-Az#d-decAVC32g{qU)e`;! z4Lb`LILdis>%w3y4Nsfzj8&$HG^pHisAPUd?MZv@ z6HWULJvOq(-d0%A#6Mc7e0^2EHcSd;K1`s%e5e5ZdH`gd<2yn(6Ac^Wrgq&(LdySZ zOTFM=gwehGq9}KU`YzuVqU(FKSSI6hf^$-GB@yW zYg0qgdnNE&=WM7>QT>k8Vn-px&^%ZvHgDevje|*Iybg76*G`%KH50HvE$vv!F35GG zzx^NolM%Et2%;x=W>yfu7*XUV_nu-3C6gPYs3$q=KV~KG`bDURQG4Ge^lCQ)fuuJ} z?OGT@FCJ4687ITuUk}1)G%k7IbJ0btkJC9>c@->3>N$>4|JXxEmm4!@G!&ArGx7}` zs@nE?ymT|_HaTrjanZu>1-xs7pd?!r~}Rsx+Z0{XcNNF2~=P-MS?X~nlh zRyA++xVKL~J`i&Z{zjzs*$A0Sbj^3__uc|dEJ^2aF~tj0#AUNntrwqeJ(C6T7W$_A z&t4>q#?SXY@)q&8bo5uwomk(zVvjRTemQD+U{bI_CsW4bHb2!ULbCPzbM^N9lI%RM zGlczOSq>EzKrU11ccx)YypBs5DFuzEdwx8^Y7Fe^W|;L4yg9zI#;d#l8n69fTv9V$ zLd>dW6Q^x>@Tljeoh`FbZ3?z+e-&(i4siafcv3O_mjZmyTH zJhDhLhNU&*je@L({ugmCoCh>La6g4&S3fF9!dckuiSh?f#6W)u=M$=E$>>P3 zi4Ms)xG@BNkt0S>Hwm7wFxrf=qtjIx%}NBE_B;$%|DLZGI~z#%CtEBd|#-0Gz-Ohyxhv0Co+9 vK;4~>xI04*f!*A};2CT5tv?7*n8XXn>^~QfvqwEt0>Fvmfqrz~xcpxMWkJ&R literal 0 HcmV?d00001 diff --git a/etc/images/popup2.png b/etc/images/popup2.png new file mode 100644 index 0000000000000000000000000000000000000000..12b89faf2b1f4320e7b0e251be13a12ffb5d5878 GIT binary patch literal 2099 zcmeH|`8V5n7stP$sK(Zf#O|PqYK7XP8KNbsw4;xu_C)NlC1cBos)`s(TSb#Gs5xzz zBB-Ucw^iFvv^0pMI z9svMA8s%X3Jph2Zt)DHuI z#5I(i&GiJDxizkKwHvBf+EL9 z?xsA{^_7y*auuY>l+@qeU~8n#H+}gl3%3Iaoo*v}?nl$_!ks!dHs2z5 zrmxJd1VeG%<%G+O$M;r(n8d9==c=bN8i`)^`*jlTd&3HyIpfDWtFI|3HdT8)lTE`z z9;o|8hCB#(1jerLw5F1N+>Ty}D~|y0J*D@8cdu?QVA|({z~)?wT4Xp;(x@Q2LC_qh z(4gO-9iwuv^lYl1pWisgWsVhAjzC`xQCP6@a&op@~EuW&gb+SHq%wv|2k#z z9>tI>cwAvj>gVr-g$HP;xslK__&!gArbX-OeWP4^*W$oA-z)JQ@JTmMycpZ^?xq{| z(|(tc0a4Z4*~?Y%8NzfH)WGJ?aLtkLX_94(A-S%IbGXi)iJjC`+=YRuA6JU9hE*5v z$2pp-t(_f596R7GPdGULIXv3yMM=~zqhxM$eCN;@(YUx zLBN^@>U83x+ojEN;Xw+@{8ZS&hRf0*h&252tI;EZm^Xn2azUv5L>My=lo z{#-3@w3?jaZ?UX_OI;3N%A#thdu72?M_XGJC%}ISTdmq!#cigrI_??)Ka=oEISPOv|FFivf9**WHzeozVYYj}pYM9{+JhqUI-fo2>+5Uu zLZp$9VVZbH@kFc|*onLdQzwszpbs0UlO@Cf7~Bw`1bmweA$17REKQ0S2$9MTrb>uY z5u*2@E2$tPIu#|weF0>O(P4wOCo;uO8Bd6c^2`;e;<8czde`FH%GwY3vW-@f9}(FN zHzBrQipD<>u7K*ZKW--BH@+qbV6yi<)w_Ipg*Y(BPqj7@DczQd(P3sK)+sHhVxD_3 z+#EOU5-cW}Q}$Ih3YxLhW`4oAhi%pArrL@mnBy| zoV4nL1(6^*3N+AK=!~)NhN{-&#-M$*08SK)`GO)br@5@BDdeQ_`4MIXn|Q5Kv>mxz zx|Yzo*qXezNktMCm}-aQO`#Fv>m^L>(c}q2;feam5XY?I)|O)j1H^@R{vPgW?%sj2 zdBt&e2W~mTKW{$8ZoYI+Pa&x~fZ4RH_CQ_sBwpTg#1Go*)25zj)QCr4&M`B^ zR%H@oe6aCgxi;bd&~|hzbg7GBRl?JhZBg3MoxJ0F3uG!o^=sx2@apRDp?Yh>Mozy> zuri2mhBwIVzb7X0EKXMS&{iz^=sOL?TeE0Wh~W7`M?q;9XgoDdaHc2U=4ThQPs%AT z2p(rrd?=-ik?hX5RjM)-tN#>;q9u^R&GKk<_b1-Cgb$GN__U(?66IW%mu=2IHXC_g z!9xMlZl(t}L%b=D&Z>D^E4v$H%a8Q8@1>K@23@iFvaAK>@WY0v@Y3g|?N-I-vd3@y z?&e2c+DiC2_q+x4jCscDOBs1uY_7F{y?L3JUZGNdz=UjZ77#hf$6!yOxin*5PQ?&s zXjR#Ayo{3)zH4$RTSo`LYJ@_o!qm1;Fzi|X^Bhr^?-kl_0kGTha>x+S-=W^MRTOx- z`2u+OS&i@Cezxkv2XW!WJxaLfLBK@eaM(x!pohoA1`seIdIMeqe!`^oU&+7#0@e}} zixmPeGK9el42=y8&91|YEln&ejnC^FT38wy(&{v6|0Tdh1%?JC{(r&el_G7S06<-I Kwqw}(-}*NvqPe{Q literal 0 HcmV?d00001 diff --git a/etc/images/popup3.png b/etc/images/popup3.png new file mode 100644 index 0000000000000000000000000000000000000000..03d6464306915562a3aeda35a7ca43d426896c98 GIT binary patch literal 2246 zcmeH}**_Z!7RRF<%TPrZ#8OqI+Ka~0i_|hzwU)GKQ$mw8mk3P+5w}uX7fTVeYG10T zx)ExPE!<*~*3#Hw31M2jB}H0Imy@D9pz=! zWB~wxyt9+N2LK>pwO>a2iyG7B;qfj|2++uZfsxy z0MehG?Js%#%vs^qku@#=7@=Am$0T?CCy%m@ncbC;*7cBm>SQUIoG+^#HpYWoZ#kSS zAf?9>&gf#+q-6Y}p)Y0n-m$mUEYr<_546qP!8$bHwMB~= zK#eBfi-JvmkXG?bn*f1}u zFO(4^o|+1WSu9=+&bG8ZJg+jFb(V&4Om+M2J52n%$b36QzdFZ!a`C}5t&ECCxeTjM zh~LfjqTCFoyT6e;*uc9XOT+RJ5!R!`xjC#(c}dN88O`}1{rr(qQpL9xUH=kH8KoU2 zd(~wLSjZQ-@7SYVmz(|b64IQ{6V|X&*Pq4jb zv(m$cq&-dVGUNs~ibO)VOQgi~-<{-=cv={^hSv6Zt-`|R{BW`gGcm1Lw4fX1G3n;q zg$s}p3LZXd0MYpVzw5m4xoBqH+-k^`LwM$OO%8I!y9l;^)ipxLibd@`D>X#Gb}V;b zW20%BNDD*V0cK~})Ed>W($-~{8tK(Q3iE5!zFuQB3Xa+7R>)u6@z$@Kl#JR-jCT`! zNb8xhNxp(525O(vi8-x&ybp*GOWTnkiMmb6jM{mFZZNx8jp(*#H-@$?$>yJyLTI~a zb_rE;3wC*{A#>3lZO>q!l7uE-rsvgZ)riqNxJY9umWJy^>^V0AmA%zT<&gW_WALHH<0C$y^216J5>6A{Ld>G z=-yo#E_19P9r#rhHSl%;ITh3tHZ4cn_{ye?6iE(+)NN_U{YYU~aV@}69nM8rbPl<} zr--Q4O0&bZ*)5f%&Ll^)TeX@nW-L34{E&C}vd{-WM{;)g zOix*1#3$ycJ~pjE@%Zi4RN=|Kgvt{Y+u;PkWak_XWw7a9AIpfE2nr0o!{_F`pcW2o z=Ukk@iFnsytb&qoSn;LWJU4}+x2#5^JbqaP?R3GQ1I%Z6hW-5a^WQY)HWz5a;4eLv z_%iof+MJSlHBXa09TRb%N-K2<7=VTBq=5QvG?{nB;$xkHNrx4LVG(?;h@pA^qxn3I zGj2<|wpU5ly~jcs{j4WbPMLQUtbOi-n_#X zx9p70?HkZ3>tklb^ycHZM~1svoMqM*ystcSHkC4^is*^kdfpCym7Yd-^+d*gL4NAZ zw&C84NibhV_whfTfuf>6^g3{qiZP^x_fvO4JE1JGzICEb%|Y{RQ*}?NsxQ55C)}I8 zzHoxt4RBeTa?**-b)2!>xNMM zt8E}vD>G%IJ*gCq<}%}yXCE6MvBO&}w%k8>8qr%nz)@b%kGW@8(_YUe1hxDEg+dvs z1vfhxNro=1-1SqLHmwxxu=(xCa=)D|46hgvxUnlHp=>lTLZNUvXs+cRg^(DpxrP(# z8Ti&t;0n6_qL8HB7^i9{_h-nZk7xoimj5vV8aWWQE0MS91NeLx0@;58ln7UD5l|sm ztUrzbI2VozLlRJd=lWs&@O@GD5Ai1?!5@qY^WO)+1Y~S%2r@MUnR^+VfkDP#vkO0f mEWseqx$pg)|1e-fe!>LY`|k!AH9TP70C2wIZeL@Ec<@i-CMd=L literal 0 HcmV?d00001 diff --git a/popup.el b/popup.el new file mode 100644 index 0000000..b67a777 --- /dev/null +++ b/popup.el @@ -0,0 +1,1431 @@ +;;; popup.el --- Visual Popup User Interface + +;; Copyright (C) 2009-2015 Tomohiro Matsuyama + +;; Author: Tomohiro Matsuyama +;; Keywords: lisp +;; 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 . + +;;; 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 diff --git a/tests/popup-interactive-test.el b/tests/popup-interactive-test.el new file mode 100644 index 0000000..3839717 --- /dev/null +++ b/tests/popup-interactive-test.el @@ -0,0 +1,124 @@ +(require 'popup) + +(defmacro test (explain &rest body) + (declare (indent 1)) + `(let ((buf "*buf*") + (window-config (current-window-configuration))) + (unwind-protect + (progn + (delete-other-windows) + (switch-to-buffer buf) + (erase-buffer) + (insert " ") + (let ((success (progn ,@body))) + (unless success + (error "failed: %s" ,explain)))) + (when popup + (popup-delete popup) + (setq popup nil)) + (kill-buffer buf) + (set-window-configuration window-config)))) + +(defmacro ui-test (prompt &rest body) + (declare (indent 1)) + `(test ,prompt ,@body (yes-or-no-p ,prompt))) + +(defun input (key) + (push key unread-command-events)) + +(defvar popup nil) + +(test "popup-create" + (setq popup (popup-create (point) 10 10))) + +(test "popup-delete" + (setq popup (popup-create (point) 10 10)) + (popup-delete popup) + (not (popup-live-p popup))) + +(ui-test "popup?" + (setq popup (popup-create (point) 10 10)) + (popup-set-list popup '("hello" "world")) + (popup-draw popup)) + +(ui-test "hidden?" + (setq popup (popup-create (point) 10 10)) + (popup-set-list popup '("hello" "world")) + (popup-draw popup) + (popup-hide popup)) + +(ui-test "isearch?" + (setq popup (popup-create (point) 10 10)) + (popup-set-list popup '("hello" "world")) + (popup-draw popup) + (input ?e) + (popup-isearch popup)) + +(ui-test "tip?" + (popup-tip + "Start isearch on POPUP. This function is synchronized, meaning +event loop waits for quiting of isearch. + +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." + :nowait t)) + +(ui-test "fold?" + (let ((s (make-string (- (window-width) 3) ? ))) + (insert s) + (setq popup (popup-tip "long long long long line" :nowait t)))) + +(ui-test "fold?" + (let ((s (make-string (- (window-height) 3) ?\n))) + (insert s) + (setq popup (popup-tip "bla\nbla\nbla\nbla\nbla" :nowait t)))) + +(ui-test "margin?" + (setq popup (popup-tip "Margin?" :nowait t :margin t))) + +(ui-test "two lines?" + (setq popup (popup-tip "Foo\nBar\nBaz" :nowait t :height 2))) + +(ui-test "scroll bar?" + (setq popup (popup-tip "Foo\nBar\nBaz\nFez\nOz" :nowait t :height 3 :scroll-bar t :margin t))) + +(ui-test "min-height?" + (setq popup (popup-tip "Hello" :nowait t :min-height 10))) + +(ui-test "menu?" + (setq popup (popup-menu* '("Foo" "Bar" "Baz") :nowait t))) + +(ui-test "cascade menu?" + (setq popup (popup-cascade-menu '(("Foo" "Foo1" "Foo2") "Bar" "Baz") :nowait t :margin t))) + +(ui-test "next?" + (setq popup (popup-cascade-menu '("Foo" "Bar" "Baz") :nowait t :margin t)) + (popup-next popup)) + +(ui-test "previous?" + (setq popup (popup-cascade-menu '("Foo" "Bar" "Baz") :nowait t :margin t)) + (popup-previous popup)) + +(ui-test "select?" + (setq popup (popup-cascade-menu '("Foo" "Bar" "Baz") :nowait t :margin t)) + (popup-select popup 1)) + +(ui-test "scroll-down?" + (setq popup (popup-cascade-menu (loop repeat 100 collect "Foo") :nowait t :height 10 :margin t :scroll-bar t)) + (popup-scroll-down popup 10)) + +(ui-test "scroll-up?" + (setq popup (popup-cascade-menu (loop repeat 100 collect "Foo") :nowait t :height 10 :margin t :scroll-bar t)) + (popup-scroll-down popup 999) + (popup-scroll-up popup 10)) + +(message "Congratulations!") diff --git a/tests/popup-test.el b/tests/popup-test.el new file mode 100644 index 0000000..7da821d --- /dev/null +++ b/tests/popup-test.el @@ -0,0 +1,664 @@ +(require 'ert) + +(require 'popup) + +(when (< (frame-width) (length "long long long long line")) + (set-frame-size (selected-frame) 80 35)) + +(defun popup-test-helper-posn-col-row (dummy) + "This function is workaround. Because `posn-col-row' and `posn-at-point' +can not work well in batch mode." + (cons (current-column) (line-number-at-pos (point)))) + +(defmacro popup-test-with-common-setup (&rest body) + (declare (indent 0) (debug t)) + `(save-excursion + (with-temp-buffer + (switch-to-buffer (current-buffer)) + (delete-other-windows) + (erase-buffer) + (if noninteractive + (cl-letf (((symbol-function 'posn-col-row) + #'popup-test-helper-posn-col-row)) + ,@body) + ,@body)))) + +(defun popup-test-helper-line-move-visual (arg) + "This function is workaround. Because `line-move-visual' can not work well in +batch mode." + (let ((cur-col + (- (current-column) + (save-excursion (vertical-motion 0) (current-column))))) + (vertical-motion arg) + (move-to-column (+ (current-column) cur-col)))) + +(defun popup-test-helper-rectangle-match (str) + (let ((buffer-contents (popup-test-helper-buffer-contents))) + (with-temp-buffer + (insert buffer-contents) + (goto-char (point-min)) + (let ((strings (split-string str "\n"))) + (when (search-forward (car strings) nil t) + (goto-char (match-beginning 0)) + (cl-every + 'identity + (mapcar + (lambda (elem) + (popup-test-helper-line-move-visual 1) + (looking-at (regexp-quote elem))) + (cdr strings)))))))) + +(defun popup-test-helper-buffer-contents () + (cl-loop with start = (point-min) + with contents + for overlay in (cl-sort (overlays-in (point-min) (point-max)) + '< :key 'overlay-start) + for overlay-start = (overlay-start overlay) + for overlay-end = (overlay-end overlay) + for prefix = (buffer-substring start overlay-start) + for befstr = (overlay-get overlay 'before-string) + for substr = (or (overlay-get overlay 'display) + (buffer-substring overlay-start overlay-end)) + for aftstr = (overlay-get overlay 'after-string) + collect prefix into contents + unless (overlay-get overlay 'invisible) collect + (concat befstr substr aftstr) into contents + do (setq start overlay-end) + finally (return (concat (apply 'concat contents) + (buffer-substring start (point-max)))) + )) + +(defun popup-test-helper-create-popup (str) + (setq popup (popup-create (point) 10 10)) + (popup-set-list popup (split-string str "\n")) + (popup-draw popup)) + +(defun popup-test-helper-in-popup-p () + (let* ((faces (get-text-property (point) 'face)) + (faces (if (listp faces) faces (list faces)))) + (or (memq 'popup-tip-face faces) + (memq 'popup-menu-face faces) + (memq 'popup-menu-selection-face faces) + (memq 'popup-face faces)))) + +(defun popup-test-helper-popup-selected-item (str) + (let ((buffer-contents (popup-test-helper-buffer-contents))) + (with-temp-buffer + (insert buffer-contents) + (goto-char (point-min)) + (goto-char + (text-property-any (point-min) (point-max) + 'face 'popup-menu-selection-face)) + (looking-at str) + ))) + +(defun popup-test-helper-popup-beginning-line () + (let ((buffer-contents (popup-test-helper-buffer-contents))) + (with-temp-buffer + (insert buffer-contents) + (goto-char (point-min)) + (let ((end (point))) + (while (and (not (eobp)) + (not (popup-test-helper-in-popup-p))) + (goto-char (or (next-single-property-change (point) 'face) + (point-max)))) + (if (popup-test-helper-in-popup-p) + ;; todo visual line + (line-number-at-pos (point)) nil) + )))) + +(defun popup-test-helper-popup-beginning-column () + (let ((buffer-contents (popup-test-helper-buffer-contents))) + (with-temp-buffer + (insert buffer-contents) + (goto-char (point-min)) + (let ((end (point))) + (while (and (not (eobp)) + (not (popup-test-helper-in-popup-p))) + (goto-char (or (next-single-property-change (point) 'face) + (point-max)))) + (if (popup-test-helper-in-popup-p) + (current-column) nil) + )))) + +(defun popup-test-helper-popup-end-line () + (let ((buffer-contents (popup-test-helper-buffer-contents))) + (with-temp-buffer + (insert buffer-contents) + (goto-char (point-max)) + (let ((end (point))) + (while (and (not (bobp)) + (not (popup-test-helper-in-popup-p))) + (setq end (point)) + (goto-char (or (previous-single-property-change (point) 'face) + (point-min)))) + (if (popup-test-helper-in-popup-p) + ;; todo visual line + (line-number-at-pos end) nil) + )))) + +(defun popup-test-helper-popup-end-column () + (let ((buffer-contents (popup-test-helper-buffer-contents))) + (with-temp-buffer + (insert buffer-contents) + (goto-char (point-max)) + (let ((end (point))) + (while (and (not (bobp)) + (not (popup-test-helper-in-popup-p))) + (setq end (point)) + (goto-char (or (previous-single-property-change (point) 'face) + (point-min)))) + (when (popup-test-helper-in-popup-p) + (goto-char end) + (current-column)) + )))) + +(defun popup-test-helper-debug () + (let ((buffer-contents (popup-test-helper-buffer-contents))) + (with-current-buffer (get-buffer-create "*dump*") + (erase-buffer) + (insert buffer-contents) + (buffer-string) + ))) +;; Test for helper method +(ert-deftest popup-test-no-truncated () + (popup-test-with-common-setup + (insert (make-string (- (window-width) 4) ? )) (insert "Foo\n") + (insert (make-string (- (window-width) 4) ? )) (insert "Bar\n") + (insert (make-string (- (window-width) 4) ? )) (insert "Baz\n") + (should (eq t (popup-test-helper-rectangle-match "\ +Foo +Bar +Baz"))) + )) + +(ert-deftest popup-test-truncated () + (popup-test-with-common-setup + (insert (make-string (- (window-width) 2) ? )) (insert "Foo\n") + (insert (make-string (- (window-width) 2) ? )) (insert "Bar\n") + (insert (make-string (- (window-width) 2) ? )) (insert "Baz\n") + (should (eq nil (popup-test-helper-rectangle-match "\ +Foo +Bar +Baz"))) + )) + +(ert-deftest popup-test-misaligned () + (popup-test-with-common-setup + (progn + (insert (make-string (- (window-width) 5) ? )) (insert "Foo\n") + (insert (make-string (- (window-width) 4) ? )) (insert "Bar\n") + (insert (make-string (- (window-width) 3) ? )) (insert "Baz\n")) + (should (eq nil (popup-test-helper-rectangle-match "\ +Foo +Bar +Baz"))) + )) +;; Test for popup-el +(ert-deftest popup-test-simple () + (popup-test-with-common-setup + (popup-test-helper-create-popup "\ +foo +bar +baz") + (should (popup-test-helper-rectangle-match "\ +foo +bar +baz")) + (should (eq (popup-test-helper-popup-beginning-column) 0)))) + +(ert-deftest popup-test-delete () + (popup-test-with-common-setup + (popup-test-helper-create-popup "\ +foo +bar +baz") + (popup-delete popup) + (should-not (popup-test-helper-rectangle-match "\ +foo +bar +baz")) + )) + +(ert-deftest popup-test-hide () + (popup-test-with-common-setup + (popup-test-helper-create-popup "\ +foo +bar +baz") + (popup-hide popup) + (should-not (popup-test-helper-rectangle-match "\ +foo +bar +baz")) + )) + +(ert-deftest popup-test-at-colum1 () + (popup-test-with-common-setup + (insert " ") + (popup-test-helper-create-popup "\ +foo +bar +baz") + (should (popup-test-helper-rectangle-match "\ +foo +bar +baz")) + (should (eq (popup-test-helper-popup-beginning-column) 1)) + )) + +(ert-deftest popup-test-tip () + (popup-test-with-common-setup + (popup-tip "\ +Start isearch on POPUP. This function is synchronized, meaning +event loop waits for quiting of isearch. + +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." + :nowait t) + (should (popup-test-helper-rectangle-match "\ +KEYMAP is a keymap which is used when processing events during +event loop. The default value is `popup-isearch-keymap'.")) + )) + +(ert-deftest popup-test-folding-long-line-right-top () + (popup-test-with-common-setup + ;; To use window-width because Emacs 23 does not have window-body-width + (insert (make-string (- (window-width) 3) ? )) + (popup-tip "long long long long line" :nowait t) + (should (popup-test-helper-rectangle-match "long long long long line")) + (should (eq (popup-test-helper-popup-beginning-line) + 2)) + (should (eq (popup-test-helper-popup-end-line) 2)) + )) + +(ert-deftest popup-test-folding-long-line-left-bottom () + (popup-test-with-common-setup + (insert (make-string (- (window-body-height) 1) ?\n)) + (popup-tip "long long long long line" :nowait t) + (should (popup-test-helper-rectangle-match "long long long long line")) + (should (eq (popup-test-helper-popup-beginning-line) + (- (window-body-height) 1))) + (should (eq (popup-test-helper-popup-end-line) (- (window-body-height) 1))) + )) + +(ert-deftest popup-test-folding-long-line-right-bottom () + (popup-test-with-common-setup + (insert (make-string (- (window-body-height) 1) ?\n)) + (insert (make-string (- (window-width) 3) ? )) + (popup-tip "long long long long line" :nowait t) + (should (popup-test-helper-rectangle-match "long long long long line")) + (should (eq (popup-test-helper-popup-beginning-line) + (- (window-body-height) 1))) + (should (eq (popup-test-helper-popup-end-line) (- (window-body-height) 1))) + )) + +(ert-deftest popup-test-folding-short-line-right-top () + (popup-test-with-common-setup + (insert (make-string (- (window-width) 4) ? )) + (popup-tip "\ +bla +bla +bla +bla +bla" :nowait t) + (should (popup-test-helper-rectangle-match "\ +bla +bla +bla +bla +bla")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + )) + +(ert-deftest popup-test-folding-short-line-left-bottom () + (popup-test-with-common-setup + (insert (make-string (- (window-body-height) 1) ?\n)) + (popup-tip "\ +bla +bla +bla +bla +bla" :nowait t) + (should (popup-test-helper-rectangle-match "\ +bla +bla +bla +bla +bla")) + (should (eq (popup-test-helper-popup-end-line) (- (window-body-height) 1))))) + +(ert-deftest popup-test-folding-short-line-right-bottom () + (popup-test-with-common-setup + (insert (make-string (- (window-body-height) 1) ?\n)) + (insert (make-string (- (window-width) 4) ? )) + (popup-tip "\ +bla +bla +bla +bla +bla" :nowait t) + (should (popup-test-helper-rectangle-match "\ +bla +bla +bla +bla +bla")) + (should (eq (popup-test-helper-popup-end-line) (- (window-body-height) 1))) + )) + +(ert-deftest popup-test-margin-at-column1 () + (popup-test-with-common-setup + (insert " ") + (popup-tip "Margin?" :nowait t :margin t) + (should (eq (popup-test-helper-popup-beginning-column) + 0)) + (should (popup-test-helper-rectangle-match " Margin? ")) + )) + +(ert-deftest popup-test-margin-left () + (popup-test-with-common-setup + (popup-tip "Margin?" :nowait t :margin t) + (should (eq (popup-test-helper-popup-beginning-column) + 0)) + ;; Pending: #19 + ;; (should (popup-test-helper-rectangle-match " Margin? ")) + )) + +(ert-deftest popup-test-margin-right () + (popup-test-with-common-setup + (insert (make-string (- (window-width) 1) ? )) + (popup-tip "Margin?" :nowait t :margin t) + (should (popup-test-helper-rectangle-match " Margin? ")) + ;; Pending: #19 + ;; (should (< (popup-test-helper-popup-end-column) (window-width))) + )) + +(ert-deftest popup-test-height-limit () + (popup-test-with-common-setup + (popup-tip "\ +Foo +Bar +Baz" :nowait t :height 2) + (should (popup-test-helper-rectangle-match "\ +Foo +Bar")) + (should-not (popup-test-helper-rectangle-match "Baz")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + (should (eq (popup-test-helper-popup-end-line) 3)) + )) + +(ert-deftest popup-test-height-limit-bottom () + (popup-test-with-common-setup + (insert (make-string (- (window-body-height) 1) ?\n)) + (popup-tip "\ +Foo +Bar +Baz" :nowait t :height 2) + (should (popup-test-helper-rectangle-match "\ +Foo +Bar")) + (should-not (popup-test-helper-rectangle-match "Baz")) + (should (eq (popup-test-helper-popup-end-line) (- (window-body-height) 1))) + )) + +(ert-deftest popup-test-scroll-bar () + (popup-test-with-common-setup + (let ((popup-scroll-bar-foreground-char + (propertize "f" 'face 'popup-scroll-bar-foreground-face)) + (popup-scroll-bar-background-char + (propertize "b" 'face 'popup-scroll-bar-background-face))) + (popup-tip "\ +Foo +Bar +Baz +Fez +Oz" + :nowait t :height 3 :scroll-bar t :margin t) + (should (popup-test-helper-rectangle-match "\ +Foo f +Bar b +Baz b")) + (should-not (popup-test-helper-rectangle-match "Fez")) + (should-not (popup-test-helper-rectangle-match "Oz")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + (should (eq (popup-test-helper-popup-end-line) 4)) + ))) + +(ert-deftest popup-test-scroll-bar-right-no-margin () + (popup-test-with-common-setup + (insert (make-string (- (window-width) 1) ? )) + (let ((popup-scroll-bar-foreground-char + (propertize "f" 'face 'popup-scroll-bar-foreground-face)) + (popup-scroll-bar-background-char + (propertize "b" 'face 'popup-scroll-bar-background-face))) + (popup-tip "\ +Foo +Bar +Baz +Fez +Oz" + :nowait t :height 3 :scroll-bar t) + (should (popup-test-helper-rectangle-match "\ +Foof +Barb +Bazb")) + (should-not (popup-test-helper-rectangle-match "Fez")) + (should-not (popup-test-helper-rectangle-match "Oz")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + (should (eq (popup-test-helper-popup-end-line) 4)) + ))) + +(ert-deftest popup-test-scroll-bar-right-margin () + (popup-test-with-common-setup + (insert (make-string (- (window-width) 1) ? )) + (let ((popup-scroll-bar-foreground-char + (propertize "f" 'face 'popup-scroll-bar-foreground-face)) + (popup-scroll-bar-background-char + (propertize "b" 'face 'popup-scroll-bar-background-face))) + (popup-tip "\ +Foo +Bar +Baz +Fez +Oz" + :nowait t :height 3 :scroll-bar t :margin t) + (should-not (popup-test-helper-rectangle-match "Fez")) + (should-not (popup-test-helper-rectangle-match "Oz")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + (should (eq (popup-test-helper-popup-end-line) 4)) + ;; Pending: #21 + ;; (should (popup-test-helper-rectangle-match "\ + ;; Foof + ;; Barb + ;; Bazb")) + ))) + +(ert-deftest popup-test-min-height () + (popup-test-with-common-setup + (insert (make-string (- (window-width) 1) ? )) + (popup-tip "Hello" :nowait t :min-height 10) + (should (popup-test-helper-rectangle-match "Hello")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + (should (eq (popup-test-helper-popup-end-line) 11)) + )) + +(ert-deftest popup-test-menu () + (popup-test-with-common-setup + (popup-menu* '("Foo" "Bar" "Baz") :nowait t) + (should (popup-test-helper-rectangle-match "\ +Foo +Bar +Baz")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + )) + +(ert-deftest popup-test-cascade-menu () + (popup-test-with-common-setup + (popup-cascade-menu + '(("Foo" "Foo1" "Foo2") "Bar" "Baz") :nowait t) + (should (popup-test-helper-rectangle-match "Foo >")) + (should (popup-test-helper-rectangle-match "\ +Foo +Bar +Baz")) + (should-not (popup-test-helper-rectangle-match "Foo1")) + (should-not (popup-test-helper-rectangle-match "Foo2")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + )) + +(ert-deftest popup-test-next () + (popup-test-with-common-setup + (setq popup (popup-menu* '("Foo" "Bar" "Baz") :nowait t)) + (should (popup-test-helper-popup-selected-item "Foo")) + (popup-next popup) + (should (popup-test-helper-popup-selected-item "Bar")) + (popup-next popup) + (should (popup-test-helper-popup-selected-item "Baz")) + (popup-next popup) + (should (popup-test-helper-popup-selected-item "Foo")) + (should (popup-test-helper-rectangle-match "Foo\nBar\nBaz")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + )) + +(ert-deftest popup-test-previous () + (popup-test-with-common-setup + (setq popup (popup-menu* '("Foo" "Bar" "Baz") :nowait t)) + (should (popup-test-helper-popup-selected-item "Foo")) + (popup-previous popup) + (should (popup-test-helper-popup-selected-item "Baz")) + (popup-previous popup) + (should (popup-test-helper-popup-selected-item "Bar")) + (popup-previous popup) + (should (popup-test-helper-popup-selected-item "Foo")) + (should (popup-test-helper-rectangle-match "\ +Foo +Bar +Baz")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + )) + +(ert-deftest popup-test-select () + (popup-test-with-common-setup + (setq popup (popup-menu* '("Foo" "Bar" "Baz") :nowait t)) + (should (popup-test-helper-popup-selected-item "Foo")) + (popup-select popup 1) + (should (popup-test-helper-popup-selected-item "Bar")) + (popup-select popup 0) + (should (popup-test-helper-popup-selected-item "Foo")) + (popup-select popup 2) + (should (popup-test-helper-popup-selected-item "Baz")) + (should (popup-test-helper-rectangle-match "\ +Foo +Bar +Baz")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + )) + +(ert-deftest popup-test-scroll-down () + (popup-test-with-common-setup + (setq popup + (popup-cascade-menu (cl-loop for x to 100 collect (format "Foo%d" x)) + :nowait t :height 10 :margin t :scroll-bar t)) + (should (popup-test-helper-rectangle-match "\ +Foo0 +Foo1 +Foo2")) + (should (popup-test-helper-popup-selected-item "Foo0")) + (popup-scroll-down popup 10) + (should (popup-test-helper-popup-selected-item "Foo10")) + (popup-scroll-down popup 10) + (should (popup-test-helper-popup-selected-item "Foo20")) + (popup-scroll-down popup 100) + (should-not (popup-test-helper-rectangle-match "Foo90")) + (should (popup-test-helper-rectangle-match "Foo91")) + (should (popup-test-helper-rectangle-match "Foo100")) + (should-not (popup-test-helper-rectangle-match "Foo0")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + )) + +(ert-deftest popup-test-scroll-up () + (popup-test-with-common-setup + (setq popup + (popup-cascade-menu (cl-loop for x to 100 collect (format "Foo%d" x)) + :nowait t :height 10 :margin t :scroll-bar t)) + (should (popup-test-helper-rectangle-match "\ +Foo0 +Foo1 +Foo2")) + (should (popup-test-helper-popup-selected-item "Foo0")) + (popup-scroll-down popup 100) + (should (popup-test-helper-popup-selected-item "Foo91")) + (popup-scroll-up popup 10) + (should (popup-test-helper-popup-selected-item "Foo81")) + (popup-scroll-up popup 10) + (should-not (popup-test-helper-rectangle-match "Foo70")) + (should (popup-test-helper-rectangle-match "Foo71")) + (should (popup-test-helper-rectangle-match "Foo80")) + (should-not (popup-test-helper-rectangle-match "Foo81")) + (should (eq (popup-test-helper-popup-beginning-line) 2)) + )) + +(ert-deftest popup-test-two-tip () + (popup-test-with-common-setup + (popup-tip "\ +Foo +Bar" :nowait t) + (save-excursion (insert "\n")) + (popup-tip "\ +Baz +Qux" :nowait t) + ;; Pending: #20 + ;; (should (popup-test-helper-rectangle-match "\ + ;; Foo + ;; Bar")) + ;; (should (popup-test-helper-rectangle-match "\ + ;; Baz + ;; Qux")) + )) + +(ert-deftest popup-test-initial-index () + (popup-test-with-common-setup + (setq popup (popup-menu* '("Foo" "Bar" "Baz") :initial-index 0 :nowait t)) + (should (popup-test-helper-popup-selected-item "Foo"))) + + (popup-test-with-common-setup + (setq popup (popup-menu* '("Foo" "Bar" "Baz") :initial-index 2 :nowait t)) + (should (popup-test-helper-popup-selected-item "Baz"))) + + (popup-test-with-common-setup + (setq popup (popup-menu* '("Foo" "Bar" "Baz") :initial-index 2 :height 1 :scroll-bar t :nowait t)) + (should (popup-test-helper-popup-selected-item "Baz"))) + + (popup-test-with-common-setup + (setq popup (popup-menu* '("Foo" "Bar" "Baz") :initial-index -1 :nowait t)) + (should (popup-test-helper-popup-selected-item "Foo"))) + + (popup-test-with-common-setup + (setq popup (popup-menu* '("Foo" "Bar" "Baz") :initial-index 100 :nowait t)) + (should (popup-test-helper-popup-selected-item "Baz")))) + +(defun popup-test-helper-input (key) + (push key unread-command-events)) + +(ert-deftest popup-test-isearch () + (popup-test-with-common-setup + (popup-test-helper-create-popup "\ +foo +bar +baz") + (popup-isearch-update popup 'popup-isearch-filter-list "a") + (should (popup-test-helper-rectangle-match "\ +bar +baz")) + (should-not (popup-test-helper-rectangle-match "foo")) + )) diff --git a/tests/run-test.el b/tests/run-test.el new file mode 100644 index 0000000..fce1fe2 --- /dev/null +++ b/tests/run-test.el @@ -0,0 +1,32 @@ +;; Usage: +;; +;; cask exec emacs -Q -l tests/run-test.el # interactive mode +;; cask exec emacs -batch -Q -l tests/run-test.el # batch mode + + +;; Utils +(defun popup-test-join-path (path &rest rest) + "Join a list of PATHS with appropriate separator (such as /). + +\(fn &rest paths)" + (if rest + (concat (file-name-as-directory path) (apply 'popup-test-join-path rest)) + path)) + +(defvar popup-test-dir (file-name-directory load-file-name)) +(defvar popup-root-dir (concat popup-test-dir "..")) + + +;; Setup `load-path' +(mapc (lambda (p) (add-to-list 'load-path p)) + (list popup-test-dir + popup-root-dir)) + +;; Load tests +(load "popup-test") + + +;; Run tests +(if noninteractive + (ert-run-tests-batch-and-exit) + (ert t))