You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

787 lines
28 KiB

;;; mono-complete.el --- Completion suggestions with multiple back-ends -*- lexical-binding: t -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;; Copyright (C) 2023 Campbell Barton
;; Author: Campbell Barton <>
;; URL:
;; Version: 0.1
;; Package-Requires: ((emacs "28.1"))
;;; Commentary:
;; Configurable completion suggestions while typing.
;;; Usage
;; (mono-complete-mode)
;;; Code:
;; ---------------------------------------------------------------------------
;; Custom Variables
(defgroup mono-complete nil
"Complete while typing with configurable back-ends."
:group 'convenience)
(defcustom mono-complete-backends (list 'dabbrev)
"A list of backend identifiers, or a function which returns the same.
When a function is used this takes a single boolean IS-CONTEXT argument.
When non-nil return all back-ends that may be used for the buffer,
otherwise return a sub-set of this list based on the current context."
:type '(repeat function))
(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-fallback-command 'indent-for-tab-command
"Command to run when no preview is available."
:type '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)
(defcustom mono-complete-evil-insert-mode-only t
"Restrict to insert mode when used in combination with `evil-mode'."
:type 'boolean)
(defcustom mono-complete-cache-directory
(locate-user-emacs-file "mono-complete" ".emacs-mono-complete")
"The directory to store mono-complete cache data."
:type 'string)
(defface mono-complete-preview-face '((t (:foreground "#ffff00" :background "#000000")))
"Face for the preview.")
;; ---------------------------------------------------------------------------
;; Custom Variables (used by back-ends)
(defcustom mono-complete-project-root 'mono-complete-project-root-default
"Function to call that returns the root path of the current buffer.
A nil return value will fall back to the `default-directory'."
:type 'function)
;; ---------------------------------------------------------------------------
;; Custom Callbacks
(defcustom mono-complete-debug-log nil ; 'stdout
"Debug logging (intended for back-end developers)."
'(choice (const :tag "Disabled" nil)
(const :tag "Buffer" t)
(const :tag "Standard Output" stdout)))
(defcustom mono-complete-debug-log-time t
"Report the time taken to execute back-ends completion functions.
Intended for back-end developers investigating performance."
:type 'boolean)
(defcustom mono-complete-debug-log-backends t
"Report the back-ends used."
:type 'boolean)
;; ---------------------------------------------------------------------------
;; Public Variables
(defvar mono-complete-mode-map (make-sparse-keymap)
"Minimal key-map intended to call.
`mono-complete-expand' or `mono-complete-expand-or-fallback'.")
;; ---------------------------------------------------------------------------
;; Back-Ported Functions
(when (version< emacs-version "29.1")
(defmacro with-undo-amalgamate (&rest body)
"Like `progn' but perform BODY with amalgamated undo barriers.
This allows multiple operations to be undone in a single step.
When undo is disabled this behaves like `progn'."
(declare (indent 0) (debug t))
(let ((handle (make-symbol "--change-group-handle--")))
`(let ((,handle (prepare-change-group))
;; Don't truncate any undo data in the middle of this,
;; otherwise Emacs might truncate part of the resulting
;; undo step: we want to mimic the behavior we'd get if the
;; undo-boundaries were never added in the first place.
(undo-outer-limit nil)
(undo-limit most-positive-fixnum)
(undo-strong-limit most-positive-fixnum))
(activate-change-group ,handle)
(accept-change-group ,handle)
(undo-amalgamate-change-group ,handle)))))))
;; ---------------------------------------------------------------------------
;; Generic Functions
(defun mono-complete-project-root-default ()
"Function to find the project root from the current buffer.
This checks `ffip', `projectile' & `vc' root,
using `default-directory' as a fallback."
((fboundp 'ffip-project-root)
(funcall #'ffip-project-root))
((fboundp 'projectile-project-root)
(funcall #'projectile-project-root))
(or (when buffer-file-name
(let ((vc-backend
(vc-responsible-backend buffer-file-name))))
(when vc-backend
(vc-call-backend vc-backend 'root buffer-file-name))))))))
(defun mono-complete-project-root ()
"Return the project directory (or default)."
(file-name-as-directory (or (funcall mono-complete-project-root) default-directory)))
;; ---------------------------------------------------------------------------
;; 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.
;; This is the result of `mono-complete--preview-state-from-overlay' see it's doc-string for details.
(defvar-local mono-complete--preview-overlay-was-visible nil)
;; The preview idle timer.
(defvar-local mono-complete--preview-timer nil)
;; Store the current context during text insertion.
;; - `backends':
;; Store a list of back-ends calculated when typing begins.
;; - `result-cache':
;; 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--context nil)
;; ---------------------------------------------------------------------------
;; Internal Constants
(defconst mono-complete--commands '(mono-complete-expand mono-complete-expand-or-fallback))
;; Boolean to use this to prevent simulated input running command hooks
;; (which would otherwise trigger the idle timer). Use `let' to override this.
(defconst mono-complete--suppress-command-hooks nil)
;; ---------------------------------------------------------------------------
;; Internal Logging
(defsubst mono-complete--debug-log-unchecked (&rest args)
"Log format ARGS."
(let ((str (apply #'format args)))
((eq 'stdout mono-complete-debug-log)
(princ str #'external-debugging-output)
(external-debugging-output ?\n))
(let ((buf (get-buffer-create "*mono-complete-log*")))
(with-current-buffer buf
(insert str "\n")))))))
(defsubst mono-complete--debug-log (&rest args)
"Log format ARGS."
(when mono-complete-debug-log
(apply #'mono-complete--debug-log-unchecked args)))
;; ---------------------------------------------------------------------------
;; 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))
(let ((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."
(let ((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."
(execute-kbd-macro (vconcat text))))
(defun mono-complete--backend-load-validate-uuid (id uuid config)
"Validate ID, UUID & CONFIG arguments."
(unless uuid
"mono-complete-backend-load: has CONFIG argument without a UUID argument, skipping!")
(setq uuid :invalid))
(setq uuid id))))
;; ---------------------------------------------------------------------------
;; Internal Back-end Functions
(defun mono-complete--backend-load-impl (id &optional uuid config)
"See `mono-complete-backend-load' for ID UUID & CONFIG doc-strings."
(unless mono-complete--backend-require-cache
(setq mono-complete--backend-require-cache (make-hash-table :test #'eq)))
(let ((result (gethash uuid mono-complete--backend-require-cache :unset)))
(when (eq result :unset)
(setq result nil)
(let ((preset-sym (intern (concat "mono-complete-backend-" (symbol-name id)))))
(when (condition-case-unless-debug err
(require preset-sym)
(error (message "mono-complete: back-end %S not found! (%S)" preset-sym err) nil))
(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))
(when (and result config)
(plist-put result :config config))
(defun mono-complete-backend-load (id &optional uuid config)
"Load a pre-defined back-end ID.
When passing in a CONFIG UUID must be a unique identifier in the list."
((and id (symbolp id))
(setq uuid (mono-complete--backend-load-validate-uuid id uuid config))
(mono-complete--backend-load-impl id uuid config))
(message "mono-complete: found non-symbol when loading a back-end (%S)" id)
(defun mono-complete--backends-from-config (is-context)
"Return back-ends from user configuration.
IS-CONTEXT is forwarded to the callback."
(let ((backends mono-complete-backends))
(when (functionp backends)
(setq backends (funcall backends is-context)))
(mapcar (lambda (id) (mono-complete-backend-load id)) backends)))
;; ---------------------------------------------------------------------------
;; Internal Functions
(defun mono-complete--is-mono-complete-command (command)
"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 ()
"Show the completion from the text at the point (where possible)."
(let ((result nil)
(backends-cons (assq 'backends mono-complete--context))
(backends nil)
(prefix-cache (list)))
(setq backends (cdr backends-cons)))
(setq backends (mono-complete--backends-from-config t))
(setq backends-cons (cons 'backends backends))
(push backends-cons mono-complete--context)))
(when (and mono-complete-debug-log mono-complete-debug-log-backends)
(let ((backend-info (list)))
(dolist (backend-item backends)
(when backend-item
(pcase-let ((`(,_config ,_setup-fn ,_prefix-fn ,complete-fn)
(mono-complete--backend-items-or-warn backend-item)))
(when complete-fn
(let ((backend-str
;; Remove prefix for brevity only.
(string-remove-prefix "mono-complete-backend-" (format "%S" complete-fn))))
(push backend-str backend-info))))))
(setq backend-info (nreverse backend-info))
"backend-used: (%d) %s" (length backend-info) (mapconcat #'identity backend-info ", "))))
(while backends
(when-let ((backend-item (pop backends)))
(pcase-let ((`(,config ,_setup-fn ,prefix-fn ,complete-fn)
(mono-complete--backend-items-or-warn backend-item)))
(when complete-fn
(let ((prefix nil))
(let ((prefix-fn-result-cons (assq prefix-fn prefix-cache)))
(setq prefix (cdr prefix-fn-result-cons)))
(condition-case-unless-debug err
(setq prefix (funcall prefix-fn))
(message "mono-complete: prefix function %S, failed with error (%S)"
(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.
((and (stringp (car backend-cache))
(string-prefix-p (car backend-cache) prefix)))
;; Call the completion function.
((let ((result-suffix
complete-fn config 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'."
(setq mono-complete--context nil))
;; ---------------------------------------------------------------------------
;; Internal Back-End Functions
(defun mono-complete--backend-call-and-update (complete-fn config prefix backend-cache)
(let ((time-beg nil))
(when (and mono-complete-debug-log mono-complete-debug-log-time)
(setq time-beg (current-time)))
(pcase-let ((`(,result . ,cache-next) (funcall complete-fn config prefix (cdr backend-cache))))
(when time-beg
"backend-call: (%S) %.4f"
(float-time (time-subtract (current-time) time-beg))))
(setcdr backend-cache cache-next)
(defun mono-complete--backend-cache-set (complete-fn val)
(let ((result-cache-cons (assq 'result-cache mono-complete--context))
(result-cache nil))
(setq result-cache (cdr result-cache-cons)))
(setq result-cache (make-hash-table :test #'eq))
(setq result-cache-cons (cons 'result-cache result-cache))
(push result-cache-cons mono-complete--context)))
(puthash complete-fn val result-cache)))
(defun mono-complete--backend-cache-ensure (complete-fn)
"Ensure COMPLETE-FN has an entry in `mono-complete--context' (result-cache)."
(let ((result-cache (alist-get 'result-cache mono-complete--context nil nil #'eq)))
;; Existing.
(and result-cache (gethash complete-fn result-cache))
;; Add new.
(mono-complete--backend-cache-set complete-fn (cons nil nil)))))
(defun mono-complete--backend-cache-clear ()
"Clear back-end cache."
;; Get and remove, the key.
(let ((result-cache (alist-get 'result-cache mono-complete--context nil t #'eq)))
(when result-cache
(clrhash result-cache))))
(defun mono-complete--backend-items-or-warn (item)
"Extract back-end callbacks from ITEM, returning a list or nil."
(let ((config nil)
;; Setup is optional.
(setup-fn nil)
(prefix-fn nil)
(complete-fn nil))
(while item
(let* ((key (pop item))
(val (pop item)))
((eq key :config)
(setq config val))
((eq key :setup)
(setq setup-fn val))
((eq key :prefix)
(setq prefix-fn val))
((eq key :complete)
(setq complete-fn val))
(message "Unexpected keyword %S found!" key)))))
((eq config t)
;; A signal that calling setup failed (with an error or the mode was not compatible),
;; return nothing with no error.
((null complete-fn)
(message "Missing :complete function!")
((null prefix-fn)
(message "Missing :prefix function!")
(list config setup-fn 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-create-overlay (prefix expansion)
"Add EXPANSION overlay (with PREFIX as a property)."
(let ((overlay (make-overlay (point) (point))))
;; Empty strings may be used for temporary expansion.
(unless (string-empty-p expansion)
(add-text-properties 0 1 '(cursor 1) expansion))
(add-face-text-property 0 (length expansion) 'mono-complete-preview-face nil expansion)
(overlay-put overlay 'after-string expansion)
(overlay-put overlay 'mono-complete-prefix prefix)
(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))
(let ((prefix-in-buffer
(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
(let ((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
(mono-complete--preview-create-overlay prefix expansion))
(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
(mono-complete--preview-create-overlay prefix expansion)))))))))
;; ---------------------------------------------------------------------------
;; 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 (mono-complete--preview-state-from-overlay))
(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
(let ((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
(run-with-idle-timer mono-complete-preview-delay nil #'mono-complete--preview
(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--command-hooks-enable ()
"Enable command hooks."
(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--command-hooks-disable ()
"Disable command hooks."
(remove-hook 'pre-command-hook #'mono-complete--pre-command-hook t)
(remove-hook 'post-command-hook #'mono-complete--post-command-hook t))
(defun mono-complete--mode-enable ()
"Turn on option `mono-complete-mode' for the current buffer."
((and mono-complete-evil-insert-mode-only (boundp 'evil-state))
(lambda ()
;; Only add hooks.
(lambda ()
;; Clear overlays.
(when (timerp mono-complete--preview-timer)
(cancel-timer mono-complete--preview-timer)
(setq mono-complete--preview-timer nil))))
(when (memq (symbol-value 'evil-state) (list 'replace 'insert))
;; Run `setup' on all back-ends.
(let ((backends (mono-complete--backends-from-config nil)))
(while backends
(when-let ((backend-item (pop backends)))
(pcase-let ((`(,config ,setup-fn ,_prefix-fn ,_complete-fn)
(mono-complete--backend-items-or-warn backend-item)))
(when setup-fn
(let ((config-next
(condition-case-unless-debug err
(funcall setup-fn config)
(message "mono-complete: setup %S error (%S)" setup-fn err)
;; Skip the back-end.
(plist-put backend-item :config config-next))))))))
(defun mono-complete--mode-disable ()
"Turn off option `mono-complete-mode' for the current buffer."
(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)
(kill-local-variable 'mono-complete--context))
(defun mono-complete--expand-impl ()
"Expand the completion, return non-nil on success."
(let ((text (mono-complete--preview-text-from-command)))
(when (string-empty-p text)
(setq text nil))
(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)
;; Local Variables:
;; fill-column: 99
;; indent-tabs-mode: nil
;; elisp-autofmt-format-quoted: nil
;; End:
;;; mono-complete.el ends here