From 9050450092da0244d20238e065b298d986d24c6d Mon Sep 17 00:00:00 2001 From: tslil Date: Thu, 23 Apr 2026 12:48:22 +0100 Subject: [emacs] use Michael Olson's fix for treesitter queries until emacs > 31 or something --- emacs/inits/03-miscload.el | 4 +- emacs/scripts/treesit-predicate-rewrite.el | 342 +++++++++++++++++++++++++++++ 2 files changed, 345 insertions(+), 1 deletion(-) create mode 100644 emacs/scripts/treesit-predicate-rewrite.el diff --git a/emacs/inits/03-miscload.el b/emacs/inits/03-miscload.el index 9a94f56..f8ad9ae 100644 --- a/emacs/inits/03-miscload.el +++ b/emacs/inits/03-miscload.el @@ -1,8 +1,10 @@ -;; Time-stamp: <2025-08-23 14h40 BST (anker)> +;; Time-stamp: <2026-04-23 12h47 BST (anker)> (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 new file mode 100644 index 0000000..0840f62 --- /dev/null +++ b/emacs/scripts/treesit-predicate-rewrite.el @@ -0,0 +1,342 @@ +;;; 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 -- cgit v1.2.3