diff options
| -rw-r--r-- | emacs/inits/03-miscload.el | 4 | ||||
| -rw-r--r-- | emacs/scripts/treesit-predicate-rewrite.el | 342 |
2 files changed, 1 insertions, 345 deletions
diff --git a/emacs/inits/03-miscload.el b/emacs/inits/03-miscload.el index f8ad9ae..87c0b4f 100644 --- a/emacs/inits/03-miscload.el +++ b/emacs/inits/03-miscload.el @@ -1,10 +1,8 @@ -;; Time-stamp: <2026-04-23 12h47 BST (anker)> +;; Time-stamp: <2026-05-22 09h04 PDT (7bca6747)> (use-package siege-mode :load-path "~/.config/emacs/scripts/siege-mode/") -(load "~/.config/emacs/scripts/treesit-predicate-rewrite" nil nil nil t) - ;; (use-package maxima ;; :defer t ;; :config (setq imaxima-use-maxima-mode-flag t)) diff --git a/emacs/scripts/treesit-predicate-rewrite.el b/emacs/scripts/treesit-predicate-rewrite.el deleted file mode 100644 index 0840f62..0000000 --- a/emacs/scripts/treesit-predicate-rewrite.el +++ /dev/null @@ -1,342 +0,0 @@ -;;; treesit-predicate-rewrite.el --- -*- lexical-binding: t -*- -;; -;; Description: Generic workaround for Emacs bug#79687 -- strip -;; tree-sitter query predicates at `treesit-font-lock-rules' call -;; time, replacing them with capture-name-is-a-function fontifiers. -;; Author: Michael Olson -;; -;; The contents of this file may be used, distributed, and modified -;; without restriction. - -;;; Commentary: - -;; Emacs 30.2 serialises `:match' / `:equal' / `:pred' s-expr -;; predicates to `#match' / `#equal' / `#pred' (no trailing `?'), and -;; libtree-sitter >=0.26 rejects those at query-parse time. The -;; upstream fix (commit b0143530 on master) is slated for Emacs 31 and -;; has not been backported to emacs-30 as of 30.2. On Arch we ship -;; libtree-sitter.so.0.26, so every mode whose `treesit-font-lock-rules' -;; uses `:match' fails the first time it hits tree-sitter. `#match?' -;; doesn't work either: Emacs 30.2's own predicate dispatcher hard-codes -;; bare `match'/`equal'/`pred' and rejects `match?'/`equal?'/`pred?' at -;; eval time, so no string-level rewrite can satisfy both sides. -;; -;; Instead, intercept `treesit-font-lock-rules' via `:filter-args' -;; advice and rewrite its argument plist, replacing predicate-gated -;; patterns with capture-name-is-a-function fontifiers. The resulting -;; query contains NO predicates, so libtree-sitter is happy; the -;; fontifier applies the face only when the node satisfies the -;; original predicate, so the semantics are preserved. -;; -;; `treesit-range-rules' (used by e.g. js.el for JSDoc parser embed) -;; gets the same advice, but range captures are scratch names rather -;; than faces, so predicates there always strip cleanly (Case C). The -;; downside is slight over-matching (e.g. JSDoc embed attaches to all -;; comments, not just `/**' ones); benign in practice. -;; -;; Handled cases (in order of detection): -;; -;; A. ((NODE) @FACE (:match REGEX @FACE)) -;; -> ((NODE) @my-ts-rw--fn-FACE-HASH), and the fontifier applies -;; FACE when the node text matches REGEX. Also handles nested -;; captures like ((X Y: (Z) @FACE) (:match ... @FACE)). -;; -;; B. (((NODE) @scratch (:match REGEX @scratch)) @FACE) -;; Outer-group-wraps-inner-scratch form (used by ruby-ts-mode -;; builtins). Semantically equivalent to Case A after flattening, -;; handled the same way. -;; -;; C. Predicate where target capture is not the face capture, e.g., -;; elixir-ts-mode's (call (identifier) @_fn (:match "assert" @_fn) -;; arguments: ...). Cannot be flattened into a single fontifier -;; safely; the predicate is silently stripped (set -;; `my-ts-rw-verbose' non-nil to log strips). This will -;; over-fontify, which is a minor visual regression. elixir-ts-mode -;; uses this pattern heavily and is best left alone -- callers -;; should avoid loading it with this advice active, OR accept -;; the over-fontification. -;; -;; :equal (@cap "literal") is handled for Case A/B; :pred is not -;; (would require re-invoking the user's fn) and is treated as Case C. -;; -;; Removal plan: delete this whole file and its `load' in -;; `shared-init.el' once we upgrade to an Emacs that carries the -;; bug#79687 fix (Emacs 31+, or a backport landing in a future 30.x -;; point release). - -;;; Code: - -(require 'cl-lib) -(require 'seq) - -(defvar my-ts-rw--fontifiers (make-hash-table :test 'equal) - "Cache: (KIND FACE . DATA) -> interned fontifier symbol. -KIND is `regex' or `equal'. DATA is the regex string or literal. -Prevents symbol churn when the same rewrite is computed repeatedly -across reloads.") - -(defvar my-ts-rw-verbose nil - "When non-nil, log each predicate rewrite or strip via `message'. -Off by default so Case C over-fontification notes don't spam the -echo area at mode-load time.") - -;;;; Entry points: :filter-args advice on query-building functions - -(define-advice treesit-font-lock-rules - (:filter-args (args) my-ts-rw-rewrite) - "Rewrite tree-sitter predicates into fontifier captures. -Workaround for Emacs bug#79687 / libtree-sitter 0.26 strict predicates." - (condition-case err - (my-ts-rw--rewrite-args args) - (error - (message "treesit-predicate-rewrite: rewrite failed, passing through: %S" err) - args))) - -(define-advice treesit-range-rules - (:filter-args (args) my-ts-rw-rewrite) - "Strip tree-sitter predicates from range rules. -Range-rule captures are scratch names, not faces, so predicates -always fall into Case C (strip). The net effect for e.g. js.el's -JSDoc-begin predicate is that the embedded parser attaches to all -comments rather than just `/**' comments, which is harmless but -may cost a little extra parser work on non-doc comments." - (condition-case err - (my-ts-rw--rewrite-args args) - (error - (message "treesit-predicate-rewrite: range-rules rewrite failed, passing through: %S" err) - args))) - -(define-advice treesit-query-compile - (:filter-args (args) my-ts-rw-rewrite) - "Strip/rewrite predicates from queries compiled directly. -Catches call sites that bypass `treesit-font-lock-rules' and -`treesit-range-rules' -- e.g. c-ts-mode's `c-ts-mode--emacs-c-range-query' -defvar which calls `treesit-query-compile' with an s-expression -containing `:match'. Predicates on face targets become fontifiers; -others are stripped." - (condition-case err - (pcase args - (`(,lang ,query . ,rest) - (cons lang - (cons (if (listp query) - (my-ts-rw--rewrite-query-list query) - query) - rest))) - (_ args)) - (error - (message "treesit-predicate-rewrite: query-compile rewrite failed, passing through: %S" err) - args))) - -;;;; Arg-plist walker - -(defun my-ts-rw--rewrite-args (args) - "Walk ARGS (the plist-style argument list of `treesit-font-lock-rules'). -Rewrite every query-list value; leave :KEYWORD/VALUE pairs as-is." - (let ((result nil) - (tail args)) - (while tail - (let ((item (car tail))) - (cond - ((keywordp item) - (push item result) - (push (cadr tail) result) - (setq tail (cddr tail))) - (t - (push (my-ts-rw--rewrite-query-list item) result) - (setq tail (cdr tail)))))) - (nreverse result))) - -(defun my-ts-rw--rewrite-query-list (queries) - "Rewrite each top-level query in QUERIES. -QUERIES is a list of queries, or an already-compiled query object / -string; non-list inputs are returned unchanged." - (if (and (listp queries) (not (null queries))) - (mapcar #'my-ts-rw--walk queries) - queries)) - -;;;; Per-query recursive walker - -(defun my-ts-rw--walk (form) - "Rewrite predicates within FORM recursively." - (cond - ((not (consp form)) form) - ;; Don't descend into a predicate form itself -- its children - ;; shouldn't be interpreted as predicate-containing queries. - ((my-ts-rw--predicate-p form) form) - (t - ;; Case B must be detected at this level BEFORE recursing into - ;; children; otherwise the bottom-up recursion would strip the - ;; inner predicate under Case C and we'd over-fontify. - (let ((b (my-ts-rw--try-case-b form))) - (if b - (my-ts-rw--walk b) - ;; Bottom-up: recurse children first, then handle Case A at - ;; this level so inner predicates are resolved before outer. - (let ((children (mapcar #'my-ts-rw--walk form))) - (my-ts-rw--rewrite-case-a children))))))) - -;;;; Case B: (((NODE) @scratch (:match REGEX @scratch)) @FACE) - -(defun my-ts-rw--try-case-b (form) - "If FORM matches Case B, return the pre-rewrite flattened form. -Otherwise return nil. The returned form still has the inner -predicate in place; Case A handling will lift it." - (when (and (consp form) - (= (length form) 2) - (consp (car form)) - (my-ts-rw--face-symbol-p (cadr form))) - (let* ((group (car form)) - (outer-face-sym (cadr form)) - (predicates (seq-filter #'my-ts-rw--predicate-p group))) - (when (= (length predicates) 1) - (let* ((pred (car predicates)) - (target (my-ts-rw--predicate-target pred))) - (when (and target - (my-ts-rw--cap-symbol-p target) - ;; Case B is only safe if the inner scratch capture - ;; tags the same node the outer face wraps -- if - ;; target appears as a direct capture marker inside - ;; group (not nested inside a named-child pattern), - ;; flattening is semantically sound. - (my-ts-rw--cap-directly-on-root-of-p group target) - ;; Avoid double-rewriting if target already is a face - ;; (that's Case A in disguise, handled below). - (not (my-ts-rw--face-symbol-p target))) - ;; Substitute the inner scratch capture with the outer - ;; face symbol and drop the outer wrapping. Case A will - ;; then recognise the predicate + face pairing. - (my-ts-rw--replace-capture-in-tree - group target outer-face-sym))))))) - -(defun my-ts-rw--cap-directly-on-root-of-p (group cap-sym) - "Non-nil if CAP-SYM appears as a top-level capture marker in GROUP. -Specifically, CAP-SYM is a direct element of GROUP that follows the -node pattern (i.e., `(NODE CAP-SYM ...)'). This is the signature of -the inner scratch in Case B." - (and (consp group) - (memq cap-sym group) - t)) - -;;;; Case A: ((...@FACE...) (:match REGEX @FACE)) - -(defun my-ts-rw--rewrite-case-a (children) - "Process top-level predicates among CHILDREN. -Returns the rewritten list with predicates stripped and capture -symbols rewritten to fontifier symbols where applicable." - (if (not (cl-some #'my-ts-rw--predicate-p children)) - children - (let ((result children)) - (dolist (pred (seq-filter #'my-ts-rw--predicate-p children)) - (let ((target (my-ts-rw--predicate-target pred))) - (cond - ((and target (my-ts-rw--face-symbol-p target)) - (let* ((face (my-ts-rw--cap-to-face target)) - (fontifier (my-ts-rw--try-make-fontifier pred face))) - (if fontifier - (setq result - (my-ts-rw--replace-capture-in-tree - result target (my-ts-rw--face-to-cap fontifier))) - (when my-ts-rw-verbose - (message "treesit-predicate-rewrite: unsupported predicate %S (face target %s); stripping" - (car pred) target))))) - (t - (when my-ts-rw-verbose - (message "treesit-predicate-rewrite: stripping non-face-target predicate %S" - pred)))))) - (seq-remove #'my-ts-rw--predicate-p result)))) - -;;;; Fontifier factory - -(defun my-ts-rw--try-make-fontifier (predicate face) - "Build a fontifier applying FACE when PREDICATE is satisfied. -Return the fontifier symbol, or nil if PREDICATE isn't supported." - (pcase predicate - (`(:match ,(and regex (pred stringp)) ,(pred my-ts-rw--cap-symbol-p)) - (my-ts-rw--intern-fontifier - (list 'regex face regex) - (lambda (node override start end &rest _) - (when (string-match-p regex (treesit-node-text node t)) - (treesit-fontify-with-override - (treesit-node-start node) (treesit-node-end node) - face override start end))))) - (`(:equal ,a ,b) - (let ((literal (cond ((and (stringp a) (my-ts-rw--cap-symbol-p b)) a) - ((and (my-ts-rw--cap-symbol-p a) (stringp b)) b)))) - (when literal - (my-ts-rw--intern-fontifier - (list 'equal face literal) - (lambda (node override start end &rest _) - (when (equal (treesit-node-text node t) literal) - (treesit-fontify-with-override - (treesit-node-start node) (treesit-node-end node) - face override start end))))))) - (_ nil))) - -(defun my-ts-rw--intern-fontifier (key fn) - "Return a fontifier symbol for KEY, defining it to FN on first sight. -Subsequent calls with an `equal' KEY return the cached symbol and do -not redefine it, so reloading this file does not leak symbols." - (or (gethash key my-ts-rw--fontifiers) - (let* ((face (cadr key)) - (sym (intern (format "my-ts-rw--fn-%s-%08x" - face (abs (sxhash-equal key)))))) - (defalias sym fn) - (puthash key sym my-ts-rw--fontifiers) - sym))) - -;;;; Predicate / capture helpers - -(defun my-ts-rw--predicate-p (form) - "Non-nil if FORM is a tree-sitter predicate form." - (and (consp form) - (memq (car form) '(:match :equal :pred)))) - -(defun my-ts-rw--predicate-target (predicate) - "Return the capture symbol PREDICATE tests, or nil." - (pcase (car predicate) - (:match - (let ((tail (car (last predicate)))) - (and (my-ts-rw--cap-symbol-p tail) tail))) - (:equal - (cl-loop for arg in (cdr predicate) - when (my-ts-rw--cap-symbol-p arg) return arg)) - (:pred - (cl-loop for arg in (cddr predicate) - when (my-ts-rw--cap-symbol-p arg) return arg)))) - -(defun my-ts-rw--cap-symbol-p (x) - "Non-nil if X is a tree-sitter capture symbol (starts with `@')." - (and (symbolp x) - (let ((name (symbol-name x))) - (and (> (length name) 1) (eq (aref name 0) ?@))))) - -(defun my-ts-rw--face-symbol-p (cap-sym) - "Non-nil if CAP-SYM names a font-lock face. -Accepts any symbol starting with `@' whose trailing name is either -a defined face or begins with `font-lock-'." - (and (my-ts-rw--cap-symbol-p cap-sym) - (let ((stripped (substring (symbol-name cap-sym) 1))) - (or (facep (intern-soft stripped)) - (string-prefix-p "font-lock-" stripped))))) - -(defun my-ts-rw--cap-to-face (cap-sym) - "Return the face symbol underlying capture symbol CAP-SYM." - (intern (substring (symbol-name cap-sym) 1))) - -(defun my-ts-rw--face-to-cap (face-sym) - "Return the capture symbol (`@face-sym') for FACE-SYM." - (intern (format "@%s" face-sym))) - -;;;; Tree substitution - -(defun my-ts-rw--replace-capture-in-tree (tree from to) - "Recursively replace occurrences of FROM with TO in TREE." - (cond - ((eq tree from) to) - ((consp tree) - (cons (my-ts-rw--replace-capture-in-tree (car tree) from to) - (my-ts-rw--replace-capture-in-tree (cdr tree) from to))) - (t tree))) - -(provide 'treesit-predicate-rewrite) -;;; treesit-predicate-rewrite.el ends here |