emacs-config/elisp/corfu-terminal-popupinfo.el

;;; corfu-terminal-popupinfo.el --- corfu-popupinfo support in the terminal -*- lexical-binding: t -*-

;;; Commentary:
;; To make use of this file, simply `require' it, and then enable
;; `corfu-terminal-popupinfo-mode', which is a global mode.  Note that
;; `corfu-terminal-mode' MUST be loaded and enabled for this to work.

;;; Code:
(require 'popon)
(require 'corfu-terminal)
(require 'corfu-popupinfo)
(require 'cl-lib)

(defvar ctp--popon nil
  "The current popon, or nil if there is none.")

(defvar ctp--buffer nil
  "The buffer holding the current candidate's documentation.")

(defun ctp--get-buffer ()
  "Create or return `ctp--buffer'."
  (unless (and (bufferp ctp--buffer) (buffer-live-p ctp--buffer))
    (setq ctp--buffer (generate-new-buffer " *corfu-terminal-popupinfo*" t)))
  ctp--buffer)

(defun ctp--visible-p ()
  "Return non-nil if the terminal popup window is visible."
  (popon-live-p ctp--popon))

(defun ctp--corfu-popupinfo--visible-p-advice (oldfun &optional frame)
  "Advice for `corfu-popupinfo--visible-p'.
If FRAME is nil, this will return `ctp--visible-p'.  If
FRAME is `corfu--frame', this will return weather the `corfu-terminal--popon' is
live or not.

As this is :around advice, OLDFUN is the real (advised) function to call."
  (cond
   ((and (not frame) (ctp--visible-p)))
   ((and (eq frame corfu--frame) (popon-live-p corfu-terminal--popon)))
   ((funcall oldfun frame))))

(defun ctp--close ()
  "Close the popon."
  (popon-kill ctp--popon)
  (setq ctp--popon nil))

(defalias 'ctp--corfu-popupinfo--hide-advice 'ctp--close
  "Advice for `corfu-popupinfo--hide' that works in the terminal.")

