Remove company-quickhelp and helm-spotify

I didn’t really use them, and they introduced some strange problems.
This commit is contained in:
Gergely Polonkai 2016-10-14 18:54:39 +02:00
parent 0ab774889a
commit e2f9416bde
13 changed files with 0 additions and 1547 deletions

View File

@ -1,31 +0,0 @@
;;; company-quickhelp-autoloads.el --- automatically extracted autoloads
;;
;;; Code:
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
;;;### (autoloads nil "company-quickhelp" "company-quickhelp.el"
;;;;;; (22490 24939 611396 515000))
;;; Generated autoloads from company-quickhelp.el
(defvar company-quickhelp-mode nil "\
Non-nil if Company-Quickhelp mode is enabled.
See the command `company-quickhelp-mode' for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `company-quickhelp-mode'.")
(custom-autoload 'company-quickhelp-mode "company-quickhelp" nil)
(autoload 'company-quickhelp-mode "company-quickhelp" "\
Provides documentation popups for `company-mode' using `pos-tip'.
\(fn &optional ARG)" t nil)
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; End:
;;; company-quickhelp-autoloads.el ends here

View File

@ -1 +0,0 @@
(define-package "company-quickhelp" "20160826.806" "Popup documentation for completion candidates" '((emacs "24.4") (company "0.8.9") (pos-tip "0.4.6")) :url "https://www.github.com/expez/company-quickhelp" :keywords '("company" "popup" "documentation" "quickhelp"))

View File

@ -1,204 +0,0 @@
;;; company-quickhelp.el --- Popup documentation for completion candidates
;; Copyright (C) 2016, Lars Andersen
;; Author: Lars Andersen <expez@expez.com>
;; URL: https://www.github.com/expez/company-quickhelp
;; Package-Version: 20160826.806
;; Keywords: company popup documentation quickhelp
;; Version: 1.4.0
;; Package-Requires: ((emacs "24.4") (company "0.8.9") (pos-tip "0.4.6"))
;; This file is not part of GNU Emacs.
;; 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:
;; When idling on a completion candidate the documentation for the
;; candidate will pop up after `company-quickhelp-idle-delay' seconds.
;;; Usage:
;; put (company-quickhelp-mode 1) in you init.el to activate
;; `company-quickhelp-mode'.
;; You can adjust the time it takes for the documentation to pop up by
;; changing `company-quickhelp-delay'
;;; Code:
(require 'company)
(require 'pos-tip)
(require 'cl-lib)
(defgroup company-quickhelp nil
"Documentation popups for `company-mode'"
:group 'company)
(defcustom company-quickhelp-delay 0.5
"Delay, in seconds, before the quickhelp popup appears.
If set to nil the popup won't automatically appear, but can still
be triggered manually using `company-quickhelp-show'."
:type '(choice (number :tag "Delay in seconds")
(const :tag "Don't popup help automatically" nil))
:group 'company-quickhelp)
(defcustom company-quickhelp-max-lines nil
"When not NIL, limits the number of lines in the popup."
:type '(choice (integer :tag "Max lines to show in popup")
(const :tag "Don't limit the number of lines shown" nil))
:group 'company-quickhelp)
(defvar company-quickhelp--timer nil
"Quickhelp idle timer.")
(defvar company-quickhelp--original-tooltip-width company-tooltip-minimum-width
"The documentation popup breaks inexplicably when we transition
from a large pseudo-tooltip to a small one. We solve this by
overriding `company-tooltip-minimum-width' and save the
original value here so we can restore it.")
(defun company-quickhelp-frontend (command)
"`company-mode' front-end showing documentation in a `pos-tip' popup."
(pcase command
(`post-command (when company-quickhelp-delay
(company-quickhelp--set-timer)))
(`hide
(when company-quickhelp-delay
(company-quickhelp--cancel-timer))
(pos-tip-hide))))
(defun company-quickhelp--doc-and-meta (doc)
;; The company backend can either return a buffer with the doc or a
;; cons containing the doc buffer and a position at which to start
;; reading.
(let ((doc-buffer (if (consp doc) (car doc) doc))
(doc-begin (when (consp doc) (cdr doc))))
(with-current-buffer doc-buffer
(let ((truncated t))
(goto-char (or doc-begin (point-min)))
(if company-quickhelp-max-lines
(forward-line company-quickhelp-max-lines)
(goto-char (point-max)))
(beginning-of-line)
(when (= (line-number-at-pos)
(save-excursion (goto-char (point-max)) (line-number-at-pos)))
(setq truncated nil))
(while (and (not (= (line-number-at-pos) 1))
(or
;; [back] appears at the end of the help elisp help buffer
(looking-at-p "\\[back\\]")
;; [source] cider's help buffer contains a link to source
(looking-at-p "\\[source\\]")
(looking-at-p "^\\s-*$")))
(forward-line -1))
(list :doc (buffer-substring-no-properties (point-min) (point-at-eol))
:truncated truncated)))))
(defun company-quickhelp--completing-read (prompt candidates &rest rest)
"`cider', and probably other libraries, prompt the user to
resolve ambiguous documentation requests. Instead of failing we
just grab the first candidate and press forward."
(car candidates))
(defun company-quickhelp--doc (selected)
(cl-letf (((symbol-function 'completing-read)
#'company-quickhelp--completing-read))
(let* ((doc (company-call-backend 'doc-buffer selected))
(doc-and-meta (when doc
(company-quickhelp--doc-and-meta doc)))
(truncated (plist-get doc-and-meta :truncated))
(doc (plist-get doc-and-meta :doc)))
(unless (string= doc "")
(if truncated
(concat doc "\n\n[...]")
doc)))))
(defun company-quickhelp-manual-begin ()
"Manually trigger the `company-quickhelp' popup for the
currently active `company' completion candidate."
(interactive)
;; This might seem a bit roundabout, but when I attempted to call
;; `company-quickhelp--show' in a more direct manner it triggered a
;; redisplay of company's list of completion candidates which looked
;; quite weird.
(let ((company-quickhelp-delay 0.01))
(company-quickhelp--set-timer)))
(defun company-quickhelp--show ()
(company-quickhelp--ensure-compatibility)
(company-quickhelp--cancel-timer)
(let* ((selected (nth company-selection company-candidates))
(doc (company-quickhelp--doc selected))
(ovl company-pseudo-tooltip-overlay)
(overlay-width (* (frame-char-width)
(if ovl (overlay-get ovl 'company-width) 0)))
(overlay-position (* (frame-char-width)
(- (if ovl (overlay-get ovl 'company-column) 1) 1)))
(x-gtk-use-system-tooltips nil))
(when (and ovl doc)
(with-no-warnings
(pos-tip-show doc nil (overlay-start ovl) nil 300 80 nil
(+ overlay-width overlay-position) 1)))))
(defun company-quickhelp--set-timer ()
(when (null company-quickhelp--timer)
(setq company-quickhelp--timer
(run-with-idle-timer company-quickhelp-delay nil
'company-quickhelp--show))))
(defun company-quickhelp--cancel-timer ()
(when (timerp company-quickhelp--timer)
(cancel-timer company-quickhelp--timer)
(setq company-quickhelp--timer nil)))
(defun company-quickhelp-hide ()
(company-cancel))
(defun company-quickhelp--ensure-compatibility ()
;; Originally this code was in `company-quickhelp-enable' but that
;; caused trouble for --daemon users reported in #16.
(cond
((or (not (fboundp 'x-hide-tip))
(not (fboundp 'x-show-tip)))
(user-error "Company-quickhelp doesn't work on your system.
Most likely this means you're on a mac with an Emacs build using Cocoa instead of X"))
((or (null window-system)
(eq window-system 'pc))
(user-error "Company-quickhelp doesn't work in the terminal"))))
(defun company-quickhelp--enable ()
(add-hook 'focus-out-hook #'company-quickhelp-hide)
(setq company-quickhelp--original-tooltip-width company-tooltip-minimum-width
company-tooltip-minimum-width (max company-tooltip-minimum-width 40))
(add-to-list 'company-frontends 'company-quickhelp-frontend :append))
(defun company-quickhelp--disable ()
(remove-hook 'focus-out-hook #'company-quickhelp-hide)
(company-quickhelp--cancel-timer)
(setq company-tooltip-minimum-width company-quickhelp--original-tooltip-width
company-frontends
(delq 'company-quickhelp-frontend company-frontends)))
;;;###autoload
(define-minor-mode company-quickhelp-mode
"Provides documentation popups for `company-mode' using `pos-tip'."
:global t
(if company-quickhelp-mode
(company-quickhelp--enable)
(company-quickhelp--disable)))
(provide 'company-quickhelp)
;;; company-quickhelp.el ends here

View File

@ -1,24 +0,0 @@
;;; helm-spotify-autoloads.el --- automatically extracted autoloads
;;
;;; Code:
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
;;;### (autoloads nil "helm-spotify" "helm-spotify.el" (22490 28015
;;;;;; 820716 223000))
;;; Generated autoloads from helm-spotify.el
(defvar helm-source-spotify-track-search '((name . "Spotify") (volatile) (delayed) (multiline) (requires-pattern . 2) (candidates-process . helm-spotify-search) (action-transformer . helm-spotify-actions-for-track)))
(autoload 'helm-spotify "helm-spotify" "\
Bring up a Spotify search interface in helm.
\(fn)" t nil)
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; End:
;;; helm-spotify-autoloads.el ends here

View File

@ -1 +0,0 @@
(define-package "helm-spotify" "20160905.1447" "Control Spotify with Helm." '((helm "0.0.0") (multi "2.0.0")) :url "https://github.com/krisajenkins/helm-spotify" :keywords '("helm" "spotify"))

View File

@ -1,132 +0,0 @@
;;; helm-spotify.el --- Control Spotify with Helm.
;; Copyright 2013 Kris Jenkins
;;
;; Author: Kris Jenkins <krisajenkins@gmail.com>
;; Maintainer: Kris Jenkins <krisajenkins@gmail.com>
;; Keywords: helm spotify
;; Package-Version: 20160905.1447
;; URL: https://github.com/krisajenkins/helm-spotify
;; Created: 14th October 2013
;; Version: 0.1.1
;; Package-Requires: ((helm "0.0.0") (multi "2.0.0"))
;;; Commentary:
;;
;; A search & play interface for Spotify.
;;
;; Currently supports OSX, Linux & Windows.
;;
;; (Want support for another platform? There's a guide in the github README.)
;;; Code:
;;; API Reference: https://developer.spotify.com/technologies/web-api/
(require 'url)
(require 'json)
(require 'helm)
(require 'multi)
(defun alist-get (symbols alist)
"Look up the value for the chain of SYMBOLS in ALIST."
(if symbols
(alist-get (cdr symbols)
(assoc (car symbols) alist))
(cdr alist)))
(defmulti spotify-play-href (href)
"Get the Spotify app to play the object with the given HREF."
system-type)
(defmulti-method spotify-play-href 'darwin
(href)
(shell-command (format "osascript -e 'tell application %S to play track %S'"
"Spotify"
href)))
(defmulti-method spotify-play-href 'gnu/linux
(href)
(shell-command "dbus-send --print-reply --session --type=method_call --dest=org.mpris.MediaPlayer2.spotify /org/mpris/MediaPlayer2 org.mpris.MediaPlayer2.Player.Pause")
(shell-command (format "dbus-send --session --type=method_call --dest=org.mpris.MediaPlayer2.spotify /org/mpris/MediaPlayer2 org.mpris.MediaPlayer2.Player.OpenUri \"string:%s\""
href)))
(defmulti-method spotify-play-href 'windows-nt
(href)
(shell-command (format "explorer %S" href)))
(defmulti-method-fallback spotify-play-href
(href)
(message "Sorry, helm-spotify does not support playing tracks on %S." system-type))
(defun spotify-play-track (track)
"Get the Spotify app to play the TRACK."
(spotify-play-href (alist-get '(uri) track)))
(defun spotify-get-track (album-href)
(let ((response (with-current-buffer
(url-retrieve-synchronously album-href)
(goto-char url-http-end-of-headers)
(json-read))))
(aref (alist-get '(tracks items) response) 0)))
(defun spotify-play-album (track)
"Get the Spotify app to play the album for this TRACK."
(let ((first-track (spotify-get-track (alist-get '(album href) track))))
(spotify-play-href (alist-get '(uri) first-track))))
(defun spotify-search (search-term)
"Search spotify for SEARCH-TERM, returning the results as a Lisp structure."
(let ((a-url (format "https://api.spotify.com/v1/search?q=%s&type=track" search-term)))
(with-current-buffer
(url-retrieve-synchronously a-url)
(goto-char url-http-end-of-headers)
(json-read))))
(defun spotify-format-track (track)
"Given a TRACK, return a a formatted string suitable for display."
(let ((track-name (alist-get '(name) track))
(track-length (/ (alist-get '(duration_ms) track) 1000))
(album-name (alist-get '(album name) track))
(artist-names (mapcar (lambda (artist)
(alist-get '(name) artist))
(alist-get '(artists) track))))
(format "%s (%dm%0.2ds)\n%s - %s"
track-name
(/ track-length 60) (mod track-length 60)
(mapconcat 'identity artist-names "/")
album-name)))
(defun spotify-search-formatted (search-term)
(mapcar (lambda (track)
(cons (spotify-format-track track) track))
(alist-get '(tracks items) (spotify-search search-term))))
(defun helm-spotify-search ()
(spotify-search-formatted helm-pattern))
(defun helm-spotify-actions-for-track (actions track)
"Return a list of helm ACTIONS available for this TRACK."
`((,(format "Play Track - %s" (alist-get '(name) track)) . spotify-play-track)
(,(format "Play Album - %s" (alist-get '(album name) track)) . spotify-play-album)
("Show Track Metadata" . pp)))
;;;###autoload
(defvar helm-source-spotify-track-search
'((name . "Spotify")
(volatile)
(delayed)
(multiline)
(requires-pattern . 2)
(candidates-process . helm-spotify-search)
(action-transformer . helm-spotify-actions-for-track)))
;;;###autoload
(defun helm-spotify ()
"Bring up a Spotify search interface in helm."
(interactive)
(helm :sources '(helm-source-spotify-track-search)
:buffer "*helm-spotify*"))
(provide 'helm-spotify)
;;; helm-spotify.el ends here

View File

@ -1,15 +0,0 @@
;;; multi-autoloads.el --- automatically extracted autoloads
;;
;;; Code:
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
;;;### (autoloads nil nil ("multi.el") (22490 28015 535100 796000))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; End:
;;; multi-autoloads.el ends here

View File

@ -1 +0,0 @@
(define-package "multi" "20131013.844" "Clojure-style multi-methods for emacs lisp" '((emacs "24")) :url "http://github.com/kurisuwhyte/emacs-multi" :keywords '("multimethod" "generic" "predicate" "dispatch"))

View File

@ -1,134 +0,0 @@
;;; multi.el --- Clojure-style multi-methods for emacs lisp -*- lexical-binding: t -*-
;; Copyright (c) 2013 Christina Whyte <kurisu.whyte@gmail.com>
;; Version: 2.0.1
;; Package-Version: 20131013.844
;; Package-Requires: ((emacs "24"))
;; Keywords: multimethod generic predicate dispatch
;; Author: Christina Whyte <kurisu.whyte@gmail.com>
;; URL: http://github.com/kurisuwhyte/emacs-multi
;; This file is not part of GNU Emacs.
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;;; Commentary
;; See README.md (or http://github.com/kurisuwhyte/emacs-multi#readme)
;;; Code:
;;;; State ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar multi/-method-branches (make-hash-table)
"A dictionary of dictionaries of branches.
Type: { Symbol { A (A... B) }}
This holds the mappings of names to a mappings of premises to lambdas,
which allows a relatively efficient dispatching O(2) when applying the
multi-method.")
(defvar multi/-method-fallbacks (make-hash-table)
"A dictionary of fallbacks for each multi-method.
Type: { Symbold (A... B) }
This holds mappings of names to fallback method branches, which are
invoked in case none of the premises for the defined branches match.")
;;;; API ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro defmulti (name arguments &optional docstring &rest forms)
"Defines a new multi-method and a dispatch function."
(declare (doc-string 3)
(debug (&define name (&rest arg) [&optional stringp] def-body))
(indent defun))
`(progn
(defun ,name (&rest args)
,(if (stringp docstring) docstring (prog1 nil (push docstring forms)))
(apply (multi/-dispatch-with ',name (lambda ,arguments ,@forms))
args))
(multi/-make-multi-method ',name)))
(defmacro defmulti-method (name premise arguments &rest forms)
"Adds a branch to a previously-defined multi-method."
(declare (debug (&define name sexp (&rest arg) def-body))
(indent defun))
`(multi/-make-multi-method-branch ',name ,premise
(lambda ,arguments ,@forms)))
(defmacro defmulti-method-fallback (name arguments &rest forms)
"Adds a fallback branch to a previously-defined multi-method.
The fallback branch will be applied if none of the premises defined
for the branches in a multi-method match the dispatch value."
`(multi/-make-multi-method-fallback ',name (lambda ,arguments ,@forms)))
(defun multi-remove-method (name premise)
"Removes the branch with the given premise from the multi-method."
(remhash premise (gethash name multi/-method-branches)))
(defun multi-remove-method-fallback (name)
"Removes the defined fallback branch for the multi-method."
(remhash name multi/-method-fallbacks))
;;;; Helper functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun multi/-make-multi-method (name)
(puthash name (make-hash-table :test 'equal)
multi/-method-branches))
(defun multi/-make-multi-method-branch (name premise lambda)
(puthash premise lambda
(gethash name multi/-method-branches)))
(defun multi/-make-multi-method-fallback (name lambda)
(puthash name lambda multi/-method-fallbacks))
(defun multi/-dispatch-with (name f)
(lambda (&rest args)
(let* ((premise (apply f args))
(method (gethash premise (gethash name multi/-method-branches))))
(if method (apply method args)
(apply (gethash name multi/-method-fallbacks) args)))))
;;;; Emacs stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(eval-after-load "lisp-mode"
'(progn
(font-lock-add-keywords 'emacs-lisp-mode
'(("(\\(defmulti\\|defmulti-method\\|defmulti-method-fallback\\)\\(?:\\s-\\)+\\(\\_<.*?\\_>\\)"
(1 font-lock-keyword-face)
(2 font-lock-function-name-face))))))
(provide 'multi)
;;; multi.el ends here

View File

@ -1,15 +0,0 @@
;;; pos-tip-autoloads.el --- automatically extracted autoloads
;;
;;; Code:
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
;;;### (autoloads nil nil ("pos-tip.el") (22297 53347 971569 117000))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; End:
;;; pos-tip-autoloads.el ends here

View File

@ -1 +0,0 @@
(define-package "pos-tip" "20150318.813" "Show tooltip at point" 'nil :keywords '("tooltip"))

View File

@ -1,980 +0,0 @@
;;; pos-tip.el --- Show tooltip at point -*- coding: utf-8 -*-
;; Copyright (C) 2010 S. Irie
;; Author: S. Irie
;; Maintainer: S. Irie
;; Keywords: Tooltip
;; Package-Version: 20150318.813
(defconst pos-tip-version "0.4.6")
;; 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 2, or
;; (at your option) any later version.
;; It 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, write to the Free
;; Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
;; MA 02110-1301 USA
;;; Commentary:
;; The standard library tooltip.el provides the function for displaying
;; a tooltip at mouse position which allows users to easily show it.
;; However, locating tooltip at arbitrary buffer position in window
;; is not easy. This program provides such function to be used by other
;; frontend programs.
;; This program is tested on GNU Emacs 22, 23 under X window system and
;; Emacs 23 for MS-Windows.
;;
;; Installation:
;;
;; First, save this file as pos-tip.el and byte-compile in
;; a directory that is listed in load-path.
;;
;; Put the following in your .emacs file:
;;
;; (require 'pos-tip)
;;
;; To use the full features of this program on MS-Windows,
;; put the additional setting in .emacs file:
;;
;; (pos-tip-w32-max-width-height) ; Maximize frame temporarily
;;
;; or
;;
;; (pos-tip-w32-max-width-height t) ; Keep frame maximized
;;
;; Examples:
;;
;; We can display a tooltip at the current position by the following:
;;
;; (pos-tip-show "foo bar")
;;
;; If you'd like to specify the tooltip color, use an expression as:
;;
;; (pos-tip-show "foo bar" '("white" . "red"))
;;
;; Here, "white" and "red" are the foreground color and background
;; color, respectively.
;;; History:
;; 2013-07-16 P. Kalinowski
;; * Adjusted `pos-tip-show' to correctly set tooltip text foreground
;; color when using custom color themes.
;; * Version 0.4.6
;;
;; 2010-09-27 S. Irie
;; * Simplified implementation of `pos-tip-window-system'
;; * Version 0.4.5
;;
;; 2010-08-20 S. Irie
;; * Changed to use `window-line-height' to calculate tooltip position
;; * Changed `pos-tip-string-width-height' to ignore last empty line
;; * Version 0.4.4
;;
;; 2010-07-25 S. Irie
;; * Bug fix
;; * Version 0.4.3
;;
;; 2010-06-09 S. Irie
;; * Bug fix
;; * Version 0.4.2
;;
;; 2010-06-04 S. Irie
;; * Added support for text-scale-mode
;; * Version 0.4.1
;;
;; 2010-05-04 S. Irie
;; * Added functions:
;; `pos-tip-x-display-width', `pos-tip-x-display-height'
;; `pos-tip-normalize-natnum', `pos-tip-frame-relative-position'
;; * Fixed the supports for multi-displays and multi-frames
;; * Version 0.4.0
;;
;; 2010-04-29 S. Irie
;; * Modified to avoid byte-compile warning
;; * Bug fix
;; * Version 0.3.6
;;
;; 2010-04-29 S. Irie
;; * Renamed argument MAX-HEIGHT of `pos-tip-fill-string' to MAX-ROWS
;; * Modified old FSF address
;; * Version 0.3.5
;;
;; 2010-04-29 S. Irie
;; * Modified `pos-tip-show' to truncate string exceeding display size
;; * Added function `pos-tip-truncate-string'
;; * Added optional argument MAX-ROWS to `pos-tip-split-string'
;; * Added optional argument MAX-HEIGHT to `pos-tip-fill-string'
;; * Version 0.3.4
;;
;; 2010-04-16 S. Irie
;; * Changed `pos-tip-show' not to fill paragraph unless exceeding WIDTH
;; * Version 0.3.3
;;
;; 2010-04-08 S. Irie
;; * Bug fix
;; * Version 0.3.2
;;
;; 2010-03-31 S. Irie
;; * Bug fix
;; * Version 0.3.1
;;
;; 2010-03-30 S. Irie
;; * Added support for MS-Windows
;; * Added option `pos-tip-use-relative-coordinates'
;; * Bug fixes
;; * Version 0.3.0
;;
;; 2010-03-23 S. Irie
;; * Changed argument WORD-WRAP to JUSTIFY
;; * Added optional argument SQUEEZE
;; * Added function `pos-tip-fill-string'
;; * Added option `pos-tip-tab-width' used to expand tab characters
;; * Bug fixes
;; * Version 0.2.0
;;
;; 2010-03-22 S. Irie
;; * Added optional argument WORD-WRAP to `pos-tip-split-string'
;; * Changed `pos-tip-show' to perform word wrap or kinsoku shori
;; * Version 0.1.8
;;
;; 2010-03-20 S. Irie
;; * Added optional argument DY
;; * Bug fix
;; * Modified docstrings
;; * Version 0.1.7
;;
;; 2010-03-18 S. Irie
;; * Added/modifed docstrings
;; * Changed working buffer name to " *xwininfo*"
;; * Version 0.1.6
;;
;; 2010-03-17 S. Irie
;; * Fixed typos in docstrings
;; * Version 0.1.5
;;
;; 2010-03-16 S. Irie
;; * Added support for multi-display environment
;; * Bug fix
;; * Version 0.1.4
;;
;; 2010-03-16 S. Irie
;; * Bug fix
;; * Changed calculation for `x-max-tooltip-size'
;; * Modified docstring
;; * Version 0.1.3
;;
;; 2010-03-11 S. Irie
;; * Modified commentary
;; * Version 0.1.2
;;
;; 2010-03-11 S. Irie
;; * Re-implemented `pos-tip-string-width-height'
;; * Added indicator variable `pos-tip-upperside-p'
;; * Version 0.1.1
;;
;; 2010-03-09 S. Irie
;; * Re-implemented `pos-tip-show' (*incompatibly changed*)
;; - Use frame default font
;; - Automatically calculate tooltip pixel size
;; - Added optional arguments: TIP-COLOR, MAX-WIDTH
;; * Added utility functions:
;; `pos-tip-split-string', `pos-tip-string-width-height'
;; * Bug fixes
;; * Version 0.1.0
;;
;; 2010-03-08 S. Irie
;; * Added optional argument DX
;; * Version 0.0.4
;;
;; 2010-03-08 S. Irie
;; * Bug fix
;; * Version 0.0.3
;;
;; 2010-03-08 S. Irie
;; * Modified to move out mouse pointer
;; * Version 0.0.2
;;
;; 2010-03-07 S. Irie
;; * First release
;; * Version 0.0.1
;; ToDo:
;;; Code:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Settings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgroup pos-tip nil
"Show tooltip at point"
:group 'faces
:prefix "pos-tip-")
(defcustom pos-tip-border-width 1
"Outer border width of pos-tip's tooltip."
:type 'integer
:group 'pos-tip)
(defcustom pos-tip-internal-border-width 2
"Text margin of pos-tip's tooltip."
:type 'integer
:group 'pos-tip)
(defcustom pos-tip-foreground-color nil
"Default foreground color of pos-tip's tooltip.
When `nil', look up the foreground color of the `tooltip' face."
:type '(choice (const :tag "Default" nil)
string)
:group 'pos-tip)
(defcustom pos-tip-background-color nil
"Default background color of pos-tip's tooltip.
When `nil', look up the background color of the `tooltip' face."
:type '(choice (const :tag "Default" nil)
string)
:group 'pos-tip)
(defcustom pos-tip-tab-width nil
"Tab width used for `pos-tip-split-string' and `pos-tip-fill-string'
to expand tab characters. nil means use default value of `tab-width'."
:type '(choice (const :tag "Default" nil)
integer)
:group 'pos-tip)
(defcustom pos-tip-use-relative-coordinates nil
"Non-nil means tooltip location is calculated as a coordinates
relative to the top left corner of frame. In this case the tooltip
will always be displayed within the frame.
Note that this variable is automatically set to non-nil if absolute
coordinates can't be obtained by `pos-tip-compute-pixel-position'."
:type 'boolean
:group 'pos-tip)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pos-tip-window-system (&optional frame)
"The name of the window system that FRAME is displaying through.
The value is a symbol---for instance, 'x' for X windows.
The value is nil if Emacs is using a text-only terminal.
FRAME defaults to the currently selected frame."
(let ((type (framep (or frame (selected-frame)))))
(if type
(and (not (eq type t))
type)
(signal 'wrong-type-argument (list 'framep frame)))))
(defun pos-tip-normalize-natnum (object &optional n)
"Return a Nth power of 2 if OBJECT is a positive integer.
Otherwise return 0. Omitting N means return 1 for a positive integer."
(ash (if (and (natnump object) (> object 0)) 1 0)
(or n 0)))
(defvar pos-tip-saved-frame-coordinates '(0 . 0)
"The latest result of `pos-tip-frame-top-left-coordinates'.")
(defvar pos-tip-frame-offset nil
"The latest result of `pos-tip-calibrate-frame-offset'. This value
is used for non-X graphical environment.")
(defvar pos-tip-frame-offset-array [nil nil nil nil]
"Array of the results of `pos-tip-calibrate-frame-offset'. They are
recorded only when `pos-tip-frame-top-left-coordinates' is called for a
non-X but graphical frame.
The 2nd and 4th elements are the values for frames having a menu bar.
The 3rd and 4th elements are the values for frames having a tool bar.")
(defun pos-tip-frame-top-left-coordinates (&optional frame)
"Return the pixel coordinates of FRAME as a cons cell (LEFT . TOP),
which are relative to top left corner of screen.
Return nil if failing to acquire the coordinates.
If FRAME is omitted, use selected-frame.
Users can also get the frame coordinates by referring the variable
`pos-tip-saved-frame-coordinates' just after calling this function."
(let ((winsys (pos-tip-window-system frame)))
(cond
((null winsys)
(error "text-only frame: %S" frame))
((eq winsys 'x)
(condition-case nil
(with-current-buffer (get-buffer-create " *xwininfo*")
(let ((case-fold-search nil))
(buffer-disable-undo)
(erase-buffer)
(call-process shell-file-name nil t nil shell-command-switch
(format "xwininfo -display %s -id %s"
(frame-parameter frame 'display)
(frame-parameter frame 'window-id)))
(goto-char (point-min))
(search-forward "\n Absolute")
(setq pos-tip-saved-frame-coordinates
(cons (string-to-number (buffer-substring-no-properties
(search-forward "X: ")
(line-end-position)))
(string-to-number (buffer-substring-no-properties
(search-forward "Y: ")
(line-end-position)))))))
(error nil)))
(t
(let* ((index (+ (pos-tip-normalize-natnum
(frame-parameter frame 'menu-bar-lines) 0)
(pos-tip-normalize-natnum
(frame-parameter frame 'tool-bar-lines) 1)))
(offset (or (aref pos-tip-frame-offset-array index)
(aset pos-tip-frame-offset-array index
(pos-tip-calibrate-frame-offset frame)))))
(if offset
(setq pos-tip-saved-frame-coordinates
(cons (+ (eval (frame-parameter frame 'left))
(car offset))
(+ (eval (frame-parameter frame 'top))
(cdr offset))))))))))
(defun pos-tip-frame-relative-position
(frame1 frame2 &optional w32-frame frame-coord1 frame-coord2)
"Return the pixel coordinates of FRAME1 relative to FRAME2
as a cons cell (LEFT . TOP).
W32-FRAME non-nil means both of frames are under `w32' window system.
FRAME-COORD1 and FRAME-COORD2, if given, specify the absolute
coordinates of FRAME1 and FRAME2, respectively, which make the
calculations faster if the frames have different heights of menu bars
and tool bars."
(if (and (eq (pos-tip-normalize-natnum
(frame-parameter frame1 'menu-bar-lines))
(pos-tip-normalize-natnum
(frame-parameter frame2 'menu-bar-lines)))
(or w32-frame
(eq (pos-tip-normalize-natnum
(frame-parameter frame1 'tool-bar-lines))
(pos-tip-normalize-natnum
(frame-parameter frame2 'tool-bar-lines)))))
(cons (- (eval (frame-parameter frame1 'left))
(eval (frame-parameter frame2 'left)))
(- (eval (frame-parameter frame1 'top))
(eval (frame-parameter frame2 'top))))
(unless frame-coord1
(setq frame-coord1 (let (pos-tip-saved-frame-coordinates)
(pos-tip-frame-top-left-coordinates frame1))))
(unless frame-coord2
(setq frame-coord2 (let (pos-tip-saved-frame-coordinates)
(pos-tip-frame-top-left-coordinates frame2))))
(cons (- (car frame-coord1) (car frame-coord2))
(- (cdr frame-coord1) (cdr frame-coord2)))))
(defvar pos-tip-upperside-p nil
"Non-nil indicates the latest result of `pos-tip-compute-pixel-position'
was upper than the location specified by the arguments.")
(defvar pos-tip-w32-saved-max-width-height nil
"Display pixel size effective for showing tooltip in MS-Windows desktop.
This doesn't include the taskbar area, so isn't same as actual display size.")
(defun pos-tip-compute-pixel-position
(&optional pos window pixel-width pixel-height frame-coordinates dx dy)
"Return pixel position of POS in WINDOW like (X . Y), which indicates
the absolute or relative coordinates of bottom left corner of the object.
Omitting POS and WINDOW means use current position and selected window,
respectively.
If PIXEL-WIDTH and PIXEL-HEIGHT are given, this function assumes these
values as the size of small window like tooltip which is located around the
object at POS. These values are used to adjust the location in order that
the tooltip won't disappear by sticking out of the display. By referring
the variable `pos-tip-upperside-p' after calling this function, user can
examine whether the tooltip will be located above the specified position.
If FRAME-COORDINATES is omitted or nil, automatically obtain the absolute
coordinates of the top left corner of frame which WINDOW is on. Here,
`top left corner of frame' represents the origin of `window-pixel-edges'
and its coordinates are essential for calculating the return value as
absolute coordinates. If a cons cell like (LEFT . TOP), specifies the
frame absolute location and makes the calculation slightly faster, but can
be used only when it's clear that frame is in the specified position. Users
can get the latest values of frame coordinates for using in the next call
by referring the variable `pos-tip-saved-frame-coordinates' just after
calling this function. Otherwise, FRAME-COORDINATES `relative' means return
pixel coordinates of the object relative to the top left corner of the frame.
This is the same effect as `pos-tip-use-relative-coordinates' is non-nil.
DX specifies horizontal offset in pixel.
DY specifies vertical offset in pixel. This makes the calculations done
without considering the height of object at POS, so the object might be
hidden by the tooltip."
(let* ((frame (window-frame (or window (selected-window))))
(w32-frame (eq (pos-tip-window-system frame) 'w32))
(relative (or pos-tip-use-relative-coordinates
(eq frame-coordinates 'relative)
(and w32-frame
(null pos-tip-w32-saved-max-width-height))))
(frame-coord (or (and relative '(0 . 0))
frame-coordinates
(pos-tip-frame-top-left-coordinates frame)
(progn
(setq relative t
pos-tip-use-relative-coordinates t)
'(0 . 0))))
(posn (posn-at-point (or pos (window-point window)) window))
(line (cdr (posn-actual-col-row posn)))
(line-height (and line
(or (window-line-height line window)
(and (redisplay t)
(window-line-height line window)))))
(x-y (or (posn-x-y posn)
(let ((geom (pos-visible-in-window-p
(or pos (window-point window)) window t)))
(and geom (cons (car geom) (cadr geom))))
'(0 . 0)))
(x (+ (car frame-coord)
(car (window-inside-pixel-edges window))
(car x-y)
(or dx 0)))
(y0 (+ (cdr frame-coord)
(cadr (window-pixel-edges window))
(or (nth 2 line-height) (cdr x-y))))
(y (+ y0
(or dy
(car line-height)
(with-current-buffer (window-buffer window)
(cond
;; `posn-object-width-height' returns an incorrect value
;; when the header line is displayed (Emacs bug #4426).
((and posn
(null header-line-format))
(cdr (posn-object-width-height posn)))
((and (bound-and-true-p text-scale-mode)
(not (zerop (with-no-warnings
text-scale-mode-amount))))
(round (* (frame-char-height frame)
(with-no-warnings
(expt text-scale-mode-step
text-scale-mode-amount)))))
(t
(frame-char-height frame)))))))
xmax ymax)
(cond
(relative
(setq xmax (frame-pixel-width frame)
ymax (frame-pixel-height frame)))
(w32-frame
(setq xmax (car pos-tip-w32-saved-max-width-height)
ymax (cdr pos-tip-w32-saved-max-width-height)))
(t
(setq xmax (x-display-pixel-width frame)
ymax (x-display-pixel-height frame))))
(setq pos-tip-upperside-p (> (+ y (or pixel-height 0))
ymax))
(cons (max 0 (min x (- xmax (or pixel-width 0))))
(max 0 (if pos-tip-upperside-p
(- (if dy ymax y0) (or pixel-height 0))
y)))))
(defun pos-tip-cancel-timer ()
"Cancel timeout of tooltip."
(mapc (lambda (timer)
(if (eq (aref timer 5) 'x-hide-tip)
(cancel-timer timer)))
timer-list))
(defun pos-tip-avoid-mouse (left right top bottom &optional frame)
"Move out mouse pointer if it is inside region (LEFT RIGHT TOP BOTTOM)
in FRAME. Return new mouse position like (FRAME . (X . Y))."
(unless frame
(setq frame (selected-frame)))
(let* ((mpos (with-selected-window (frame-selected-window frame)
(mouse-pixel-position)))
(mframe (pop mpos))
(mx (car mpos))
(my (cdr mpos)))
(when (and (eq mframe frame)
(numberp mx))
(let* ((large-number (+ (frame-pixel-width frame) (frame-pixel-height frame)))
(dl (if (> left 2)
(1+ (- mx left))
large-number))
(dr (if (< (1+ right) (frame-pixel-width frame))
(- right mx)
large-number))
(dt (if (> top 2)
(1+ (- my top))
large-number))
(db (if (< (1+ bottom) (frame-pixel-height frame))
(- bottom my)
large-number))
(d (min dl dr dt db)))
(when (> d -2)
(cond
((= d dl)
(setq mx (- left 2)))
((= d dr)
(setq mx (1+ right)))
((= d dt)
(setq my (- top 2)))
(t
(setq my (1+ bottom))))
(set-mouse-pixel-position frame mx my)
(sit-for 0.0001))))
(cons mframe (and mpos (cons mx my)))))
(defun pos-tip-compute-foreground-color (tip-color)
"Compute the foreground color to use for tooltip.
TIP-COLOR is a face or a cons cell like (FOREGROUND-COLOR . BACKGROUND-COLOR).
If it is nil, use `pos-tip-foreground-color' or the foreground color of the
`tooltip' face."
(or (and (facep tip-color)
(face-attribute tip-color :foreground))
(car-safe tip-color)
pos-tip-foreground-color
(face-foreground 'tooltip)))
(defun pos-tip-compute-background-color (tip-color)
"Compute the background color to use for tooltip.
TIP-COLOR is a face or a cons cell like (FOREGROUND-COLOR . BACKGROUND-COLOR).
If it is nil, use `pos-tip-background-color' or the background color of the
`tooltip' face."
(or (and (facep tip-color)
(face-attribute tip-color :background))
(cdr-safe tip-color)
pos-tip-background-color
(face-background 'tooltip)))
(defun pos-tip-show-no-propertize
(string &optional tip-color pos window timeout pixel-width pixel-height frame-coordinates dx dy)
"Show STRING in a tooltip at POS in WINDOW.
Analogous to `pos-tip-show' except don't propertize STRING by `pos-tip' face.
PIXEL-WIDTH and PIXEL-HEIGHT specify the size of tooltip, if given. These
are used to adjust the tooltip position in order that it doesn't disappear by
sticking out of the display, and also used to prevent it from vanishing by
overlapping with mouse pointer.
Note that this function itself doesn't calculate tooltip size because the
character width and height specified by faces are unknown. So users should
calculate PIXEL-WIDTH and PIXEL-HEIGHT by using `pos-tip-tooltip-width' and
`pos-tip-tooltip-height', or use `pos-tip-show' instead, which can
automatically calculate tooltip size.
See `pos-tip-show' for details.
Example:
\(defface my-tooltip
'((t
:background \"gray85\"
:foreground \"black\"
:inherit variable-pitch))
\"Face for my tooltip.\")
\(defface my-tooltip-highlight
'((t
:background \"blue\"
:foreground \"white\"
:inherit my-tooltip))
\"Face for my tooltip highlighted.\")
\(let ((str (propertize \" foo \\n bar \\n baz \" 'face 'my-tooltip)))
(put-text-property 6 11 'face 'my-tooltip-highlight str)
(pos-tip-show-no-propertize str 'my-tooltip))"
(unless window
(setq window (selected-window)))
(let* ((frame (window-frame window))
(winsys (pos-tip-window-system frame))
(x-frame (eq winsys 'x))
(w32-frame (eq winsys 'w32))
(relative (or pos-tip-use-relative-coordinates
(eq frame-coordinates 'relative)
(and w32-frame
(null pos-tip-w32-saved-max-width-height))))
(x-y (prog1
(pos-tip-compute-pixel-position pos window
pixel-width pixel-height
frame-coordinates dx dy)
(if pos-tip-use-relative-coordinates
(setq relative t))))
(ax (car x-y))
(ay (cdr x-y))
(rx (if relative ax (- ax (car pos-tip-saved-frame-coordinates))))
(ry (if relative ay (- ay (cdr pos-tip-saved-frame-coordinates))))
(retval (cons rx ry))
(fg (pos-tip-compute-foreground-color tip-color))
(bg (pos-tip-compute-background-color tip-color))
(use-dxdy (or relative
(not x-frame)))
(spacing (frame-parameter frame 'line-spacing))
(border (ash (+ pos-tip-border-width
pos-tip-internal-border-width)
1))
(x-max-tooltip-size
(cons (+ (if x-frame 1 0)
(/ (- (or pixel-width
(cond
(relative
(frame-pixel-width frame))
(w32-frame
(car pos-tip-w32-saved-max-width-height))
(t
(x-display-pixel-width frame))))
border)
(frame-char-width frame)))
(/ (- (or pixel-height
(x-display-pixel-height frame))
border)
(frame-char-height frame))))
(mpos (with-selected-window window (mouse-pixel-position)))
(mframe (car mpos))
default-frame-alist)
(if (or relative
(and use-dxdy
(null (cadr mpos))))
(unless (and (cadr mpos)
(eq mframe frame))
(let* ((edges (window-inside-pixel-edges (cadr (window-list frame))))
(mx (ash (+ (pop edges) (cadr edges)) -1))
(my (ash (+ (pop edges) (cadr edges)) -1)))
(setq mframe frame)
(set-mouse-pixel-position mframe mx my)
(sit-for 0.0001)))
(when (and (cadr mpos)
(not (eq mframe frame)))
(let ((rel-coord (pos-tip-frame-relative-position frame mframe w32-frame
frame-coordinates)))
(setq rx (+ rx (car rel-coord))
ry (+ ry (cdr rel-coord))))))
(and pixel-width pixel-height
(setq mpos (pos-tip-avoid-mouse rx (+ rx pixel-width
(if w32-frame 3 0))
ry (+ ry pixel-height)
mframe)))
(x-show-tip string mframe
`((border-width . ,pos-tip-border-width)
(internal-border-width . ,pos-tip-internal-border-width)
,@(and (not use-dxdy) `((left . ,ax)
(top . ,ay)))
(font . ,(frame-parameter frame 'font))
,@(and spacing `((line-spacing . ,spacing)))
,@(and (stringp fg) `((foreground-color . ,fg)))
,@(and (stringp bg) `((background-color . ,bg))))
(and timeout (> timeout 0) timeout)
(and use-dxdy (- rx (cadr mpos)))
(and use-dxdy (- ry (cddr mpos))))
(if (and timeout (<= timeout 0))
(pos-tip-cancel-timer))
retval))
(defun pos-tip-split-string (string &optional width margin justify squeeze max-rows)
"Split STRING into fixed width strings. Return a list of these strings.
WIDTH specifies the width of filling each paragraph. WIDTH nil means use
the width of currently selected frame. Note that this function doesn't add any
padding characters at the end of each row.
MARGIN, if non-nil, specifies left margin width which is the number of spece
characters to add at the beginning of each row.
The optional fourth argument JUSTIFY specifies which kind of justification
to do: `full', `left', `right', `center', or `none'. A value of t means handle
each paragraph as specified by its text properties. Omitting JUSTIFY means
don't perform justification, word wrap and kinsoku shori (禁則処理).
SQUEEZE nil means leave whitespaces other than line breaks untouched.
MAX-ROWS, if given, specifies maximum number of elements of return value.
The elements exceeding this number are discarded."
(with-temp-buffer
(let* ((tab-width (or pos-tip-tab-width tab-width))
(fill-column (or width (frame-width)))
(left-margin (or margin 0))
(kinsoku-limit 1)
indent-tabs-mode
row rows)
(insert string)
(untabify (point-min) (point-max))
(if justify
(fill-region (point-min) (point-max) justify (not squeeze))
(setq margin (make-string left-margin ?\s)))
(goto-char (point-min))
(while (prog2
(let ((line (buffer-substring
(point) (progn (end-of-line) (point)))))
(if justify
(push line rows)
(while (progn
(setq line (concat margin line)
row (truncate-string-to-width line fill-column))
(push row rows)
(if (not (= (length row) (length line)))
(setq line (substring line (length row))))))))
(< (point) (point-max))
(beginning-of-line 2)))
(nreverse (if max-rows
(last rows max-rows)
rows)))))
(defun pos-tip-fill-string (string &optional width margin justify squeeze max-rows)
"Fill each of the paragraphs in STRING.
WIDTH specifies the width of filling each paragraph. WIDTH nil means use
the width of currently selected frame. Note that this function doesn't add any
padding characters at the end of each row.
MARGIN, if non-nil, specifies left margin width which is the number of spece
characters to add at the beginning of each row.
The optional fourth argument JUSTIFY specifies which kind of justification
to do: `full', `left', `right', `center', or `none'. A value of t means handle
each paragraph as specified by its text properties. Omitting JUSTIFY means
don't perform justification, word wrap and kinsoku shori (禁則処理).
SQUEEZE nil means leave whitespaces other than line breaks untouched.
MAX-ROWS, if given, specifies maximum number of rows. The rows exceeding
this number are discarded."
(if justify
(with-temp-buffer
(let* ((tab-width (or pos-tip-tab-width tab-width))
(fill-column (or width (frame-width)))
(left-margin (or margin 0))
(kinsoku-limit 1)
indent-tabs-mode)
(insert string)
(untabify (point-min) (point-max))
(fill-region (point-min) (point-max) justify (not squeeze))
(if max-rows
(buffer-substring (goto-char (point-min))
(line-end-position max-rows))
(buffer-string))))
(mapconcat 'identity
(pos-tip-split-string string width margin nil nil max-rows)
"\n")))
(defun pos-tip-truncate-string (string width height)
"Truncate each line of STRING to WIDTH and discard lines exceeding HEIGHT."
(with-temp-buffer
(insert string)
(goto-char (point-min))
(let ((nrow 0)
rows)
(while (and (< nrow height)
(prog2
(push (truncate-string-to-width
(buffer-substring (point) (progn (end-of-line) (point)))
width)
rows)
(< (point) (point-max))
(beginning-of-line 2)
(setq nrow (1+ nrow)))))
(mapconcat 'identity (nreverse rows) "\n"))))
(defun pos-tip-string-width-height (string)
"Count columns and rows of STRING. Return a cons cell like (WIDTH . HEIGHT).
The last empty line of STRING is ignored.
Example:
\(pos-tip-string-width-height \"abc\\nあいう\\n123\")
;; => (6 . 3)"
(with-temp-buffer
(insert string)
(goto-char (point-min))
(end-of-line)
(let ((width (current-column))
(height (if (eq (char-before (point-max)) ?\n) 0 1)))
(while (< (point) (point-max))
(end-of-line 2)
(setq width (max (current-column) width)
height (1+ height)))
(cons width height))))
(defun pos-tip-x-display-width (&optional frame)
"Return maximum column number in tooltip which occupies the full width
of display. Omitting FRAME means use display that selected frame is in."
(1+ (/ (x-display-pixel-width frame) (frame-char-width frame))))
(defun pos-tip-x-display-height (&optional frame)
"Return maximum row number in tooltip which occupies the full height
of display. Omitting FRAME means use display that selected frame is in."
(1+ (/ (x-display-pixel-height frame) (frame-char-height frame))))
(defun pos-tip-tooltip-width (width char-width)
"Calculate tooltip pixel width."
(+ (* width char-width)
(ash (+ pos-tip-border-width
pos-tip-internal-border-width)
1)))
(defun pos-tip-tooltip-height (height char-height &optional frame)
"Calculate tooltip pixel height."
(let ((spacing (or (default-value 'line-spacing)
(frame-parameter frame 'line-spacing))))
(+ (* height (+ char-height
(cond
((integerp spacing)
spacing)
((floatp spacing)
(truncate (* (frame-char-height frame)
spacing)))
(t 0))))
(ash (+ pos-tip-border-width
pos-tip-internal-border-width)
1))))
(defun pos-tip-show
(string &optional tip-color pos window timeout width frame-coordinates dx dy)
"Show STRING in a tooltip, which is a small X window, at POS in WINDOW
using frame's default font with TIP-COLOR.
Return pixel position of tooltip relative to top left corner of frame as
a cons cell like (X . Y).
TIP-COLOR is a face or a cons cell like (FOREGROUND-COLOR . BACKGROUND-COLOR)
used to specify *only* foreground-color and background-color of tooltip. If
omitted, use `pos-tip-foreground-color' and `pos-tip-background-color' or the
foreground and background color of the `tooltip' face instead.
Omitting POS and WINDOW means use current position and selected window,
respectively.
Automatically hide the tooltip after TIMEOUT seconds. Omitting TIMEOUT means
use the default timeout of 5 seconds. Non-positive TIMEOUT means don't hide
tooltip automatically.
WIDTH, if non-nil, specifies the width of filling each paragraph.
If FRAME-COORDINATES is omitted or nil, automatically obtain the absolute
coordinates of the top left corner of frame which WINDOW is on. Here,
`top left corner of frame' represents the origin of `window-pixel-edges'
and its coordinates are essential for calculating the absolute coordinates
of the tooltip. If a cons cell like (LEFT . TOP), specifies the frame
absolute location and makes the calculation slightly faster, but can be
used only when it's clear that frame is in the specified position. Users
can get the latest values of frame coordinates for using in the next call
by referring the variable `pos-tip-saved-frame-coordinates' just after
calling this function. Otherwise, FRAME-COORDINATES `relative' means use
the pixel coordinates relative to the top left corner of the frame for
displaying the tooltip. This is the same effect as
`pos-tip-use-relative-coordinates' is non-nil.
DX specifies horizontal offset in pixel.
DY specifies vertical offset in pixel. This makes the calculations done
without considering the height of object at POS, so the object might be
hidden by the tooltip.
See also `pos-tip-show-no-propertize'."
(unless window
(setq window (selected-window)))
(let* ((frame (window-frame window))
(max-width (pos-tip-x-display-width frame))
(max-height (pos-tip-x-display-height frame))
(w-h (pos-tip-string-width-height string))
(fg (pos-tip-compute-foreground-color tip-color))
(bg (pos-tip-compute-background-color tip-color))
(frame-font (find-font (font-spec :name (frame-parameter frame 'font))))
(tip-face-attrs (list :font frame-font :foreground fg :background bg)))
(cond
((and width
(> (car w-h) width))
(setq string (pos-tip-fill-string string width nil 'none nil max-height)
w-h (pos-tip-string-width-height string)))
((or (> (car w-h) max-width)
(> (cdr w-h) max-height))
(setq string (pos-tip-truncate-string string max-width max-height)
w-h (pos-tip-string-width-height string))))
(pos-tip-show-no-propertize
(propertize string 'face tip-face-attrs)
tip-color pos window timeout
(pos-tip-tooltip-width (car w-h) (frame-char-width frame))
(pos-tip-tooltip-height (cdr w-h) (frame-char-height frame) frame)
frame-coordinates dx dy)))
(defalias 'pos-tip-hide 'x-hide-tip
"Hide pos-tip's tooltip.")
(defun pos-tip-calibrate-frame-offset (&optional frame)
"Return coordinates of FRAME orign relative to the top left corner of
the FRAME extent, like (LEFT . TOP). The return value is recorded to
`pos-tip-frame-offset'.
Note that this function does't correctly work for X frame and Emacs 22."
(setq pos-tip-frame-offset nil)
(let* ((window (frame-first-window frame))
(delete-frame-functions
'((lambda (frame)
(if (equal (frame-parameter frame 'name) "tooltip")
(setq pos-tip-frame-offset
(cons (eval (frame-parameter frame 'left))
(eval (frame-parameter frame 'top))))))))
(pos-tip-border-width 0)
(pos-tip-internal-border-width 1)
(rpos (pos-tip-show ""
`(nil . ,(frame-parameter frame 'background-color))
(window-start window) window
nil nil 'relative nil 0)))
(sit-for 0)
(pos-tip-hide)
(and pos-tip-frame-offset
(setq pos-tip-frame-offset
(cons (- (car pos-tip-frame-offset)
(car rpos)
(eval (frame-parameter frame 'left)))
(- (cdr pos-tip-frame-offset)
(cdr rpos)
(eval (frame-parameter frame 'top))))))))
(defun pos-tip-w32-max-width-height (&optional keep-maximize)
"Maximize the currently selected frame temporarily and set
`pos-tip-w32-saved-max-width-height' the effective display size in order
to become possible to calculate the absolute location of tooltip.
KEEP-MAXIMIZE non-nil means leave the frame maximized.
Note that this function is usable only in Emacs 23 for MS-Windows."
(interactive)
(unless (eq window-system 'w32)
(error "`pos-tip-w32-max-width-height' can be used only in w32 frame."))
;; Maximize frame
(with-no-warnings (w32-send-sys-command 61488))
(sit-for 0)
(let ((offset (pos-tip-calibrate-frame-offset)))
(prog1
(setq pos-tip-w32-saved-max-width-height
(cons (frame-pixel-width)
(+ (frame-pixel-height)
(- (cdr offset) (car offset)))))
(if (called-interactively-p 'interactive)
(message "%S" pos-tip-w32-saved-max-width-height))
(unless keep-maximize
;; Restore frame
(with-no-warnings (w32-send-sys-command 61728))))))
(provide 'pos-tip)
;;;
;;; pos-tip.el ends here

View File

@ -57,7 +57,6 @@
command-log-mode
company
company-c-headers
company-quickhelp
company-shell
diminish
drag-stuff
@ -87,7 +86,6 @@
helm-google
helm-gtags
helm-projectile
helm-spotify
helm-swoop
helm-unicode
hyde
@ -407,10 +405,6 @@
(use-package company-c-headers)
(use-package company-quickhelp
:config
(add-hook 'company-mode-hook 'company-quickhelp-mode))
(use-package company-shell)
(use-package electric-case
@ -455,8 +449,6 @@
(use-package helm-google)
(use-package helm-spotify)
(use-package hyde)
(use-package id-manager)