From d278b976d480f672ba38764171891e74155ecb54 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Miha=20Rihtar=C5=A1i=C4=8D?= Date: Fri, 9 Sep 2022 20:08:19 +0200 Subject: [PATCH] Implement a general input fontification mechanism for comint modes * lisp/comint.el (comint-indent-input-line): (comint-indent-input-line-default): (comint-indent-input-region): (comint-indent-input-region-default): New functions that implement a general mechanism for input indentation through an indirect buffer in comint derived major modes. * lisp/shell.el (shell-mode): Set up input indentation according to sh-mode (bug#51940). --- lisp/comint.el | 229 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 229 insertions(+) diff --git a/lisp/comint.el b/lisp/comint.el index 8786c6db4b3..4fcfb500e18 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -1944,6 +1944,7 @@ Similarly for Soar, Scheme, etc." (when comint-highlight-input (add-text-properties beg end '( font-lock-face comint-highlight-input + comint--fl-inhibit-fontification t front-sticky t ))) (unless comint-use-prompt-regexp ;; Give old user input a field property of `input', to @@ -4011,6 +4012,234 @@ This function is intended to be included as an entry of (cons (point-marker) (match-string-no-properties 1 text))))) +;;; Input fontification through an indirect buffer +;;============================================================================ +;; +;; Modes derived from `comint-mode' can set up fontification input +;; text with the help of an indirect buffer whose major mode and +;; font-lock settings are set accordingly. + +(defvar-local comint-indirect-setup-function nil + "Function to set up an indirect comint fontification buffer. +This function is called by `comint-indirect-buffer' with zero +arguments after making an indirect buffer. It is usually set to +a major-mode command whose font-locking is desired for input +text. In order to prevent possible mode hooks from running, the +variable `delay-mode-hooks' is set to t prior to calling this +function and `change-major-mode-hook' along with +`after-change-major-mode-hook' are bound to nil.") + +(defcustom comint-indirect-setup-hook nil + "Hook run after setting up an indirect comint fontification buffer. +It is run after the indirect buffer is set up for fontification +of input regions." + :group 'comint + :type 'hook + :version "29.1") + +(defvar-local comint--indirect-buffer nil + "Indirect buffer used for input fontification.") + +(defvar-local comint--fl-saved-jit-lock-contextually nil) + +(define-minor-mode comint-fl-mode + "Enable input fontification in the current comint buffer. +This minor mode is useful if the current major mode derives from +`comint-mode' and if `comint-indirect-setup-function' is set. +Comint modes that support input fontification usually set this +variable buffer-locally to a major-mode command whose +font-locking is desired for input text. + +Input text is fontified through an indirect buffer created with +`comint-indirect-buffer', which see. + +This function signals an error if `comint-use-prompt-regexp' is +non-nil. Input fontification isn't compatible with this +setting." + :lighter nil + (if comint-fl-mode + (let ((success nil)) + (unwind-protect + (progn + (comint--fl-on) + (setq success t)) + (unless success + (setq comint-fl-mode nil) + (comint--fl-off)))) + (comint--fl-off))) + +(defun comint--fl-on () + "Enable input fontification in the current comint buffer." + (comint--fl-off) + + (when comint-use-prompt-regexp + (error + "Input fontification is incompatible with `comint-use-prompt-regexp'")) + + (add-function :around (local 'font-lock-fontify-region-function) + #'comint--fl-fontify-region) + ;; `before-change-functions' are only run in the current buffer and + ;; not in its indirect buffers, which means that we must manually + ;; flush ppss cache + (add-hook 'before-change-functions + #'comint--fl-ppss-flush-indirect 99 t) + + ;; Set up contextual fontification + (unless (booleanp jit-lock-contextually) + (setq comint--fl-saved-jit-lock-contextually + jit-lock-contextually) + (setq-local jit-lock-contextually t) + (when jit-lock-mode + (jit-lock-mode t)))) + +(defun comint--fl-off () + "Disable input fontification in the current comint buffer." + (remove-function (local 'font-lock-fontify-region-function) + #'comint--fl-fontify-region) + (remove-hook 'before-change-functions + #'comint--fl-ppss-flush-indirect t) + + ;; Reset contextual fontification + (when comint--fl-saved-jit-lock-contextually + (setq-local jit-lock-contextually + comint--fl-saved-jit-lock-contextually) + (setq comint--fl-saved-jit-lock-contextually nil) + (when jit-lock-mode + (jit-lock-mode t))) + + (font-lock-flush)) + +(defun comint--fl-ppss-flush-indirect (beg &rest rest) + (when-let ((buf (comint-indirect-buffer t))) + (with-current-buffer buf + (when (memq #'syntax-ppss-flush-cache before-change-functions) + (apply #'syntax-ppss-flush-cache beg rest))))) + +(defun comint--fl-fontify-region (fun beg end verbose) + "Fontify process output and user input in the current comint buffer. +First, highlight the region between BEG and END using FUN. Then +highlight only the input text in the region with the help of an +indirect buffer. VERBOSE is passed to the fontify-region +functions. Skip fontification of input regions with non-nil +`comint--fl-inhibit-fontification' text property." + (pcase (funcall fun beg end verbose) + (`(jit-lock-bounds ,beg1 . ,end1) + (setq beg beg1 end end1))) + (pcase + (let ((min (point-min)) + (max (point-max))) + (with-current-buffer (comint-indirect-buffer) + (narrow-to-region min max) + (comint--intersect-regions + nil (lambda (beg end) + (unless (get-text-property + beg 'comint--fl-inhibit-fontification) + (font-lock-fontify-region beg end verbose))) + beg end))) + (`((jit-lock-bounds ,beg1 . ,_) . (jit-lock-bounds ,_ . ,end1)) + (setq beg (min beg beg1)) + (setq end (max end end1)))) + + `(jit-lock-bounds ,beg . ,end)) + +(defun comint--intersect-regions (fun-output fun-input beg end) + "Iterate over comint output and input regions between BEG and END. +Divide the region specified by BEG and END into smaller regions +that cover either process output (its `field' property is `output') +or input (all remaining text). Interchangeably call FUN-OUTPUT +on each output region, and FUN-INPUT on each input region. + +FUN-OUTPUT and FUN-INPUT are passed two arguments, the beginning +and end of the smaller region. Before calling each function, +narrow the buffer to the surrounding process output or input. You +can also pass nil as either function to skip its corresponding +regions. + +Return a cons cell of return values of the first and last +function called, or nil, if no function was called (if BEG = END)." + (let ((beg1 beg) + (end1 (copy-marker nil t)) + (return-beg nil) (return-end nil) + (is-output (eq (get-text-property beg 'field) 'output))) + (setq end (copy-marker end t)) + + (while (< beg1 end) + (set-marker + end1 (or (if is-output + (text-property-not-all beg1 end 'field 'output) + (text-property-any beg1 end 'field 'output)) + end)) + (when-let ((fun (if is-output fun-output fun-input))) + (save-restriction + (let ((beg2 beg1) + (end2 end1)) + (when (= beg2 beg) + (setq beg2 (field-beginning beg2))) + (when (= end2 end) + (setq end2 (field-end end2))) + ;; Narrow to the whole field surrounding the region + (narrow-to-region beg2 end2)) + (setq return-end (list (funcall fun beg1 + (marker-position end1))))) + (unless return-beg + (setq return-beg return-end))) + (setq beg1 (marker-position end1)) + (setq is-output (not is-output))) + + (set-marker end nil) + (set-marker end1 nil) + (when return-beg + (cons (car return-beg) (car return-end))))) + +(defun comint-indirect-buffer (&optional no-create) + "Return an indirect comint fontification buffer. +If an indirect buffer for the current buffer already exists, +return it, otherwise create it first and set it up by calling +`comint-indirect-setup-function' with zero arguments, turning on +font-lock, and running `comint-indirect-setup-hook'. This setup +happens with `delay-mode-hooks' set to t in order to prevent +possible SETUP-FUN's mode hooks from running. + +If an indirect buffer doesn't exist and NO-CREATE is non-nil, +return nil." + (or + comint--indirect-buffer + (unless no-create + (let ((setup-hook + (if (local-variable-p 'comint-indirect-setup-hook) + (list comint-indirect-setup-hook))) + (setup-fun comint-indirect-setup-function)) + + (add-hook 'change-major-mode-hook #'comint--indirect-cleanup + nil t) + + (with-current-buffer + (setq comint--indirect-buffer + (make-indirect-buffer + (current-buffer) + (generate-new-buffer-name + (concat " " (buffer-name) "-comint-indirect")))) + (setq-local delay-mode-hooks t) + (when setup-fun + (let ((change-major-mode-hook nil) + (after-change-major-mode-hook nil)) + (funcall setup-fun))) + (setq-local font-lock-dont-widen t) + (setq-local font-lock-support-mode nil) + (font-lock-mode) + (when setup-hook + (setq-local comint-indirect-setup-hook + (car setup-hook))) + (run-hooks 'comint-indirect-setup-hook)) + comint--indirect-buffer)))) + +(defun comint--indirect-cleanup () + (when comint--indirect-buffer + (kill-buffer comint--indirect-buffer) + (setq comint--indirect-buffer nil))) + + + ;;; Converting process modes to use comint mode ;;============================================================================ ;; The code in the Emacs 19 distribution has all been modified to use comint -- 2.39.2