254 lines
10 KiB
EmacsLisp
254 lines
10 KiB
EmacsLisp
;;; company-childframe.el --- Graphical popup frontend for Company -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2026 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 <https://www.gnu.org/licenses/>.
|
|
|
|
|
|
;;; Commentary:
|
|
;;
|
|
;; Tooltip completion menu frontend for Company that uses a child frame.
|
|
;;
|
|
;; A lot of the code here was imported from the package `company-posframe',
|
|
;; credit to Clément Pit-Claudel, Feng Shu and others.
|
|
|
|
;;; Code:
|
|
|
|
(require 'company)
|
|
(require 'posframe)
|
|
|
|
(defgroup company-childframe nil
|
|
"Group group group"
|
|
:group 'company)
|
|
|
|
(defcustom company-childframe-font nil
|
|
"The font used by company-childframe's frame.
|
|
Using current frame's font if it is nil."
|
|
:type 'face)
|
|
|
|
(defcustom company-childframe-border-width 1
|
|
"The width of the popup's border, in graphical frames.
|
|
|
|
Users of HiDPI screens might like to set it to 2."
|
|
:type 'integer)
|
|
|
|
(defvar company-childframe-buffer " *company-childframe-buffer*"
|
|
"company-childframe's buffer which used by posframe.")
|
|
|
|
(defvar company-childframe--frame nil)
|
|
|
|
(defvar company-childframe-show-params nil
|
|
"List of extra parameters passed to `posframe-show' in
|
|
`company-childframe-show'.")
|
|
|
|
(defvar company-childframe-last-status nil)
|
|
|
|
(defvar company-childframe-buffer-map
|
|
(let ((keymap (make-sparse-keymap)))
|
|
(set-keymap-parent keymap company-active-map)
|
|
(define-key keymap [wheel-down] 'company-childframe-wheel-up)
|
|
(define-key keymap [wheel-up] 'company-childframe-wheel-down)
|
|
keymap)
|
|
"Keymap for the child frame's popup/buffer.")
|
|
|
|
(defun company-childframe-wheel-up ()
|
|
"Scroll up the displayed candidates."
|
|
(interactive)
|
|
(company-childframe--wheel-scroll 3))
|
|
|
|
(defun company-childframe-wheel-down ()
|
|
"Scroll up the displayed candidates."
|
|
(interactive)
|
|
(company-childframe--wheel-scroll -3))
|
|
|
|
(defun company-childframe--wheel-scroll (amount)
|
|
(let ((parent-frame (frame-parameter nil 'parent-frame))
|
|
(parent-buffer (frame-parameter nil 'posframe-parent-buffer)))
|
|
(when (and parent-frame
|
|
parent-buffer)
|
|
(select-frame parent-frame)
|
|
(select-window (get-buffer-window (cdr parent-buffer)))
|
|
(company-select-next amount))))
|
|
|
|
(defvar company-childframe-poshandler
|
|
#'company-childframe-show-at-prefix
|
|
"Poshandler for the completion dialog.")
|
|
|
|
(defun company-childframe-show-at-prefix (info)
|
|
"Poshandler showing `company-childframe' at `company-prefix'."
|
|
(let* ((parent-window (plist-get info :parent-window))
|
|
(point (- (plist-get info :position)
|
|
(plist-get info :company-prefix-length)))
|
|
(after-string-width
|
|
(with-current-buffer (window-buffer parent-window)
|
|
(thread-last
|
|
(and (= point (point-max))
|
|
(overlays-in point point))
|
|
(mapcar (lambda (o) (company--string-pixel-width
|
|
(overlay-get o 'after-string))))
|
|
(cl-reduce #'+))))
|
|
(posn (posn-at-point point parent-window))
|
|
;; TODO: Strictly speaking, if company-childframe-font is not nil, that
|
|
;; should be used to find the default width...
|
|
(expected-margin-width (* (plist-get info :company-margin) (default-font-width)))
|
|
(xy (posn-x-y posn)))
|
|
(setcar xy (- (car xy) expected-margin-width
|
|
(if (display-graphic-p)
|
|
company-childframe-border-width
|
|
0)
|
|
;; Might bite us if the posn-at-point behavior changes
|
|
;; someday, but the odds seem low.
|
|
after-string-width))
|
|
(posframe-poshandler-point-bottom-left-corner (plist-put info :position posn))))
|
|
|
|
(defun company-childframe-show ()
|
|
"Show company-childframe candidate menu."
|
|
(defvar x-wait-for-event-timeout)
|
|
(defvar x-fast-protocol-requests)
|
|
(let* ((x-wait-for-event-timeout (and (>= emacs-major-version 31)
|
|
;; debbugs#80662
|
|
(bound-and-true-p
|
|
x-wait-for-event-timeout)))
|
|
(before-make-frame-hook)
|
|
(after-make-frame-functions)
|
|
(x-fast-protocol-requests t)
|
|
(height (min company-tooltip-limit
|
|
(if company-search-mode
|
|
(1+ company-candidates-length)
|
|
company-candidates-length)))
|
|
(company-lines (company--create-lines company-selection height))
|
|
(margin (car company-lines))
|
|
(lines (cdr company-lines))
|
|
(width (length (car lines)))
|
|
(contents (mapconcat #'identity lines "\n"))
|
|
(buffer (get-buffer-create company-childframe-buffer)))
|
|
(when (and (eq (frame-live-p company-childframe--frame) 'x)
|
|
(not (eq (car (frame-list)) company-childframe--frame)))
|
|
;; Make sure it's the first in the list, to avoid premature sync when some
|
|
;; other frame is redisplayed first. Again, non-atomic updated on X11.
|
|
;; https://debbugs.gnu.org/80662#185
|
|
(delete-frame company-childframe--frame))
|
|
(apply #'posframe-show buffer
|
|
:string contents
|
|
:height height
|
|
:width (if (or (<= company-candidates-length
|
|
height)
|
|
(not (display-graphic-p)))
|
|
width
|
|
(1- width))
|
|
:font company-childframe-font
|
|
:background-color (face-attribute 'company-tooltip :background)
|
|
:lines-truncate t
|
|
:override-parameters '((inhibit-double-buffering . t))
|
|
:border-width (and (display-graphic-p) company-childframe-border-width)
|
|
;; :border-color "light salmon"
|
|
;; :border-color "light steel blue"
|
|
;; We'll probably want a separate face for it.
|
|
:border-color (face-attribute 'company-tooltip-scrollbar-track :background)
|
|
:poshandler company-childframe-poshandler
|
|
:poshandler-extra-info
|
|
(list :company-margin margin
|
|
:company-prefix-length (length (car (company--boundaries))))
|
|
company-childframe-show-params)
|
|
(with-current-buffer buffer
|
|
(use-local-map company-childframe-buffer-map)
|
|
(setq company-childframe--frame posframe--frame)
|
|
;; FIXME: Does not honor remappings by minor modes in the parent buffer,
|
|
;; e.g. the special behavior of C-d with parent-mode, etc.
|
|
(add-hook 'pre-command-hook
|
|
#'company-childframe--pre-command
|
|
nil t))))
|
|
|
|
(defun company-childframe-hide ()
|
|
"Hide company-childframe candidate menu."
|
|
(when (and (frame-live-p company-childframe--frame)
|
|
(frame-visible-p company-childframe--frame))
|
|
;; PGTK/NS/W32 protocols can update the display atomically.
|
|
(when (and (eq window-system 'x)
|
|
;; https://debbugs.gnu.org/80961
|
|
(< 32 emacs-major-version))
|
|
;; Seems to help avoid the final flicker - probably by keeping the parent's
|
|
;; display matrix up to date (so it can repaint on Expose immediately).
|
|
(redisplay))
|
|
(make-frame-invisible company-childframe--frame)))
|
|
|
|
;;;###autoload
|
|
(defun company-childframe-frontend (command)
|
|
"`company-mode' frontend using childframe.
|
|
For COMMAND refer to `company-frontends'."
|
|
(setq company-childframe-last-status
|
|
(list (selected-window)
|
|
(current-buffer)))
|
|
(cl-case command
|
|
(pre-command
|
|
(when (not (posframe-workable-p))
|
|
(user-error "Child frames not supported")))
|
|
(show (setq company--tooltip-current-width 0))
|
|
(hide
|
|
(company-childframe-hide))
|
|
(post-command
|
|
(when (equal (window-buffer (selected-window))
|
|
(current-buffer))
|
|
(company-childframe-show)))
|
|
(select-mouse
|
|
(company-childframe--select-mouse))))
|
|
|
|
(defun company-childframe--select-mouse ()
|
|
(let ((event-col-row (company--event-col-row company-mouse-event))
|
|
(event-window (posn-window (event-start company-mouse-event))))
|
|
(cond ((and event-window
|
|
(equal (buffer-name (window-buffer event-window))
|
|
company-childframe-buffer))
|
|
(company-set-selection (+ (cdr event-col-row)
|
|
company-tooltip-offset
|
|
(if (and (eq company-tooltip-offset-display 'lines)
|
|
(not (zerop company-tooltip-offset)))
|
|
-1 0)))
|
|
t))))
|
|
|
|
(defun company-childframe--pre-command ()
|
|
(let ((parent-frame (frame-parameter nil 'parent-frame))
|
|
(parent-buffer (cdr (frame-parameter nil 'posframe-parent-buffer))))
|
|
(when (and
|
|
(not (memq this-command
|
|
'(company-childframe-wheel-up
|
|
company-childframe-wheel-down)))
|
|
parent-frame parent-buffer)
|
|
(select-frame parent-frame)
|
|
(select-window (get-buffer-window parent-buffer)))))
|
|
|
|
;;;###autoload
|
|
(defun company-childframe-unless-just-one-frontend (command)
|
|
"`company-childframe-frontend', but not shown for single candidates."
|
|
(if (company--show-inline-p)
|
|
(and (member command '(post-command hide))
|
|
(company-childframe-hide))
|
|
(and (memq command '(post-command show unhide hide select-mouse))
|
|
(company-childframe-frontend command))))
|
|
|
|
(defun company-childframe-window-change ()
|
|
"Hide posframe on window change."
|
|
(when (posframe-workable-p)
|
|
(unless (or (equal (buffer-name) company-childframe-buffer)
|
|
(equal company-childframe-last-status
|
|
(list (selected-window)
|
|
(current-buffer))))
|
|
(company-childframe-hide))))
|
|
|
|
(add-hook 'window-configuration-change-hook
|
|
#'company-childframe-window-change)
|
|
|
|
(provide 'company-childframe)
|
|
;;; company-childframe.el ends here
|