(defun ctp--load-content (candidate buffer)
  "Load the documentation for CANDIDATE into BUFFER."
  (when-let ((content (funcall corfu-popupinfo--function candidate)))
    ;; A bunch of this comes straight from `corfu-popupinfo--show'
    (with-current-buffer buffer
      (dolist (var corfu-popupinfo--buffer-parameters)
        (set (make-local-variable (car var)) (cdr var)))
      (with-silent-modifications
        (erase-buffer)
        (insert content)
        ;; popon.el requires that each line be of the same width. As we are in
        ;; the terminal, we assume that each character is the same width (and
        ;; we can't do anything, or even know, if this is not the case). Thus,
        ;; we run over the buffer to pad out each line to the width of the
        ;; longest line.
        (goto-char (point-min))
        (let ((wrap-p (and (not truncate-lines) word-wrap))
              (longest-line 0))
          (cl-block nil
            (while (not (eobp))
              (let ((len (- (pos-eol) (pos-bol))))
                (when (> len longest-line)
                  (setq longest-line len))
                (when (and wrap-p (> longest-line corfu-popupinfo-max-width))
                  (setq longest-line corfu-popupinfo-max-width)
                  (cl-return)))
              (forward-line)))
          (setq-local fill-column longest-line)
          (when wrap-p
            (fill-region (point-min) (point-max)))
          (goto-char (point-min))
          (while (not (eobp))
            (end-of-line)
            (let ((len (- (point) (pos-bol))))
              (when (< len longest-line)
                (insert (make-string (- longest-line len) ? ))))
            (forward-line))))
      (goto-char (point-min))
      (put-text-property (point-min) (point-max) 'face 'corfu-popupinfo)
      (when-let ((m (memq 'corfu-default (alist-get 'default face-remapping-alist))))
        (setcar m 'corfu-popupinfo)))
    ;; We succeeded in loading the data
    t))

(defun ctp--popon-position (buffer)
  "Find a good position to open the popon for BUFFER's content.
Return a list of the position, the max line length that can be shown, and the
max height that can be shown.  Each line of BUFFER _MUST_ be the same lenght."
  (when-let ((point-posn (posn-at-point))
             (point-x (car (posn-x-y point-posn)))
             (point-y (cdr (posn-x-y point-posn))))
    (with-current-buffer buffer
      (when-let ((completion-pos (popon-position corfu-terminal--popon))
                 (completion-size (popon-size corfu-terminal--popon))
                 (comp-x (car completion-pos))
                 (comp-y (cdr completion-pos))
                 (comp-w (car completion-size))
                 (comp-h (cdr completion-size))
                 (win-w (window-max-chars-per-line))
                 (win-h (window-body-height))
                 (line-len (- (pos-eol) (pos-bol)))
                 (num-lines (count-lines (point-min) (point-max))))
        (let* ((align 'row)
               (width (min line-len corfu-popupinfo-max-width))
               (pop-x (cond
                       ((<= (+ comp-x comp-w width) win-w)
                        (+ comp-x comp-w))
                       ((>= (- comp-x width) 0)
                        (- comp-x width))
                       ((<= (+ comp-x width) win-w)
                        (setq align 'col)
                        comp-x)
                       ((>= (- win-w width) 0)
                        (setq align 'col)
                        (- win-w width))
                       (t
                        (setq align 'col
                              width win-w)
                        0)))
               (height (min num-lines corfu-popupinfo-max-height))
               (pop-y (cl-case align
                        (row (if (<= (+ comp-y height) win-h)
                                 comp-y
                               (max 0 (- win-h height))))
                        (col (cond
                              ((<= (+ comp-y comp-h height)
                                   (- win-h scroll-margin))
                               (+ comp-y comp-h))
                              ;; If the completion dialog is above the point
                              ((and (< comp-y point-y)
                                    (>= (- comp-y height) 0))
                               (- comp-y height))
                              ;; Emacs seems to hide the current text if this
                              ;; number is 1 (I think it's too close to two
                              ;; overlays)
                              ((>= (- comp-y height 2) 0)
                               (- comp-y height 2))
                              (t (+ comp-y comp-h)))))))
          (list (cons pop-x pop-y) width height))))))

(defun ctp--extract-content (buffer width height)
  "Extract the content from BUFFER for a popon.
The content extracted is for a popon of size WIDTH by HEIGHT."
  (let (start end)
    (with-current-buffer buffer
      ;; we assume that we are scrolled to the start of the region we care about
      (save-excursion
        (let ((rem-lines (count-lines (point) (point-max))))
          (when (< rem-lines height)
            (forward-line (- rem-lines height))))
        (setq start (point)
              end (pos-eol height))))
    (with-temp-buffer
      (insert-buffer-substring buffer start end)
      (goto-char (point-min))
      (cl-loop repeat height
               until (eobp) do
               (let ((len (- (pos-eol) (pos-bol))))
                 (when (> len width)
                   (delete-region (+ (pos-bol) width) (pos-eol))))
               (forward-line))
      ;; "delete" the rest of the lines
      (narrow-to-region (point-min) (point))
      (buffer-string))))

(defun ctp--display-buffer (buffer)
  "Display or redisplay BUFFER in a popon."
  (let ((inhibit-redisplay t))
    (cl-destructuring-bind (&optional pos width height)
        (ctp--popon-position buffer)
      (popon-kill ctp--popon)
      (when-let ((pos)
                 (content (ctp--extract-content buffer width height)))
        (setq ctp--popon
              ;; appear behind the auto-complete window, in case something
              ;; happens
              (popon-create content pos nil nil 100))))))

(defun ctp--corfu-popupinfo--show-advice (oldfun candidate)
  "Advice for `corfu-popupinfo--show' that works in the terminal.
CANDIDATE is the same as for `corfu-popupinfo--show'.  As this is meant to be
:around advice, OLDFUN is assumed to be the real (advised) function."
  (if (display-graphic-p)
      (progn
        (popon-kill ctp--popon)
        (funcall oldfun candidate))
    (when corfu-popupinfo--timer
      (cancel-timer corfu-popupinfo--timer)
      (setq corfu-popupinfo--timer nil))
    (when (and (frame-live-p corfu-popupinfo--frame)
               (frame-visible-p corfu-popupinfo--frame))
      (corfu--hide-frame corfu-popupinfo--frame))
    (when (or (not (ctp--visible-p))
              (not (corfu--equal-including-properties
                    candidate corfu-popupinfo--candidate)))
      (let ((buf (ctp--get-buffer)))
        (if (ctp--load-content candidate buf)
            (progn
              (ctp--display-buffer buf)
              (setq corfu-popupinfo--candidate candidate
                    corfu-popupinfo--toggle t))
          (corfu-popupinfo--hide))))))

(defun ctp--move-away-from-eob ()
  "Ensure the point isn't too close to the end of the buffer."
  (if-let ((total-lines (count-lines (point-min) (point-max)))
           ((> total-lines corfu-popupinfo-max-height))
           (rem-lines (count-lines (point) (point-max)))
           ((< rem-lines corfu-popupinfo-max-height)))
      (forward-line (- (- corfu-popupinfo-max-height rem-lines)))))

(defun ctp--corfu-popupinfo-scroll-up-advice
    (oldfun &optional n)
  "Advice for `corfu-popupinfo-scroll-up'.
N is the number of lines.  As this is :around advice, OLDFUN is the real
\(advised) function."
  (if (ctp--visible-p)
      (let ((buf (ctp--get-buffer)))
        (with-current-buffer buf
          (forward-line n)
          (beginning-of-line)
          (ctp--move-away-from-eob))
        (ctp--display-buffer buf))
    (funcall oldfun n)))

(defun ctp--corfu-popupinfo-end-advice (oldfun &optional n)
  "Advice for `corfu-popupinfo-end'.
N is the same as for `corfu-popupinfo-end'.  As this is :around advice, OLDFUN
is the real (advised) function."
  (if (ctp--visible-p)
      (let ((buf (ctp--get-buffer)))
        (with-current-buffer buf
          (let ((size (- (point-max) (point-min))))
            (goto-char (if n
                           (- (point-max) (/ (* size n) 10))
                         (point-max))))
          (beginning-of-line)
          (ctp--move-away-from-eob))
        (ctp--display-buffer buf))
    (funcall oldfun n)))

(defun ctp--corfu--popup-hide-advice ()
  ":after advice for `corfu--popup-hide'."
  (unless completion-in-region-mode
    (ctp--close)))

(defun ctp--enable ()
  "Enable corfu terminal popupinfo by advising some corfu functions."
  (advice-add 'corfu-popupinfo--visible-p :around
              'ctp--corfu-popupinfo--visible-p-advice)
  (advice-add 'corfu-popupinfo--hide :after
              'ctp--corfu-popupinfo--hide-advice)
  (advice-add 'corfu-popupinfo--show :around
              'ctp--corfu-popupinfo--show-advice)
  (advice-add 'corfu-popupinfo-scroll-up :around
              'ctp--corfu-popupinfo-scroll-up-advice)
  (advice-add 'corfu-popupinfo-end :around
              'ctp--corfu-popupinfo-end-advice)
  (advice-add 'corfu--popup-hide :after
              'ctp--corfu--popup-hide-advice))

(defun ctp--disable ()
  "Disable corfu terminal popupinfo by remove advice added by `ctp--enable'."
  (ctp--close)
  (advice-remove 'corfu-popupinfo--visible-p
                 'ctp--corfu-popupinfo--visible-p-advice)
  (advice-remove 'corfu-popupinfo--hide
                 'ctp--corfu-popupinfo--hide-advice)
  (advice-remove 'corfu-popupinfo--show
                 'ctp--corfu-popupinfo--show-advice)
  (advice-remove 'corfu-popupinfo-scroll-up
                 'ctp--corfu-popupinfo-scroll-up-advice)
  (advice-remove 'corfu-popupinfo-end
                 'ctp--corfu-popupinfo-end-advice)
  (advice-remove 'corfu--popup-hide
                 'ctp--corfu--popup-hide-advice))

(defun ctp--corfu-terminal-mode-hook ()
  "Hook run from `corfu-terminal-mode-hook'."
  (if (and corfu-terminal-mode
           (bound-and-true-p corfu-terminal-popupinfo-mode))
      (ctp--enable)
    (ctp--disable)))

;;;###autoload
(define-minor-mode corfu-terminal-popupinfo-mode
  "Minor mode shows the `corfu-popupinfo-mode' popup in the terminal.
Note that even with this enabled, you still need to enable the actual popup
using `corfu-popupinfo-toggle'.  Also, this does not do anything if
`corfu-terminal-mode' is not enabled."
  :global t
  :group 'corfu-terminal-popupinfo
  (if corfu-terminal-popupinfo-mode
      (progn
        (add-hook 'corfu-terminal-mode-hook 'ctp--corfu-terminal-mode-hook)
        (when corfu-terminal-mode
          (ctp--enable)))
    (remove-hook 'corfu-terminal-mode-hook 'ctp--corfu-terminal-mode-hook)
    (ctp--disable)))

(provide 'corfu-terminal-popupinfo)
;;; corfu-terminal-popupinfo.el ends here