....org/ideasman42/emacs-mono-complete https://www.gnu.org/software/emacs/download.html#gnu-linux
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

575 lines
20 KiB

;;; mono-complete.el --- Completion suggestions -*- lexical-binding: t -*-
;; SPDX-License-Identifier: GPL-2.0-or-later
;; Copyright (C) 2019 Campbell Barton
;; Author: Campbell Barton <ideasman42@gmail.com>
;; URL: https://codeberg.org/ideasman42/emacs-mono-complete
;; Version: 0.1
;; Package-Requires: ((emacs "27.1"))
;;; Commentary:
;; Configurable completion suggestions while typing.
;;; Usage
;; (mono-complete)
;;; Code:
;; ---------------------------------------------------------------------------
;; Custom Variables
(defgroup mono-complete nil
"Complete while typing with configurable back-ends."
:group 'convenience)
(defcustom mono-complete-preview-delay 0.235
"How long to wait until displaying the preview after a keystroke (in seconds)."
:type 'float)
(defcustom mono-complete-self-insert-commands '(self-insert-command org-self-insert-command)
"A list of commands after which to show a preview."
:type '(repeat function))
(defcustom mono-complete-literal-input t
"Simulate literal text input.
When enabled replaying this action as a macro re-inserts the literal text
instead of performing the completion action (which may give different results)."
:type 'boolean)
(defface mono-complete-preview-face '((t (:background "#000000"))) "Face for the preview.")
;; ---------------------------------------------------------------------------
;; Custom Callbacks
(defcustom mono-complete-fallback-command 'insert-tab
"Command to run when no preview is available."
:type 'function)
(defcustom mono-complete-backends 'mono-complete-backends-default
"A function which returns a list of back-ends."
:type 'function)
(defcustom mono-complete-debug-logging 'stdout
"Debug logging (intended for back-end developers)."
(list 'const :tag "Disabled" nil)
(list 'const :tag "Buffer" t)
(list 'const :tag "Standard Output" 'stdout)))
;; ---------------------------------------------------------------------------
;; Internal Variables
;; Cache for back-end presets, avoid requiring them and calling their function.
(defvar mono-complete--backend-require-cache nil)
;; The preview overlay or nil.
(defvar-local mono-complete--preview-overlay nil)
;; The preview overlay state or nil when the command.
(defvar-local mono-complete--preview-overlay-was-visible nil)
;; The preview idle timer.
(defvar-local mono-complete--preview-timer nil)
;; Hash where:
;; - The key is `complete-fn'.
;; - The value is a cons cell where:
;; - The CAR is the prefix,
;; - The CDR is the cache value defined by the completion implementation
;; (passed to and return from `complete-fn').
(defvar-local mono-complete--backend-runtime-cache nil)
;; ---------------------------------------------------------------------------
;; Internal Constants
(defconst mono-complete--commands '(mono-complete-expand mono-complete-expand-or-fallback))
;; Use this to prevent simulated input running command hooks
;; (which would trigger the idle timer).
(defconst mono-complete--suppress-command-hooks nil)
;; ---------------------------------------------------------------------------
;; Internal Logging
(defsubst mono-complete--debug-log (&rest args)
"Log format ARGS."
(when mono-complete-debug-logging
(let ((str (apply 'format args)))
((eq 'stdout mono-complete-debug-logging)
(princ str #'external-debugging-output)
(external-debugging-output ?\n))
(let ((buf (get-buffer-create "*mono-complete-log*")))
(with-current-buffer buf (insert str "\n"))))))))
;; ---------------------------------------------------------------------------
;; Internal Macro Utilities
(defun mono-complete--interactive-or-non-literal-input ()
"Return non-nil if this command is interactive or literal input is disabled."
;; Interactive only, when non-interactive,
;; the macros called here will be in-lined
;; and there is no need to perform any functionality in that case.
(not (or executing-kbd-macro noninteractive)))
(defun mono-complete--key-from-command (fn &optional descriptionp)
"Return the key for command symbol FN.
When DESCRIPTIONP is non-nil, return it's description."
(unless (commandp fn)
(error "Not a command: %s" fn))
((key (car (where-is-internal (or (command-remapping fn) fn) overriding-local-map nil nil))))
((null key)
(key-description key))
(defun mono-complete--call-interactively-macro (command-symbol)
"Call COMMAND-SYMBOL as a macro."
(command (symbol-name command-symbol))
(binding (mono-complete--key-from-command command-symbol t)))
(unless binding
;; Attempt to run "M-x command" if there is no direct shortcut.
(setq binding
(or (mono-complete--key-from-command 'execute-extended-command t) "M-x")
" "
(execute-kbd-macro (read-kbd-macro binding))))
(defun mono-complete--insert-with-literal-input (text)
"Helper function to simulate input using TEXT."
(dolist (ch (string-to-list text))
(execute-kbd-macro (char-to-string ch))))
;; ---------------------------------------------------------------------------
;; Internal Back-end Functions
(defun mono-complete--backend-load (id &optional quiet)
"Load a pre-defined back-end ID.
When QUIET is non-nil, report an error on failure to load."
(unless mono-complete--backend-require-cache
(setq mono-complete--backend-require-cache (make-hash-table :test #'eq)))
(let ((result (gethash id mono-complete--backend-require-cache :unset)))
(when (eq result :unset)
(setq result nil)
(let ((preset-sym (intern (concat "mono-complete-backend-" (symbol-name id)))))
(condition-case err
(require preset-sym)
(unless quiet
(message "mono-complete: back-end %S not found! (%S)" preset-sym err))
(setq result (funcall preset-sym))))
;; Put the result in the hash even when it's nil, not to regenerate.
(puthash id result mono-complete--backend-require-cache))
;; ---------------------------------------------------------------------------
;; Public Function Implementations
(defun mono-complete-backends-default ()
"Back-end defaults."
;; (mono-complete--backend-load 'dabbrev)
(mono-complete--backend-load 'filesystem)
;; (mono-complete--backend-load 'whole-line)
;; ---------------------------------------------------------------------------
;; Internal Functions
(defun mono-complete--is-mono-complete-command (command)
"[internal] Return non-nil if COMMAND is a mono-complete command."
(memq command mono-complete--commands))
(defun mono-complete--is-self-insert-command (command)
"Return non-nil if COMMAND is a \"self-insert command\"."
(memq command mono-complete-self-insert-commands))
(defun mono-complete--preview-text-at-point ()
"Test me."
(result nil)
(backends (funcall mono-complete-backends))
(prefix-cache (list)))
(while backends
(when-let ((backend-item (pop backends)))
((`(,prefix-fn ,complete-fn) (mono-complete--backend-items-or-warn backend-item)))
(let ((prefix nil))
(let ((prefix-fn-result-cons (assq prefix-fn prefix-cache)))
(setq prefix (cdr prefix-fn-result-cons)))
(setq prefix (funcall prefix-fn))
(push (cons prefix-fn prefix) prefix-cache))))
;; There may be no prefix, in this case skip.
(when prefix
(let ((backend-cache (mono-complete--backend-cache-ensure complete-fn)))
( ;; When the prefix was previously ignored, do nothing.
(stringp (car backend-cache))
(string-prefix-p (car backend-cache) prefix)))
;; Call the completion function.
complete-fn prefix backend-cache)))
(when result-suffix
(setq result (cons prefix result-suffix))))
;; Break.
(setq backends nil))
;; Skip this prefix in the future to prevent excessive calculation.
(setcar backend-cache prefix)))))))))
(defun mono-complete--on-exit ()
"Function run when executing another command.
That is, if `this-command' is not one of `mono-complete--commands'."
;; ---------------------------------------------------------------------------
;; Internal Back-End Functions
(defun mono-complete--backend-call-and-update (complete-fn prefix backend-cache)
(pcase-let ((`(,result . ,backend-cache-next) (funcall complete-fn prefix (cdr backend-cache))))
(setcdr backend-cache backend-cache-next)
(defun mono-complete--backend-cache-set (complete-fn val)
(unless mono-complete--backend-runtime-cache
(setq mono-complete--backend-runtime-cache (make-hash-table :test #'eq)))
(puthash complete-fn val mono-complete--backend-runtime-cache))
(defun mono-complete--backend-cache-ensure (complete-fn)
"Ensure COMPLETE-FN has an entry in `mono-complete--backend-runtime-cache'."
;; Existing.
(gethash complete-fn mono-complete--backend-runtime-cache))
;; Add new.
(mono-complete--backend-cache-set complete-fn (cons nil nil))))
(defun mono-complete--backend-cache-clear ()
"Clear back-end cache."
(when mono-complete--backend-runtime-cache
(clrhash mono-complete--backend-runtime-cache)))
(defun mono-complete--backend-items-or-warn (item)
"Extract back-end callbacks from ITEM, returning a list or nil."
(prefix-fn nil)
(complete-fn nil))
(while item
(key (pop item))
(val (pop item)))
((eq key :prefix)
(setq prefix-fn val))
((eq key :complete)
(setq complete-fn val))
(message "Unexpected keyword %S found!" key)))))
((null complete-fn)
(message "Missing :complete function!")
((null prefix-fn)
(message "Missing :prefix function!")
(list prefix-fn complete-fn)))))
;; ---------------------------------------------------------------------------
;; Internal Preview Functions
(defun mono-complete--preview-state-from-overlay ()
"Return the state of the overlay: (position . (prefix . expansion))."
(when (and mono-complete--preview-overlay (overlay-buffer mono-complete--preview-overlay))
(overlay-start mono-complete--preview-overlay)
(overlay-get mono-complete--preview-overlay 'mono-complete-prefix)
(overlay-get mono-complete--preview-overlay 'after-string)))))
(defun mono-complete--preview-refresh-from-state (state)
"Detect when text insertion follows the current preview allowing it to be used.
Argument STATE is the result of `mono-complete--preview-state-from-overlay'."
(let ((result nil))
(when state
(pcase-let ((`(,pos-prev . (,prefix-prev . ,expansion-prev)) state))
;; Ensure the point didn't move backwards.
(when (<= pos-prev (point))
;; When the length is equal, the entire word was manually typed in.
(when (> (length expansion-prev) (- (point) pos-prev))
(buffer-substring-no-properties (- pos-prev (length prefix-prev)) pos-prev)))
;; Sanity check that the buffer prefix has not changed.
(when (string-equal prefix-prev prefix-in-buffer)
(let ((overlap (buffer-substring-no-properties pos-prev (point))))
(when (or (string-empty-p overlap) (string-prefix-p overlap expansion-prev))
;; The modifications made don't impact the
(prefix (concat prefix-prev overlap))
(expansion (substring-no-properties expansion-prev (length overlap))))
(when mono-complete--preview-overlay
;; Should never happen, just sanity check.
(error "Invalid internal state"))
(setq mono-complete--preview-overlay (make-overlay (point) (point)))
(add-text-properties 0 1 '(cursor 1) expansion)
(length expansion)
(overlay-put mono-complete--preview-overlay 'after-string expansion)
(overlay-put mono-complete--preview-overlay 'mono-complete-prefix prefix)
(setq result t)))))))))
;; Don't refresh, use the timer instead.
(defun mono-complete--preview-text-from-command ()
"Return the expansion text for the preview displayed when the command began."
(when mono-complete--preview-overlay-was-visible
(substring-no-properties (cdr (cdr mono-complete--preview-overlay-was-visible)))))
(defun mono-complete--preview (buf)
"Show the preview for BUF."
(when (buffer-live-p buf)
(with-current-buffer buf
(cancel-timer mono-complete--preview-timer)
(setq mono-complete--preview-timer nil)
(let ((expansion-pair (mono-complete--preview-text-at-point)))
(when expansion-pair
(pcase-let ((`(,prefix . ,expansion-list) expansion-pair))
(let ((expansion (car expansion-list)))
(setq mono-complete--preview-overlay (make-overlay (point) (point)))
(add-text-properties 0 1 '(cursor 1) expansion)
(length expansion)
(overlay-put mono-complete--preview-overlay 'after-string expansion)
(overlay-put mono-complete--preview-overlay 'mono-complete-prefix prefix))))))))
;; ---------------------------------------------------------------------------
;; Internal Hooks
(defun mono-complete--pre-command-hook ()
"Function run from `pre-command-hook'."
(unless mono-complete--suppress-command-hooks
(setq mono-complete--preview-overlay-was-visible
(delete-overlay mono-complete--preview-overlay)
(setq mono-complete--preview-overlay nil))
(setq mono-complete--preview-overlay-was-visible nil)))))
(defun mono-complete--post-command-hook ()
"Function run from `post-command-hook'."
(unless mono-complete--suppress-command-hooks
(do-reset :unset)
(do-clear-timer t))
(when (mono-complete--is-self-insert-command this-command)
((mono-complete--preview-refresh-from-state mono-complete--preview-overlay-was-visible)
(mono-complete--debug-log "idle-timer: no-reset, use overlay in-place.")
(setq do-reset nil))
;; Keep cache when inserting text,
;; each completion must choose if cache should be reused or not.
(when mono-complete--preview-overlay-was-visible
(setq do-reset nil))
(mono-complete--debug-log "idle-timer: reuse (reset time).")
(timer-set-idle-time mono-complete--preview-timer mono-complete-preview-delay nil))
(mono-complete--debug-log "idle-timer: create.")
(setq mono-complete--preview-timer
(setq do-clear-timer nil))))
(when (eq do-reset :unset)
(setq do-reset (not (mono-complete--is-mono-complete-command this-command))))
(when do-clear-timer
(when (timerp mono-complete--preview-timer)
(cancel-timer mono-complete--preview-timer)
(setq mono-complete--preview-timer nil)))
(when do-reset
;; ---------------------------------------------------------------------------
;; Internal Mode Management
(defun mono-complete--mode-enable ()
"Turn on option `mono-complete-mode' for the current buffer."
(add-hook 'pre-command-hook #'mono-complete--pre-command-hook nil t)
(add-hook 'post-command-hook #'mono-complete--post-command-hook nil t))
(defun mono-complete--mode-disable ()
"Turn off option `mono-complete-mode' for the current buffer."
(remove-hook 'pre-command-hook #'mono-complete--pre-command-hook t)
(remove-hook 'post-command-hook #'mono-complete--post-command-hook t)
(when mono-complete--preview-overlay
(delete-overlay mono-complete--preview-overlay))
(when mono-complete--preview-timer
(cancel-timer mono-complete--preview-timer))
(kill-local-variable 'mono-complete--preview-overlay)
(kill-local-variable 'mono-complete--preview-overlay-was-visible)
(kill-local-variable 'mono-complete--preview-timer))
(defun mono-complete--expand-impl ()
"Expand the completion, return non-nil on success."
(let ((text (mono-complete--preview-text-from-command)))
(let ((mono-complete--suppress-command-hooks t))
(mono-complete--insert-with-literal-input text)))
(insert text)))
;; This would be called anyway in the post-command hook,
;; nevertheless, call early as this is known to be invalid at this point.
;; ---------------------------------------------------------------------------
;; Public API
(defun mono-complete-expand ()
"Expand the completion, return non-nil on success."
(when (mono-complete--interactive-or-non-literal-input)
(defun mono-complete-expand-or-fallback ()
"Expand the completion, return non-nil on success.
Otherwise run `mono-complete-callback-fn' and return it's result."
(when (mono-complete--interactive-or-non-literal-input)
(let ((result (mono-complete--expand-impl)))
(let ((mono-complete--suppress-command-hooks t))
(mono-complete--call-interactively-macro mono-complete-fallback-command)))
(call-interactively mono-complete-fallback-command))))))))
(define-minor-mode mono-complete-mode
"Enable enhanced compilation."
:global nil
(provide 'mono-complete)
;;; mono-complete.el ends here