eldoc-frame/eldoc-frame.el

;;; eldoc-frame.el --- Display eldoc documentation in child frame -*- lexical-binding: t; -*-

;; Author: Jessie Hildebrandt <jessieh@jessieh.net>
;;         Yuan Fu <casouri@gmail.com>
;; Homepage: https://git.tty.dog/jessieh/eldoc-frame
;; Keywords: eldoc
;; Version: 1.0.0
;; Package-Requires: ((emacs "28.1"))

;; Forked from eldoc-box:
;; https://github.com/casouri/eldoc-box
;; eldoc-box Copyright (C) 2018 Yuan Fu

;; This file is not part of GNU Emacs.

;;; Commentary:
;;
;; eldoc-frame provides a simple ElDoc frontend that displays documentation
;; in a floating child frame.
;;
;; To activate eldoc-frame:
;; (eldoc-frame-mode)
;;
;; To scroll ElDoc child frame, bind keys to:
;; (eldoc-frame-scroll-up-line)
;; (eldoc-frame-scroll-down-line)
;;
;; To hide ElDoc child frames with \\[C-g]:
;; (advice-add #'keyboard-quit :before #'eldoc-frame-hide-frame)

;;; License
;;
;; This program 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, or (at your option)
;; any later version.

;; This program 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 this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.

;;; Code:

;; -------------------------------------------------------------------------- ;;
;;
;; Byte-compiler declarations
;;
;; -------------------------------------------------------------------------- ;;

;; ---------------------------------- ;;
;; Variable defs
;; ---------------------------------- ;;

(eval-when-compile
  (defvar eldoc-frame-mode))

;; -------------------------------------------------------------------------- ;;
;;
;; Constants
;;
;; -------------------------------------------------------------------------- ;;

(defconst eldoc-frame-parameters-default
  '((no-other-frame . t)
    (no-accept-focus . t)
    (no-focus-on-map . t)
    (no-special-glyphs . t)
    (min-width  . 0)
    (min-height  . 0)
    (undecorated . t)
    (unsplittable . t)
    (menu-bar-lines . 0)
    (tool-bar-lines . 0)
    (tab-bar-lines . 0)
    (tab-bar-lines-keep-state . 1)
    (internal-border-width . 1)
    (vertical-scroll-bars . nil)
    (horizontal-scroll-bars . nil)
    (drag-internal-border . t)
    (mouse-wheel-frame . nil)
    (cursor-type . nil)
    (inhibit-double-buffering . t)
    (desktop-dont-save . t))
  "Default frame parameters supplied during creation of the ElDoc child frame.")

(defconst eldoc-frame-buffer-hook-default
  '(eldoc-frame--buffer-setup
    eldoc-frame--remove-hr
    eldoc-frame--remove-gaps
    eldoc-frame--remove-junk-chars
    eldoc-frame--remove-linked-images
    eldoc-frame--fontify-html
    eldoc-frame--set-buffer-faces
    eldoc-frame--remap-spaces)
  "Default list of functions to hook into `eldoc-frame-buffer-hook'.")

(defconst eldoc-frame-functions-default '(eldoc-frame--set-frame-faces)
  "Default list of functions to hook into `eldoc-frame-functions'.")

;; -------------------------------------------------------------------------- ;;
;;
;; Custom definitions
;;
;; -------------------------------------------------------------------------- ;;

;; ---------------------------------- ;;
;; Group definitions
;; ---------------------------------- ;;

