From: Gerd Möllmann Date: Wed, 6 Nov 2024 04:48:46 +0000 (+0100) Subject: Add tty-tip.el, not tooltips, but very close X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=66d8192a06ab50f273d99b04e6ee50c45993e566;p=emacs.git Add tty-tip.el, not tooltips, but very close (cherry picked from commit d27fc61755d8dd4a65db6291f1c83492003b30b1) --- diff --git a/lisp/tty-tip.el b/lisp/tty-tip.el new file mode 100644 index 00000000000..92a115b2008 --- /dev/null +++ b/lisp/tty-tip.el @@ -0,0 +1,196 @@ +;;; -*- lexical-binding: t; symbol-packages: t; -*- +;;; tty-tip.el --- Display help in kind of tooltips on ttys + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; GNU Emacs 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. + +;; GNU Emacs 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 GNU Emacs. If not, see . + +;;; Commentary: + +;; This uses tty child frames to display help which looks and feels much +;; like using tooltips (but they really aren't). + +;; Use `tty-tip-mode' to activate or toggle this feature. +;; +;; You can customize face `tooltip', `tooltip-short-delay', +;; `tooltip-delay', `tooltip-recent-seconds'. + +(require 'tooltip) + +(defvar tty-tip--frame nil) + +(defun tty-tip--make-buffer (text) + (with-current-buffer + (get-buffer-create " *tty-tip*") + ;; Redirect focus to parent. + (add-hook 'pre-command-hook #'tty-tip--delete-frame nil t) + ;; Use an empty keymap. + (use-local-map (make-keymap)) + (dolist (var '((mode-line-format . nil) + (header-line-format . nil) + (tab-line-format . nil) + (tab-bar-format . nil) ;; Emacs 28 tab-bar-format + (frame-title-format . "") + (truncate-lines . t) + (cursor-in-non-selected-windows . nil) + (cursor-type . nil) + (show-trailing-whitespace . nil) + (display-line-numbers . nil) + (left-fringe-width . nil) + (right-fringe-width . nil) + (left-margin-width . 0) + (right-margin-width . 0) + (fringes-outside-margins . 0) + (buffer-read-only . t))) + (set (make-local-variable (car var)) (cdr var))) + (let ((inhibit-modification-hooks t) + (inhibit-read-only t)) + (erase-buffer) + (insert text) + (goto-char (point-min))) + (current-buffer))) + +(defvar tty-tip-frame-parameters + `((visibility . nil) + (background-color . "lightyellow") + (foreground-color . "black") + (width . 0) (height . 0) + (min-width . t) (min-height . t) + (no-accept-focus . t) + (no-focus-on-map . t) + (border-width . 0) + (child-frame-border-width . 1) + (left-fringe . 0) + (right-fringe . 0) + (vertical-scroll-bars . nil) + (horizontal-scroll-bars . nil) + (menu-bar-lines . 0) + (tool-bar-lines . 0) + (tab-bar-lines . 0) + (no-other-frame . t) + (no-other-window . t) + (no-delete-other-windows . t) + (unsplittable . t) + (undecorated . t) + (cursor-type . nil) + (no-special-glyphs . t) + (desktop-dont-save . t))) + +(defun tty-tip--frame-parameters () + (let ((params (copy-sequence tty-tip-frame-parameters)) + (fg (face-attribute 'tooltip :foreground)) + (bg (face-attribute 'tooltip :background))) + (when (stringp fg) + (setf (alist-get 'foreground-color params) fg)) + (when (stringp bg) + (setf (alist-get 'background-color params) bg)) + params)) + +(defun tty-tip--delete-frame () + (when tty-tip--frame + (delete-frame tty-tip--frame) + (setq tty-tip--frame nil) + t)) + +(defun tty-tip--compute-position () + (let* ((pos (mouse-position)) + (mouse-x (car (cdr pos))) + (mouse-y (cdr (cdr pos))) + (x (+ mouse-x 1)) + (y (+ mouse-y 1)) + (tip-width (frame-width tty-tip--frame)) + (tip-height (frame-height tty-tip--frame)) + (tty-width (display-pixel-width)) + (tty-height (display-pixel-height))) + (when (> (+ x tip-width) tty-width) + (setq x (max 0 (- x tip-width 1)))) + (when (> (+ y tip-height) tty-height) + (setq y (max 0 (- y tip-height 1)))) + (cons x y))) + +(defun tty-tip--create-frame (text) + (let* ((minibuffer (minibuffer-window (window-frame))) + (buffer (tty-tip--make-buffer text)) + (window-min-height 1) + (window-min-width 1) + after-make-frame-functions + (text-lines (string-lines text))) + (setq tty-tip--frame + (make-frame + `((parent-frame . ,(car (mouse-position))) + (minibuffer . ,minibuffer) + ,@(tty-tip--frame-parameters)))) + (let ((win (frame-root-window tty-tip--frame))) + (set-window-buffer win buffer) + (set-window-dedicated-p win t) + (set-frame-size tty-tip--frame + (apply #'max (mapcar #'string-width text-lines)) + (length text-lines)) + (let* ((pos (tty-tip--compute-position)) + (x (car pos)) + (y (cdr pos))) + (set-frame-position tty-tip--frame x y)) + (make-frame-visible tty-tip--frame)))) + +(defvar tty-tip--help-message nil) +(defvar tty-tip--hide-time nil) +(defvar tty-tip--timeout-id nil) + +(defun tty-tip--delay () + (if (and tty-tip--hide-time + (time-less-p (time-since tty-tip--hide-time) + tooltip-recent-seconds)) + tooltip-short-delay + tooltip-delay)) + +(defun tty-tip--cancel-delayed-tip () + (when tty-tip--timeout-id + (cancel-timer tty-tip--timeout-id) + (setq tty-tip--timeout-id nil))) + +(defun tty-tip--start-delayed-tip () + (setq tty-tip--timeout-id + (run-with-timer (tty-tip--delay) nil + (lambda () + (tty-tip--create-frame + tty-tip--help-message))))) + +(defun tty-tip--hide (&optional _ignored-arg) + (tty-tip--cancel-delayed-tip) + (when (tty-tip--delete-frame) + (setq tty-tip--hide-time (float-time)))) + +(defun tty-tip--show-help (msg) + (let ((previous-help tty-tip--help-message)) + (setq tty-tip--help-message msg) + (cond ((null msg) + (tty-tip--hide)) + ((equal previous-help msg) + nil) + (t + (tty-tip--hide) + (tty-tip--start-delayed-tip))))) + +;;;###autoload +(define-minor-mode tty-tip-mode + "Global minor mode for displaying help in tty child frames." + :global t :group 'help + (unless (display-graphic-p) + (if tty-tip-mode + (setq show-help-function #'tty-tip--show-help) + (setq show-help-function nil)))) + +(provide 'tty-tip) + +;;; End