|
|
;;; poly-lock.el --- Font lock sub-system for polymode -*- lexical-binding: t -*-;;;; Copyright (C) 2013-2019, Vitalie Spinu;; Author: Vitalie Spinu;; URL: https://github.com/polymode/polymode;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; This file is *NOT* part of GNU Emacs.;;;; 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Commentary:;;;;; Code:
;; FONT-LOCK COMPONENTS:;;;; All * functions are lazy in poly-lock and jit-lock because they just mark;; 'fontified nil.;;;; fontification-functions -> jit-lock-function / poly-lock-function;; font-lock-ensure -> font-lock-ensure-function -> jit-lock-fontify-now/poly-lock-fontify-now;; *font-lock-flush -> font-lock-flush-function -> jit-lock-refontify / poly-lock-flush;; *font-lock-fontify-buffer -> font-lock-fontify-buffer-function -> jit-lock-refontify / poly-lock-flush;; font-lock-fontify-region -> font-lock-fontify-region-function -> font-lock-default-fontify-region;; font-lock-unfontify-region -> font-lock-unfontify-region-function -> font-lock-default-unfontify-region;; font-lock-unfontify-buffer -> font-lock-unfontify-buffer-function -> font-lock-default-unfontify-buffer;;;; Jit-lock components:;; fontification-functions (called by display engine);; --> jit-lock-function;; --> jit-lock-fontify-now (or deferred through timer/text-properties);; --> jit-lock--run-functions;; --> jit-lock-functions (font-lock-fontify-region bug-reference-fontify etc.);;;;;; Poly-lock components:;; fontification-functions;; --> poly-lock-function;; --> poly-lock-fontify-now;; --> jit-lock-fontify-now;; ...;;;; `font-lock-mode' call graph:;; -> font-lock-function <---- replaced by `poly-lock-mode';; -> font-lock-default-function;; -> font-lock-mode-internal;; -> font-lock-turn-on-thing-lock;; -> font-lock-turn-on-thing-lock;; -> (setq font-lock-flush-function jit-lock-refontify);; -> (setq font-lock-ensure-function jit-lock-fontify-now);; -> (setq font-lock-fontify-buffer-function jit-lock-refontify);; -> (jit-lock-register #'font-lock-fontify-region);; -> (add-hook 'jit-lock-functions #'font-lock-fontify-region nil t);; -> jit-lock-mode
(require 'jit-lock)(require 'polymode-core)
(defvar poly-lock-allow-fontification t)(defvar poly-lock-allow-background-adjustment t)(defvar poly-lock-fontification-in-progress nil)(defvar poly-lock-defer-after-change t)(defvar-local poly-lock-mode nil)
(eval-when-compile (defmacro with-buffer-prepared-for-poly-lock (&rest body) "Execute BODY in current buffer, overriding several variables.
Preserves the `buffer-modified-p' state of the current buffer."
(declare (debug t)) `(let ((inhibit-point-motion-hooks t)) (with-silent-modifications ,@body))))
;; FIXME: Can this hack be avoided if poly-lock is registered in;; `font-lock-support-mode'?(defun poly-lock-no-jit-lock-in-polymode-buffers (fun arg) "Don't activate FUN in `polymode' buffers.
When not in polymode buffers apply FUN to ARG."
(unless polymode-mode (funcall fun arg)))(pm-around-advice 'jit-lock-mode #'poly-lock-no-jit-lock-in-polymode-buffers);; see the comment in pm--mode-setup for these(pm-around-advice 'font-lock-fontify-region #'polymode-inhibit-during-initialization)(pm-around-advice 'font-lock-fontify-buffer #'polymode-inhibit-during-initialization)(pm-around-advice 'font-lock-ensure #'polymode-inhibit-during-initialization)
(defun poly-lock-mode (arg) "This is the value of `font-lock-function' in all polymode buffers.
Mode activated when ARG is positive; happens when font-lock isswitched on."
(unless polymode-mode (error "Calling `poly-lock-mode' in a non-polymode buffer (%s)" (current-buffer)))
(setq poly-lock-mode arg)
(if arg (progn ;; a lot of the following is inspired by what jit-lock does in ;; `font-lock-turn-on-thing-lock'
(setq-local font-lock-support-mode 'poly-lock-mode) (setq-local font-lock-dont-widen t)
;; Re-use jit-lock registration. Some minor modes (adaptive-wrap) ;; register extra functionality. [Unfortunately `jit-lock-register' ;; calls `jit-lock-mode' which we don't want. Hence the advice. TOTHINK: ;; Simply add-hook to `jit-lock-functions'?] (jit-lock-register 'font-lock-fontify-region)
;; don't allow other functions (setq-local fontification-functions '(poly-lock-function))
(setq-local font-lock-flush-function 'poly-lock-flush) (setq-local font-lock-fontify-buffer-function 'poly-lock-flush) (setq-local font-lock-ensure-function 'poly-lock-fontify-now)
;; There are some more, jit-lock doesn't change those, neither do we: ;; font-lock-unfontify-region-function (defaults to font-lock-default-unfontify-region) ;; font-lock-unfontify-buffer-function (defualts to font-lock-default-unfontify-buffer)
;; Don't fontify eagerly (and don't abort if the buffer is large). NB: ;; `font-lock-flush' is not triggered if this is nil. (setq-local font-lock-fontified t)
;; Now we can finally call `font-lock-default-function' because ;; `font-lock-support-mode' is set to "unrecognizible" value, only core ;; font-lock setup happens. (font-lock-default-function arg)
;; Must happen after call to `font-lock-default-function' (remove-hook 'after-change-functions 'font-lock-after-change-function t) (remove-hook 'after-change-functions 'jit-lock-after-change t) (add-hook 'after-change-functions 'poly-lock-after-change nil t)
;; Reusing jit-lock var becuase modes populate it directly. We are using ;; this in `poly-lock-after-change' below. Taken from `jit-lock ;; initialization. (add-hook 'jit-lock-after-change-extend-region-functions 'font-lock-extend-jit-lock-region-after-change nil t))
(remove-hook 'after-change-functions 'poly-lock-after-change t) (remove-hook 'fontification-functions 'poly-lock-function t)) (current-buffer))
(defvar poly-lock-chunk-size 2500 "Poly-lock fontifies chunks of at most this many characters at a time.")
(defun poly-lock-function (start) "The only function in `fontification-functions' in polymode buffers.
This is the entry point called by the display engine. START isdefined in `fontification-functions'. This function has the samescope as `jit-lock-function'."
(unless pm-initialization-in-progress (if (and poly-lock-mode (not memory-full)) (unless (input-pending-p) (let ((end (min (or (text-property-any start (point-max) 'fontified t) (point-max)) (+ start poly-lock-chunk-size)))) (when (< start end) (poly-lock-fontify-now start end)))) (with-buffer-prepared-for-poly-lock (put-text-property start (point-max) 'fontified t)))))
(defun poly-lock-fontify-now (beg end &optional _verbose) "Polymode main fontification function.
Fontifies chunk-by chunk within the region BEG END."
(unless (or poly-lock-fontification-in-progress pm-initialization-in-progress) (let* ((font-lock-dont-widen t) ;; For now we fontify entire chunks at once. This simplicity is ;; warranted in multi-mode use cases. (font-lock-extend-region-functions nil) ;; Fontification in one buffer can trigger fontification in another ;; buffer. Particularly, this happens when new indirect buffers are ;; created and `normal-mode' triggers font-lock in those buffers. We ;; avoid this by dynamically binding ;; `poly-lock-fontification-in-progress' and un-setting ;; `fontification-functions' in case re-display suddenly decides to ;; fontify something else in other buffer. There are also font-lock ;; guards in pm--mode-setup. (poly-lock-fontification-in-progress t) (fontification-functions nil) (protect-host (or (with-current-buffer (pm-base-buffer) (eieio-oref pm/chunkmode 'protect-font-lock)) ;; HACK: Some inner modes use syntax-table text ;; property. If there is, for example, a comment ;; syntax somewhere in the body span, havoc is spelled ;; in font-lock-fontify-syntactically-region which ;; calls parse-partial-sexp. For example fortran block ;; in ../poly-markdown/tests/input/markdown.md. We do ;; our best and protect the host in such cases. (/= (next-single-property-change beg 'syntax-table nil end) end)))) (save-restriction (widen) (save-excursion
;; TEMPORARY HACK: extend to the next span boundary in code blocks ;; (needed because re-display fontifies by small regions) (let ((end-span (pm-innermost-span end))) (if (car end-span) (when (< (nth 1 end-span) end) (setq end (nth 2 end-span))) ;; in host extend to paragraphs as in poly-lock--extend-region (goto-char end) (when (search-forward "\n\n" nil t) (setq end (min (1- (point)) (nth 2 end-span))))))
;; Fontify the whole region in host first. It's ok for modes like ;; markdown, org and slim which understand inner mode chunks. (unless protect-host (let ((span (pm-innermost-span beg))) (when (or (null (pm-true-span-type span)) ;; in inner spans fontify only if region is bigger than the span (< (nth 2 span) end)) (with-current-buffer (pm-base-buffer) (with-buffer-prepared-for-poly-lock (when poly-lock-allow-fontification (put-text-property beg end 'fontified nil) ; just in case ;; (message "jlrf-host:%d-%d %s" beg end major-mode) (condition-case-unless-debug err ;; NB: Some modes fontify beyond the limits (org-mode). ;; We need a reliably way to detect the actual limit of ;; the fontification. (save-restriction (widen) (jit-lock--run-functions beg end)) (error (message "(jit-lock--run-functions %s %s) [UNPR HOST %s]: %s" beg end (current-buffer) (error-message-string err))))) (put-text-property beg end 'fontified t)))))) (pm-map-over-spans (lambda (span) (when (or (pm-true-span-type span) protect-host) (let ((sbeg (nth 1 span)) (send (nth 2 span))) ;; skip empty spans (with-buffer-prepared-for-poly-lock (when (> send sbeg) (if (not (and poly-lock-allow-fontification poly-lock-mode)) (put-text-property sbeg send 'fontified t) (let ((new-beg (max sbeg beg)) (new-end (min send end))) (put-text-property new-beg new-end 'fontified nil) ;; (message "jlrf:%d-%d %s" new-beg new-end major-mode) (condition-case-unless-debug err (if (eieio-oref pm/chunkmode 'protect-font-lock) (pm-with-narrowed-to-span span (jit-lock--run-functions new-beg new-end)) (jit-lock--run-functions new-beg new-end)) (error (message "(jit-lock--run-functions %s %s) [span %d %d %s] -> (font-lock-default-fontify-region %s %s): %s" new-beg new-end sbeg send (current-buffer) new-beg new-end (error-message-string err)))) ;; even if failed set to t (put-text-property new-beg new-end 'fontified t))) (when poly-lock-allow-background-adjustment (poly-lock-adjust-span-face span))))))) beg end)))) (current-buffer)))
(defun poly-lock-flush (&optional beg end) "Force refontification of the region BEG..END.
This function is placed in `font-lock-flush-function''"
(unless poly-lock-fontification-in-progress (let ((beg (or beg (point-min))) (end (or end (point-max)))) (with-buffer-prepared-for-poly-lock (save-restriction (widen) (pm-flush-span-cache beg end) (put-text-property beg end 'fontified nil))))))
(defvar jit-lock-start)(defvar jit-lock-end)(defun poly-lock--extend-region (beg end) "Our own extension function which runs first on BEG END change.
Assumes widen buffer. Sets `jit-lock-start' and `jit-lock-end'."
;; NB: Debug this like ;; (with-silent-modifications (insert "`") (poly-lock-after-change 65 66 0))
;; FIXME: this one extends to whole spans; not good. old span can disappear, ;; shrunk, extend etc
;; TOCHECK: Pretty surely we need not use 'no-cache here.
;; With differed after change, any function calling pm-innermost-span (mostly ;; syntax-propertize) will reset the spans, so the extension relying on ;; :pm-span cache will not detect the change. Use instead the especially setup ;; for this purpose :pm-span-old cache in poly-lock-after-change. (let* ((prop-name (if poly-lock-defer-after-change :pm-span-old :pm-span)) (old-beg (or (previous-single-property-change beg prop-name) (point-min))) (old-end (or (next-single-property-change end prop-name) (point-max))) ;; need this here before pm-innermost-span call (old-beg-obj (nth 3 (get-text-property old-beg prop-name))) (beg-span (pm-innermost-span beg 'no-cache)) (end-span (if (<= end (nth 2 beg-span)) beg-span (pm-innermost-span end 'no-cache))) (sbeg (nth 1 beg-span)) (send (nth 2 end-span)))
(if (< old-beg sbeg) (let ((new-beg-span (pm-innermost-span old-beg))) (if (eq old-beg-obj (nth 3 new-beg-span)) ; old-beg == (nth 1 new-beg-span) for sure ;; new span appeared within an old span, don't refontify the old part (common case) (setq jit-lock-start (min sbeg (nth 2 new-beg-span))) ;; wrong span shrunk to its correct size (rare or never) (setq jit-lock-start old-beg))) ;; refontify the entire new span (setq jit-lock-start sbeg))
;; (dbg (pm-format-span beg-span)) ;; always include head (when (and (eq (car beg-span) 'tail) (> jit-lock-start (point-min))) (setq jit-lock-start (nth 1 (pm-innermost-span (1- jit-lock-start))))) (when (and (eq (car beg-span) 'body) (> jit-lock-start (point-min))) (setq jit-lock-start (nth 1 (pm-innermost-span (1- jit-lock-start)))))
;; I think it's not possible to do better than this. When region is shrunk, ;; previous region could be incorrectly fontified even if the mode is ;; preserved due to wrong ppss (setq jit-lock-end (max send old-end))
;; Check if the type of following span changed (for example when ;; modification is in head of an auto-chunk). Do this repeatedly till no ;; change. [TOTHINK: Do we need similar extension backwards?] (let ((go-on t)) (while (and (< jit-lock-end (point-max)) go-on) (let ((ospan (get-text-property jit-lock-end prop-name)) (nspan (pm-innermost-span jit-lock-end 'no-cache))) ;; (dbg "N" (pm-format-span nspan)) ;; (dbg "O" (pm-format-span ospan)) ;; if spans have just been moved by buffer modification, stop (if ospan (if (and (eq (nth 3 nspan) (nth 3 ospan)) (= (- (nth 2 nspan) (nth 1 nspan)) (- (nth 2 ospan) (nth 1 ospan)))) (setq go-on nil) (setq jit-lock-end (nth 2 nspan) end-span nspan)) (setq go-on nil jit-lock-end (point-max))))))
;; This extension is needed because some host modes (org) either don't ;; fontify the head correctly when tail is not there or worse, fontify ;; larger spans than asked for. It's mostly for unprotected hosts, but ;; doing it here for all cases to err on the safe side.
;; always include body of the head (when (and (eq (car end-span) 'head) (< jit-lock-end (point-max))) (setq end-span (pm-innermost-span jit-lock-end) jit-lock-end (nth 2 end-span)))
;; always include tail (when (and (eq (car end-span) 'body) (< jit-lock-end (point-max))) (setq jit-lock-end (nth 2 (pm-innermost-span jit-lock-end)) end-span (pm-innermost-span jit-lock-end)))
;; Temporary hack for large host mode chunks - narrow to empty lines (when (> (* 2 poly-lock-chunk-size) (- jit-lock-end jit-lock-start))
(when (eq (car beg-span) nil) (let ((tbeg (min beg (nth 2 beg-span)))) (when (> (- tbeg jit-lock-start) poly-lock-chunk-size) (goto-char (- tbeg poly-lock-chunk-size)) (when (search-backward "\n\n" nil t) (setq jit-lock-start (max jit-lock-start (1+ (point))))))))
(when (eq (car end-span) nil) (let ((tend (max end (nth 1 end-span)))) (when (> (- jit-lock-end tend) poly-lock-chunk-size) (goto-char (+ tend poly-lock-chunk-size)) (when (search-forward "\n\n" nil t) (setq jit-lock-end (min jit-lock-end (1- (point)))))))))
(cons jit-lock-start jit-lock-end)))
;; (defun poly-lock--jit-lock-extend-region-span (span old-len);; "Call `jit-lock-after-change-extend-region-functions' protected to SPAN.;; Extend `jit-lock-start' and `jit-lock-end' by side effect.;; OLD-LEN is passed to the extension function.";; ;; FIXME: for multi-span regions this function seems to reset;; ;; jit-lock-start/end to spans limits;; (let ((beg jit-lock-start);; (end jit-lock-end));; (let ((sbeg (nth 1 span));; (send (nth 2 span)));; (when (or (> beg sbeg) (< end send));; (pm-with-narrowed-to-span span;; (setq jit-lock-start (max beg sbeg);; jit-lock-end (min end send));; (condition-case err;; (progn;; ;; set jit-lock-start and jit-lock-end by side effect;; (run-hook-with-args 'jit-lock-after-change-extend-region-functions;; jit-lock-start jit-lock-end old-len));; (error (message "(after-change-extend-region-functions %s %s %s) -> %s";; jit-lock-start jit-lock-end old-len;; (error-message-string err))));; ;; FIXME: this is not in the right buffer, we need to do it in the;; ;; original buffer.;; (setq jit-lock-start (min beg (max jit-lock-start sbeg));; jit-lock-end (max end (min jit-lock-end send))));; (cons jit-lock-start jit-lock-end)))))
(defvar-local poly-lock--timer nil)(defvar-local poly-lock--beg-change most-positive-fixnum)(defvar-local poly-lock--end-change most-negative-fixnum)(defun poly-lock--after-change-internal (buffer _old-len) (when (buffer-live-p buffer) (with-current-buffer buffer (setq poly-lock--timer nil) ;; FIXME: timers can overlap; remove this check with global timer (when (> poly-lock--end-change 0) (with-buffer-prepared-for-poly-lock (save-excursion (save-restriction (widen) (let ((beg poly-lock--beg-change) (end (min (point-max) poly-lock--end-change))) (setq poly-lock--beg-change most-positive-fixnum poly-lock--end-change most-negative-fixnum) (save-match-data (poly-lock--extend-region beg end) ;; no need for 'no-cache; poly-lock--extend-region re-computed the spans
;; FIXME: currently poly-lock--extend-region extends to whole ;; spans, which could get crazy for very large chunks, but ;; seems to work really well with the deferred after-change ;; hook. So the following jit-lock extensions are not needed ;; and probably even harm.
;; This extension hooks are run for major-mode's syntactic ;; hacks mostly and not that much for actual extension. For ;; example, markdown can syntactically propertize in this hook ;; markdown-font-lock-extend-region-function. Call on the ;; entire region host hooks to account for such patterns. ;; (let ((hostmode (oref pm/polymode -hostmode))) ;; (unless (eieio-oref hostmode 'protect-font-lock) ;; (with-current-buffer (pm-base-buffer) ;; (run-hook-with-args 'jit-lock-after-change-extend-region-functions ;; beg end old-len) ;; (setq beg jit-lock-start ;; end jit-lock-end))) ;; (let ((bspan (pm-innermost-span jit-lock-start))) ;; ;; FIXME: these are currently always protected and set ;; ;; jit-lock-end/start in their own buffers, not the buffer ;; ;; which invoked the after-change-hook ;; (unless (eq (nth 3 bspan) hostmode) ;; (poly-lock--jit-lock-extend-region-span bspan old-len)) ;; (when (< (nth 2 bspan) jit-lock-end) ;; (let ((espan (pm-innermost-span jit-lock-end))) ;; (unless (eq (nth 3 espan) hostmode) ;; (poly-lock--jit-lock-extend-region-span espan old-len))))) ;; )
;; ;; Why is this still needed? poly-lock--extend-region re-computes the spans ;; (pm-flush-span-cache jit-lock-start jit-lock-end) ;; (dbg (cb) jit-lock-start jit-lock-end) ;; (put-text-property jit-lock-end jit-lock-end :poly-lock-refontify nil) (put-text-property jit-lock-start jit-lock-end 'fontified nil))))))))))
(defun poly-lock-after-change (beg end old-len) "Mark changed region with 'fontified nil.
Extend the region to spans which need to be updated. BEG, END andOLD-LEN are as in `after-change-functions'. When`poly-lock-defer-after-change' is non-nil (the default), run fontification"
(when (and poly-lock-mode pm-allow-after-change-hook (not memory-full)) ;; Extension is slow but after-change functions can be called in rapid ;; succession (#200 with string-rectangle on which combine-change-calls is ;; of little help). Thus we do that in a timer. (when (timerp poly-lock--timer) ;; FIXME: Instead of local timer, make a global one iterating over ;; relevant buffers (cancel-timer poly-lock--timer)) (if poly-lock-defer-after-change (progn (with-silent-modifications ;; don't re-fontify before we extend (put-text-property beg end 'fontified t) (setq poly-lock--beg-change (min beg end poly-lock--beg-change) poly-lock--end-change (max beg end poly-lock--end-change)) ;; between this call and deferred extension pm-inner-span can be ;; called, so we cache a few :pm-span properties around beg/end (poly-lock--cache-pm-span-property beg end)) (setq-local poly-lock--timer (run-at-time 0.05 nil #'poly-lock--after-change-internal (current-buffer) old-len))) (setq poly-lock--beg-change beg poly-lock--end-change end) (poly-lock--after-change-internal (current-buffer) old-len))))
(defun poly-lock--cache-pm-span-property (beg end) ;; cache one previous and 5 forward spans (let ((new-beg (or (previous-single-property-change beg :pm-span) (point-min)))) (put-text-property new-beg beg :pm-span-old (get-text-property new-beg :pm-span))) (let ((i 5)) (while (and (< 0 i) (< end (point-max))) (let ((new-end (or (next-single-property-change end :pm-span) (point-max)))) (put-text-property new-end end :pm-span-old (get-text-property (1- new-end) :pm-span)) (setq end new-end i (1- i))))))
(defun poly-lock--adjusted-background (prop) ;; if > lighten on dark backgroun. Oposite on light. (color-lighten-name (face-background 'default) (if (eq (frame-parameter nil 'background-mode) 'light) (- prop) ;; darken prop)))
(declare-function pm-get-adjust-face "polymode-methods")(defvar poly-lock--extra-span-props (when (fboundp 'set-face-extend) (list :extend t)))(defun poly-lock-adjust-span-face (span) "Adjust 'face property of SPAN..
How adjustment is made is defined in :adjust-face slot of theSPAN's chunkmode."
(interactive "r") (let ((face (pm-get-adjust-face (nth 3 span) (car span)))) (let ((face (if (numberp face) (unless (= face 0) (list (append (list :background (poly-lock--adjusted-background face)) poly-lock--extra-span-props))) face))) (when face (font-lock-append-text-property (nth 1 span) (nth 2 span) 'face face)))))
(provide 'poly-lock);;; poly-lock.el ends here
|