(defgroup eldoc-frame nil
  "Display ElDoc documentation in a child frame."
  :group 'eldoc)

(defgroup eldoc-frame-faces nil
  "Faces used by eldoc-frame."
  :group 'eldoc-frame
  :group 'faces)

;; ---------------------------------- ;;
;; Variable definitions
;; ---------------------------------- ;;

(defcustom eldoc-frame-lighter " ELDOC-FRAME"
  "Mode line lighter for `eldoc-frame-mode'.
When nil, no lighter is displayed."
  :group 'eldoc-frame
  :type '(choice string
                 (const :tag "None" nil)))

(defcustom eldoc-frame-max-pixel-width '(min 500 (/ (frame-pixel-width) 4))
  "Maximum allowed width of the ElDoc child frame, in pixels.
May be any expression that evaluates to a number."
  :group 'eldoc-frame
  :type 'sexp)

(defcustom eldoc-frame-max-pixel-height '(min 300 (/ (frame-pixel-height) 4))
  "Maximum allowed height of the ElDoc child frame, in pixels.
May be any expression that evaluates to a number."
  :group 'eldoc-frame
  :type 'sexp)

(defcustom eldoc-frame-offset '(16 16 16)
  "List providing left, right, and top pixel offsets of the ElDoc child frame.
The list should be of the form (LEFT RIGHT TOP)."
  :group 'eldoc-frame
  :type '(list
          (integer :tag "Left")
          (integer :tag "Right")
          (integer :tag "Top")))

(defcustom eldoc-frame-parameters eldoc-frame-parameters-default
  "Frame parameters supplied during creation of the ElDoc child frame."
  :group 'eldoc-frame
  :type '(alist :tag "Frame parameters"
                :key-type (symbol :tag "Parameter")
                :value-type (sexp :tag "Value")))

(defcustom eldoc-frame-buffer-hook eldoc-frame-buffer-hook-default
  "Hook run after documentation display buffer is set up.
All functions are run with the documentation display buffer current."
  :group 'eldoc-frame
  :type 'hook)

(defcustom eldoc-frame-functions eldoc-frame-functions-default
  "Hook run after ElDoc child frame is set up, before it is made visible.
All functions are run with the eldoc child frame selected."
  :group 'eldoc-frame
  :type 'hook)

;; ---------------------------------- ;;
;; Face definitions
;; ---------------------------------- ;;

(defface eldoc-frame-default
  '((t nil))
  "Default face used in the body of eldoc-frame child frames."
  :group 'eldoc-frame-faces)

(defface eldoc-frame-border
  '((t (:inherit vertical-border)))
  "Face used for eldoc-frame child frame borders."
  :group 'eldoc-frame-faces)

;; -------------------------------------------------------------------------- ;;
;;
;; Buffer formatting functions
;;
;; -------------------------------------------------------------------------- ;;

;; ---------------------------------- ;;
;; Buffer setup
;; ---------------------------------- ;;

(defun eldoc-frame--buffer-setup ()
  "Set up appropriate local modes and related settings for the current buffer."
  (setq-local mode-line-format nil
              header-line-format nil
              global-hl-line-mode nil
              tab-line-format nil
              cursor-type t)
  (visual-line-mode))

;; ---------------------------------- ;;
;; Junk removal
;; ---------------------------------- ;;

(defun eldoc-frame--remove-hr ()
  "Remove horizontal rules from the current buffer."
  (goto-char (point-min))
  (let ((prop))
    (while (setq prop (text-property-search-forward 'markdown-hr))
      (goto-char (prop-match-beginning prop))
      (delete-char (- (prop-match-end prop) (prop-match-beginning prop))))))

(defun eldoc-frame--remove-gaps ()
  "Truncate groups of two-or-more newlines from the current buffer."
  (goto-char (point-min))
  (while (re-search-forward
          (rx (>= 2 (or "\n"
                        (seq (+ "<br>") "\n")
                        (seq bol "```" (* (syntax word)) "\n")
                        (seq bol (+ (or " " "\t" " ")) "\n"))))
          nil t)
    (if (or (eq (match-beginning 0) (point-min))
            (eq (match-end 0) (point-max)))
        (replace-match "")
      (replace-match "\n\n"))))

(defun eldoc-frame--remove-junk-chars ()
  "Remove junk display characters from the current buffer."
  (goto-char (point-min))
  (while (search-forward "\r" nil t)
    (replace-match "")))

(defun eldoc-frame--remove-linked-images ()
  "Remove Markdown image links from the current buffer."
  (goto-char (point-min))
  (while (re-search-forward
          (rx "[" (seq "![" (+? anychar) "](" (+? anychar) ")") "]"
              "(" (+? anychar) ")")
          nil t)
    (replace-match "")))

;; ---------------------------------- ;;
;; Fontification
;; ---------------------------------- ;;

(defun eldoc-frame--fontify-html ()
  "Fontify HTML tags and character entities in the current buffer."
  ;; Header tags
  (goto-char (point-min))
  (while (re-search-forward (rx bol
                                (group "<h" digit ">")
                                (group (*? anychar))
                                (group "</h" digit ">")
                                eol)
                            nil t)
    (add-text-properties (match-beginning 2) (match-end 2)
                         '(face (:weight bold) font-lock-face (:weight bold)))
    (put-text-property (match-beginning 1) (match-end 1)
                       'invisible t)
    (put-text-property (match-beginning 3) (match-end 3)
                       'invisible t))
  ;; Character entities
  (goto-char (point-min))
  (while (re-search-forward (rx (or "&lt;" "&gt;" "&nbsp;")) nil t)
    (put-text-property (match-beginning 0) (match-end 0)
                       'display
                       (pcase (match-string 0)
                         ("&lt;" "<")
                         ("&gt;" ">")
                         ("&nbsp;" " ")))))

;; ---------------------------------- ;;
;; Face setup
;; ---------------------------------- ;;

(defun eldoc-frame--set-buffer-faces ()
  "Set up appropriate faces in the current buffer."
  (buffer-face-set 'eldoc-frame-default))

(defun eldoc-frame--remap-spaces ()
  "Remap special spaces to display as standard spaces in the current buffer."
  (face-remap-set-base 'nobreak-space '(:inherit default))
  (face-remap-set-base 'markdown-line-break-face '(:inherit default)))

;; -------------------------------------------------------------------------- ;;
;;
;; Frame formatting functions
;;
;; -------------------------------------------------------------------------- ;;

;; ---------------------------------- ;;
;; Face setup
;; ---------------------------------- ;;

(defun eldoc-frame--set-frame-faces (frame)
  "Set up appropriate face attributes for child frame FRAME."
  (set-face-attribute 'fringe frame
                      :background 'unspecified
                      :inherit 'eldoc-frame-default)
  (set-face-attribute 'internal-border frame
                      :background 'unspecified
                      :inherit 'eldoc-frame-border)
  (set-face-attribute 'child-frame-border frame
                      :background 'unspecified
                      :inherit 'eldoc-frame-border))

;; -------------------------------------------------------------------------- ;;
;;
;; Child frame helper functions
;;
;; -------------------------------------------------------------------------- ;;

(defvar eldoc-frame--frame nil
  "Child frame used to display `eldoc-frame--buffer'.")

(defvar eldoc-frame--buffer (get-buffer-create " *eldoc-frame*" t)
  "Buffer used by `eldoc-frame--display' to display documentation.")

(defvar-local eldoc-frame--last-point nil
  "Buffer-local value of `point' when ElDoc child frame was last displayed.")

;; ---------------------------------- ;;
;; Frame geometry
;; ---------------------------------- ;;

(defun eldoc-frame--selected-window-side ()
  "Return which side of the frame the selected window is on.
Return ‘left’ if the selected window is on the left, or ‘right’ if the selected
window is on the right. Return ‘left’ if there is only one window in the frame."
  (let* ((window-left (nth 0 (window-absolute-pixel-edges)))
         (window-right (nth 2 (window-absolute-pixel-edges)))
         (frame-left (nth 0 (frame-edges)))
         (frame-right (nth 2 (frame-edges)))
         (distance-left (- window-left frame-left))
         (distance-right (- frame-right window-right)))
    (if (<= distance-left distance-right) 'left 'right)))

(defun eldoc-frame--calc-frame-x-position (frame)
  "Calculate the appropriate X position (offset) for FRAME."
  (pcase-let ((`(,offset-l ,offset-r) eldoc-frame-offset))
    (pcase (eldoc-frame--selected-window-side)
      ;; Selected window is on the left, so child frame should be on the right:
      ('left (- (frame-pixel-width (selected-frame))
                (frame-pixel-width frame)
                offset-r))
      ;; Selected window is on the right, so child frame should be on the left:
      ('right offset-l))))

(defun eldoc-frame--update-frame-geometry (frame)
  "Update size and position of FRAME."
  (let ((size (window-text-pixel-size (frame-selected-window frame)
                                      nil nil
                                      (eval eldoc-frame-max-pixel-width)
                                      (eval eldoc-frame-max-pixel-height)
                                      t)))
    (set-frame-size frame (car size) (cdr size) :pixelwise)
    (set-frame-position frame
                        (eldoc-frame--calc-frame-x-position frame)
                        (nth 2 eldoc-frame-offset))))

(defun eldoc-frame--maybe-resize-frame ()
  "Update the size and position of ElDoc child frame if it is visible."
  (when (and (frame-live-p eldoc-frame--frame)
             (not (eq (selected-frame) eldoc-frame--frame)))
    (eldoc-frame--update-frame-geometry eldoc-frame--frame)))

;; ---------------------------------- ;;
;; Frame visibility
;; ---------------------------------- ;;

(defun eldoc-frame--maybe-hide-frame ()
  "Hide ElDoc child frame if it is appropriate to do so.
The child frame will be hidden if it is currently visible, the child frame is
not currently selected, and the point has moved or `eldoc-frame-mode' is no
longer active."
  (when (and eldoc-frame--frame
             (frame-visible-p eldoc-frame--frame)
             (not (eq (selected-frame) eldoc-frame--frame))
             (or (not (eq (point) eldoc-frame--last-point))
                 (not eldoc-frame-mode)))
    (eldoc-frame-hide-frame)))

(defun eldoc-frame-hide-frame ()
  "Hide ElDoc child frame if it is visible."
  (interactive)
  (when (frame-live-p eldoc-frame--frame)
    (make-frame-invisible eldoc-frame--frame t)))

;; ---------------------------------- ;;
;; Frame scrolling
;; ---------------------------------- ;;

(defun eldoc-frame-scroll (count)
  "Scroll text of ElDoc child frame by COUNT lines if it visible."
  (interactive)
  (when (and (frame-live-p eldoc-frame--frame)
             (frame-visible-p eldoc-frame--frame))
    (with-selected-frame eldoc-frame--frame
      (scroll-up count))))

(defun eldoc-frame-scroll-up-line (&optional arg)
  "Scroll text of ElDoc child frame upward ARG lines if it visible."
  (interactive)
  (eldoc-frame-scroll (or arg 1)))

(defun eldoc-frame-scroll-down-line (&optional arg)
  "Scroll text of ElDoc child frame down ARG lines if it visible."
  (interactive)
  (eldoc-frame-scroll (or arg -1)))

;; ---------------------------------- ;;
;; Frame creation
;; ---------------------------------- ;;

(defun eldoc-frame--create-child-frame (buffer)
  "Return new child frame displaying BUFFER."
  (let* ((before-make-frame-hook nil)
         (after-make-frame-functions nil)
         (frame-parameters (append
                            `((top . -1)
                              (left . -1)
                              (width  . 0)
                              (height  . 0)
                              (visibility . nil)
                              (minibuffer . ,(minibuffer-window))
                              (default-minibuffer-frame . ,(selected-frame)))
                            eldoc-frame-parameters))
         (display-buffer-alist `((dedicated . t)
                                 (child-frame-parameters . ,frame-parameters)))
         (window (display-buffer-in-child-frame buffer display-buffer-alist))
         (frame (window-frame window)))
    (redirect-frame-focus frame (frame-parent frame))
    frame))

;; -------------------------------------------------------------------------- ;;
;;
;; ElDoc display function
;;
;; -------------------------------------------------------------------------- ;;

;; ---------------------------------- ;;
;; Display helper functions
;; ---------------------------------- ;;

(defun eldoc-frame--display-buffer-in-child-frame (buffer)
  "Display BUFFER in child frame.
If `eldoc-frame--frame' already contains a live frame, that child frame will be
reused. Otherwise, a new frame is created by `eldoc-frame--create-child-frame'."
  (unless (frame-live-p eldoc-frame--frame)
    (setq eldoc-frame--frame (eldoc-frame--create-child-frame buffer)))
  (set-frame-parameter eldoc-frame--frame 'parent-frame (selected-frame))
  (eldoc-frame--update-frame-geometry eldoc-frame--frame)
  (run-hook-with-args 'eldoc-frame-functions eldoc-frame--frame)
  (set-window-vscroll (get-buffer-window eldoc-frame--buffer) 0)
  (make-frame-visible eldoc-frame--frame))

(defun eldoc-frame--format-doc (doc)
  "Format ElDoc doc DOC into a string."
  (string-trim (concat (when-let ((thing (plist-get (cdr doc) :thing)))
                         (concat (propertize (format "%s" thing)
                                             'face (plist-get (cdr doc) :face))
                                 ": "))
                       (car doc))))

;; ---------------------------------- ;;
;; Display function
;; ---------------------------------- ;;

(defun eldoc-frame--eldoc-display-function (docs _interactive)
  "Display DOCS in a child frame."
  (when-let ((str (string-join (mapcar #'eldoc-frame--format-doc docs) "\n\n")))
    (unless (string-empty-p str)
      (setq-local eldoc-frame--last-point (point))
      (with-current-buffer eldoc-frame--buffer
        (erase-buffer)
        (insert str)
        (run-hook-with-args 'eldoc-frame-buffer-hook)
        (goto-char (point-min)))
      (eldoc-frame--display-buffer-in-child-frame eldoc-frame--buffer))))

;; -------------------------------------------------------------------------- ;;
;;
;; eldoc-frame-mode
;;
;; -------------------------------------------------------------------------- ;;

(defvar eldoc-frame--idle-timer nil
  "Timer triggering `eldoc-frame--maybe-hide-frame'.")

(defvar-local eldoc-frame--old-eldoc-functions nil
  "The original buffer-local value of ‘eldoc-display-functions’.")

(defvar eldoc-frame-mode-map (make-sparse-keymap)
  "Keymap used when `eldoc-frame-mode' is active.")

;; ---------------------------------- ;;
;; Activation
;; ---------------------------------- ;;

(defun eldoc-frame--activate ()
  "Handle activation of `eldoc-frame-mode'."
  ;; Back up current buffer-local value of `eldoc-display-functions' and
  ;; install the eldoc-frame diplay function
  (setq-local eldoc-frame--old-eldoc-functions eldoc-display-functions
              eldoc-display-functions '(eldoc-frame--eldoc-display-function))
  ;; Install hooks to handle window state changes gracefully
  (add-hook 'window-state-change-hook #'eldoc-frame--maybe-resize-frame)
  (add-hook 'window-state-change-hook #'eldoc-frame--maybe-hide-frame)
  ;; Start `eldoc-frame--idle-timer' if another buffer hasn't started it
  (unless (timerp eldoc-frame--idle-timer)
    (setq eldoc-frame--idle-timer (run-with-idle-timer
                                   (* eldoc-idle-delay 2)
                                   :repeat
                                   #'eldoc-frame--maybe-hide-frame))))

;; ---------------------------------- ;;
;; Deactivation
;; ---------------------------------- ;;

(defun eldoc-frame--deactivate ()
  "Handle deactivation of `eldoc-frame-mode'."
  ;; Delete `eldoc-frame--frame' if it exists
  (when eldoc-frame--frame
    (setq eldoc-frame--frame (delete-frame eldoc-frame--frame)))
  ;; Clear `eldoc-frame--idle-timer' if it exists
  (when (timerp eldoc-frame--idle-timer)
    (setq eldoc-frame--idle-timer (cancel-timer eldoc-frame--idle-timer)))
  ;; Remove window state change hooks
  (remove-hook 'window-size-change-functions #'eldoc-frame--maybe-resize-frame)
  (remove-hook 'window-state-change-hook #'eldoc-frame--maybe-hide-frame)
  ;; Restore the original buffer-local value of `eldoc-display-functions'
  (setq-local eldoc-display-functions
              eldoc-frame--old-eldoc-functions))

;; ---------------------------------- ;;
;; Mode definition
;; ---------------------------------- ;;

;;;###autoload
(define-minor-mode eldoc-frame-mode
  "Display ElDoc documentation in a child frame."
  :group 'eldoc-frame
  :keymap eldoc-frame-mode-map
  :lighter eldoc-frame-lighter
  (if eldoc-frame-mode
      (eldoc-frame--activate)
    (eldoc-frame--deactivate)))

;; -------------------------------------------------------------------------- ;;
;;
;; Provide package
;;
;; -------------------------------------------------------------------------- ;;

(provide 'eldoc-frame)

;;; eldoc-frame.el ends here