Download
(require 'help)
(require 'eldoc)
(global-set-key (kbd "<f1>") 'th-show-help)
(defun th-show-help ()
(interactive)
(let ((handler (intern (concat "th-" (symbol-name major-mode) "-handler"))))
(if (functionp handler)
(let ((help (funcall handler)))
(if (equal help "")
(message "No help available.")
(th-show-tooltip-for-point help)
(message "")))
(message "The current major mode is not supported."))))
(defun th-lisp-interaction-mode-handler ()
(th-emacs-lisp-mode-handler))
(defun th-emacs-lisp-mode-handler ()
(let* ((argument nil)
(symbol (if (and (char-after)
(or (eq (char-syntax (char-after)) ?w)
(eq (char-syntax (char-after)) ?_)))
(intern-soft (current-word))
(or (let ((func (eldoc-fnsym-in-current-sexp)))
(when func
(setq argument t)
func))
(intern-soft (current-word)))))
(help ""))
(if (boundp symbol)
(setq help (th-elisp-get-help-text 'describe-variable symbol)))
(when (functionp symbol)
(let ((funhelp (th-elisp-get-help-text 'describe-function symbol)))
(unless (equal funhelp "")
(if argument
(setq funhelp (th-elisp-highlight-current-function-arg funhelp)))
(unless (equal help "")
(setq help (concat help "\n\n------------------------------\n\n")))
(setq help (concat help funhelp)))))
help))
(defun th-elisp-get-help-text (func symbol)
(let ((pop-up-frames nil)
(wincfg (current-window-configuration)))
(if (get-buffer "*Help*")
(kill-buffer "*Help*"))
(funcall func symbol)
(if (get-buffer "*Help*")
(progn
(set-window-configuration wincfg)
(with-current-buffer "*Help*" (buffer-string)))
"")))
(defun th-elisp-highlight-current-function-arg (doc)
(let ((lines (split-string doc "\n")))
(if (> (length lines) 1)
(let ((first (pop lines))
(second (pop lines)))
(concat first "\n"
(eldoc-highlight-nth-arg
second (eldoc-get-arg-index)) "\n"
(mapconcat 'identity lines "\n")))
doc)))
(defun eldoc-get-arg-index ()
(save-excursion
(let ((fn (eldoc-fnsym-in-current-sexp))
(i 0))
(unless (memq (char-syntax (char-before)) '(32 39))
(condition-case err
(backward-sexp)
(error 1)))
(condition-case err
(while (not (equal fn (eldoc-current-symbol)))
(setq i (1+ i))
(backward-sexp))
(error 1))
(max 0 i))))
(defun eldoc-highlight-nth-arg (doc n)
(cond ((null doc) "")
((<= n 0) doc)
(t
(let ((i 0))
(mapconcat
(lambda (arg)
(if (member arg '("&optional" "&rest"))
arg
(prog2
(if (= i n)
(put-text-property 0 (length arg) 'face 'bold arg))
arg
(setq i (1+ i)))))
(split-string doc) " ")))))
(defvar th-max-tooltip-lines 25
"The maximum number of lines shown in a tooltip.
The tooltip is truncated if necessary.")
(if (eq window-system 'w32)
(defcustom th-titlebar-height 30
"Height of Emacs window titlebar. It mostly depends on your window
manager settings. Correct titlebar height will help tooltip-help to display
popup windows in a proper position."
:type 'integer
:group 'th)
(defconst th-titlebar-height 0
"On Linux the title bar is not the part of the window, so we
don't have to consider its height in calculations."))
(defun th-show-tooltip-for-point (msg &optional x y)
"Show tooltip MSG at point or at X Y if given."
(let ((lines (split-string msg "\n")))
(when (> (length lines)
th-max-tooltip-lines)
(setq lines
(append
(subseq lines
0
(1- th-max-tooltip-lines))
(list
(concat "(Further lines not shown "
"due to line number limit.)"))))
(setq msg (mapconcat (lambda (x) x)
lines "\n")))
(th-show-tooltip-for-point-gnuemacs msg lines x y)))
(defun th-show-tooltip-for-point-gnuemacs (msg lines &optional x y)
"Show tooltip MSG at point or at X Y if given.
LINES is the same as MSG split into individual lines."
(let* ((tooltip-width (* (frame-char-width)
(apply 'max (mapcar 'length lines))))
(tooltip-height (* (frame-char-height) (min (length lines)
(cdr x-max-tooltip-size))))
(position (th-calculate-popup-position tooltip-width
tooltip-height
'above
x y))
(tooltip-hide-delay 600)
(tooltip-frame-parameters (append `((left . ,(car position))
(top . ,(cdr position)))
tooltip-frame-parameters))
(old-propertize (symbol-function 'propertize)))
(fset 'propertize (lambda (string &rest properties)
string))
(unwind-protect
(tooltip-show msg)
(fset 'propertize old-propertize))))
(defun th-calculate-popup-position (width height preferred-pos &optional x y)
"Calculate pixel position of a rectangle with size WIDTH*HEIGHT at
X;Y or point if they are not given and return a list (X . Y) containing
the calculated position.
Ensure the rectangle does not cover the position.
PREFERRED-POS can either be the symbol `above' or `below' indicating the
preferred position of the popup relative to point."
(if (and x
(> x (frame-width)))
(setq x (frame-width)))
(let* ((fx (frame-parameter nil 'left))
(fy (frame-parameter nil 'top))
(fw (frame-pixel-width))
(fh (frame-pixel-height))
(frame-left (if (not (consp fx))
fx
(if (eq (car fx) '-)
(- (x-display-pixel-width) (car (cdr fx)) fw)
(car (cdr fx)))))
(frame-top (if (not (consp fy))
fy
(if (eq (car fy) '-)
(- (x-display-pixel-height) (car (cdr fy)) fh)
(car (cdr fy)))))
(point-x (car (if x
(th-get-pixel-position x y)
(get-point-pixel-position))))
(point-y (cdr (if y
(th-get-pixel-position x y)
(get-point-pixel-position))))
(corner-x (let ((x (+ point-x
frame-left
(* 2 (frame-char-width)))))
(if (< (+ x width)
(display-pixel-width))
x
(- (display-pixel-width) width))))
(real-y-offset (+ point-y
frame-top
th-titlebar-height
(let ((n-lines (frame-parameter nil 'menu-bar-lines)))
(* n-lines (frame-char-height)))))
(y-above (- real-y-offset
(+ height
(* 2 (frame-char-height)))))
(y-below (+ real-y-offset
(frame-char-height)))
(corner-y (if (eq preferred-pos 'above)
y-above
y-below)))
(if (< corner-y 0)
(setq corner-y y-below))
(if (> (+ corner-y height)
(display-pixel-height))
(setq corner-y y-above))
(cons corner-x corner-y)))
(eval-and-compile
(if (fboundp 'window-inside-edges)
(defalias 'th-window-edges
'window-inside-edges)
(defalias 'th-window-edges
'window-edges)
))
(defun th-point-position ()
"Return the location of POINT as positioned on the selected frame.
Return a cons cell (X . Y)"
(let* ((w (selected-window))
(f (selected-frame))
(edges (th-window-edges w))
(col (current-column))
(row (count-lines (window-start w) (point)))
(x (+ (car edges) col))
(y (+ (car (cdr edges)) row)))
(cons x y)))
(defun get-point-pixel-position ()
"Return the position of point in pixels within the frame."
(let ((point-pos (th-point-position)))
(th-get-pixel-position (car point-pos) (cdr point-pos))))
(defun th-get-pixel-position (x y)
"Return the pixel position of location X Y (1-based) within the frame."
(let ((old-mouse-pos (mouse-position)))
(set-mouse-position (selected-frame)
x
(1- y))
(let ((point-x (car (cdr (mouse-pixel-position))))
(point-y (cdr (cdr (mouse-pixel-position)))))
(when (eq window-system 'w32)
(set-mouse-position
(selected-frame)
(cadr old-mouse-pos)
(cddr old-mouse-pos)))
(cons point-x point-y))))
(provide 'tooltip-help)