update packages
This commit is contained in:
@@ -0,0 +1,253 @@
|
||||
;;; 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
|
||||
Reference in New Issue
Block a user