79f5bc23d1
Normalize size units and intrinsic sizing across Elisp and native layout. Add help, pointer, hover-style and keymap support with reusable interaction adapters. Keep content updates local, preserve scroll caches and hover borders, and avoid rebuilding retained plans and ownership metadata for stable geometry. Validation: make check and native-rust-tests passed; targeted native interaction and scroll publication regressions passed.
455 lines
23 KiB
EmacsLisp
455 lines
23 KiB
EmacsLisp
;;; ebox-interaction.el --- Fixed native node capabilities -*- lexical-binding: t; -*-
|
|
|
|
;;; Commentary:
|
|
;; Validates Ebox's finite interaction inputs and projects them to native text
|
|
;; properties. These node facts do not participate in CSS cascade or geometry.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'tp-core)
|
|
(require 'tp-style)
|
|
|
|
(declare-function ebox-style-compile-form "ebox-style" (tag plist))
|
|
(declare-function ebox-style-declaration-properties "ebox-style"
|
|
(declarations predicate))
|
|
(declare-function ebox-buffer--text-decoration-face "ebox-buffer-backend" (style))
|
|
(declare-function ebox-buffer-paint-text-properties "ebox-buffer-backend"
|
|
(style role))
|
|
(declare-function ebox-get "ebox" (box property))
|
|
(declare-function ebox--ensure-region-id "ebox" (box))
|
|
(declare-function ebox-runtime-index-get "ebox-runtime-index" (key index &optional default))
|
|
(declare-function ebox-fragment-style-source-node "ebox-fragment" (node))
|
|
(defvar ebox-buffer--decoration-style-map)
|
|
|
|
(defconst ebox-interaction-properties
|
|
'(:help-echo :pointer :hover-style :keymap)
|
|
"Fixed node capabilities accepted outside the Ebox style schema.")
|
|
|
|
(defconst ebox-interaction--hover-properties
|
|
'(:color :background-color :text-decoration-line
|
|
:text-decoration-color :text-decoration-style)
|
|
"Geometry-independent Ebox declarations accepted by `:hover-style'.")
|
|
|
|
(defun ebox-interaction--command (callback)
|
|
"Wrap zero-argument CALLBACK as a keyboard or mouse command."
|
|
(lambda (&optional event)
|
|
(interactive (list (and (mouse-event-p last-input-event) last-input-event)))
|
|
(if (null event)
|
|
(funcall callback)
|
|
(unless (and (consp event) (mouse-event-p event))
|
|
(user-error "Ebox activation requires a mouse text event"))
|
|
(let* ((position (event-start event))
|
|
(window (posn-window position))
|
|
(point (posn-point position)))
|
|
(unless (and (window-live-p window) (null (posn-area position))
|
|
(integer-or-marker-p point))
|
|
(user-error "Ebox activation requires a live text window"))
|
|
(with-current-buffer (window-buffer window)
|
|
(unless (and (or (integerp point)
|
|
(eq (marker-buffer point) (current-buffer)))
|
|
(<= (point-min) point (point-max)))
|
|
(user-error "Ebox activation position is outside its text buffer"))
|
|
(funcall callback))))))
|
|
|
|
;;;###autoload
|
|
(defun ebox-keymap-create (&rest options)
|
|
"Create an ordinary native keymap from OPTIONS.
|
|
`:activate' is an optional zero-argument callback for RET, return, SPC and
|
|
the primary mouse button. Nil omits these activation bindings. `:bindings'
|
|
is an alist of string key descriptions or key vectors paired with
|
|
zero-argument callbacks.
|
|
Callbacks are not invoked until a generated command runs. Keyboard commands
|
|
use the current buffer; mouse commands use the event window's buffer without
|
|
selecting a window or moving point. Duplicate or overlapping keys are errors.
|
|
This function does not supply focus navigation, state or event propagation."
|
|
(unless (and (proper-list-p options) (zerop (% (length options) 2)))
|
|
(error "Ebox keymap options must be an even plist"))
|
|
(let ((map (make-sparse-keymap)) seen keys)
|
|
(cl-loop for (key _value) on options by #'cddr do
|
|
(unless (memq key '(:activate :bindings))
|
|
(error "Unknown Ebox keymap option: %S" key))
|
|
(when (memq key seen)
|
|
(error "Repeated Ebox keymap option: %S" key))
|
|
(push key seen))
|
|
(let ((activate (plist-get options :activate))
|
|
(bindings (plist-get options :bindings)))
|
|
(unless (proper-list-p bindings)
|
|
(error "Ebox keymap :bindings must be an alist"))
|
|
(when activate
|
|
(setq bindings (append (mapcar (lambda (key) (cons key activate))
|
|
'("RET" [return] "SPC" [mouse-1]))
|
|
bindings)))
|
|
(dolist (entry bindings)
|
|
(unless (and (consp entry) (functionp (cdr entry)))
|
|
(error "Ebox keymap bindings require a key and a callback"))
|
|
(let ((key (car entry)) (callback (cdr entry)))
|
|
(unless (or (stringp key) (vectorp key))
|
|
(error "Ebox keymap keys must be strings or vectors"))
|
|
(unless (or (autoloadp (indirect-function callback))
|
|
(zerop (car (func-arity callback))))
|
|
(error "Ebox keymap callbacks must accept zero arguments"))
|
|
(setq key (vconcat (kbd (if (stringp key) key (key-description key)))))
|
|
(when (zerop (length key))
|
|
(error "Ebox keymap keys must not be empty"))
|
|
(when (cl-some (lambda (other)
|
|
(let ((length (min (length key) (length other))))
|
|
(equal (cl-subseq key 0 length)
|
|
(cl-subseq other 0 length))))
|
|
keys)
|
|
(error "Ebox keymap binding overlaps an existing key: %s"
|
|
(key-description key)))
|
|
(define-key map key (ebox-interaction--command callback))
|
|
(push key keys))))
|
|
map))
|
|
|
|
;;;###autoload
|
|
(defun ebox-help-create (function)
|
|
"Adapt zero-argument FUNCTION to a native `help-echo' callback.
|
|
The help object's buffer, or the live window buffer for a displayed string,
|
|
becomes current while FUNCTION runs. Neither point nor window selection is
|
|
changed. FUNCTION runs only when Emacs requests help and must return a string
|
|
or nil. Existing native three-argument callbacks need no adapter."
|
|
(unless (and (functionp function)
|
|
(or (autoloadp (indirect-function function))
|
|
(zerop (car (func-arity function)))))
|
|
(error "Ebox help requires a zero-argument function"))
|
|
(lambda (window object _position)
|
|
(let ((buffer (cond ((bufferp object) object)
|
|
((overlayp object) (overlay-buffer object))
|
|
((and (stringp object) (window-live-p window))
|
|
(window-buffer window)))))
|
|
(unless (buffer-live-p buffer)
|
|
(user-error "Ebox help requires a live text buffer"))
|
|
(with-current-buffer buffer
|
|
(let ((value (funcall function)))
|
|
(unless (or (null value) (stringp value))
|
|
(error "Ebox help function must return a string or nil"))
|
|
value)))))
|
|
|
|
(defun ebox-interaction--keymap-snapshot (keymap)
|
|
"Copy native KEYMAP, resolving named root, prefix and parent maps.
|
|
Only native map positions are resolved; ordinary command symbols and literal
|
|
callback environments retain their identities. Sharing and cycles survive."
|
|
(let ((copies (make-hash-table :test #'eq)))
|
|
(cl-labels
|
|
((binding
|
|
(value)
|
|
(cond
|
|
((keymapp value) (map-copy value))
|
|
((functionp value) value)
|
|
((and (consp value) (eq (car value) 'menu-item))
|
|
(let ((copy (tp-property-value-copy value)))
|
|
(when (cddr copy)
|
|
(setcar (cddr copy) (binding (nth 2 value))))
|
|
copy))
|
|
((and (consp value) (stringp (car value)))
|
|
(cons (tp-property-value-copy (car value)) (binding (cdr value))))
|
|
((and (consp value) (keymapp (car value)))
|
|
(cons (map-copy (car value)) (tp-property-value-copy (cdr value))))
|
|
(t (tp-property-value-copy value))))
|
|
(map-copy
|
|
(source)
|
|
(setq source (if (symbolp source) (indirect-function source) source))
|
|
(or (gethash source copies)
|
|
(let* ((parent (keymap-parent source))
|
|
(local (copy-sequence source))
|
|
(copy (tp-property-value-copy source)))
|
|
(puthash source copy copies)
|
|
;; Only the copied spine is edited, leaving source bindings
|
|
;; and character tables untouched while enumerating locals.
|
|
;; Replacing existing entries also preserves native menu order.
|
|
(set-keymap-parent local nil)
|
|
(map-keymap
|
|
(lambda (event definition)
|
|
(define-key copy (vector event) (binding definition)))
|
|
local)
|
|
(when parent (set-keymap-parent copy (map-copy parent)))
|
|
copy))))
|
|
(map-copy keymap))))
|
|
|
|
(defun ebox-interaction--hover-face (value)
|
|
"Validate hover declarations VALUE and return a native mouse face."
|
|
(unless (and (proper-list-p value) (zerop (% (length value) 2)))
|
|
(error "Ebox :hover-style must be an even declaration plist"))
|
|
(cl-loop for (key val) on value by #'cddr
|
|
unless (memq key ebox-interaction--hover-properties)
|
|
do (error "Ebox :hover-style does not support %S" key)
|
|
when (memq key '(:color :background-color :text-decoration-color))
|
|
unless (or (stringp val)
|
|
(and (eq key :text-decoration-color)
|
|
(eq val 'currentColor)))
|
|
do (error "Ebox :hover-style %S requires a color string" key))
|
|
(when value
|
|
(require 'ebox-style)
|
|
(require 'ebox-buffer-backend)
|
|
(let* ((style (ebox-style-declaration-properties
|
|
(ebox-style-compile-form 'text value) (lambda (_property) t)))
|
|
(face (ebox-buffer--text-decoration-face style)))
|
|
;; A solid underline is represented by t in a face, not an empty plist.
|
|
(when (and (plist-member face :underline)
|
|
(null (plist-get face :underline)))
|
|
(setq face (plist-put face :underline t)))
|
|
(when (plist-member style :color)
|
|
(setq face (plist-put face :foreground (plist-get style :color))))
|
|
(when (plist-member style :background-color)
|
|
(setq face (plist-put face :background
|
|
(plist-get style :background-color))))
|
|
(when (eq (plist-get style :text-decoration-line) 'none)
|
|
(setq face (append face '(:underline nil :overline nil
|
|
:strike-through nil))))
|
|
face)))
|
|
|
|
(defun ebox-interaction-normalize (properties)
|
|
"Return an owned, validated copy of node interaction PROPERTIES.
|
|
Absent keys inherit enclosing surface values; explicit nil blocks them.
|
|
Callback values remain literal functions. Mutable keymaps are snapshotted;
|
|
replace the property to publish subsequent binding changes."
|
|
(unless (and (proper-list-p properties)
|
|
(zerop (% (length properties) 2)))
|
|
(error "Ebox interaction properties must be an even plist"))
|
|
(let (seen)
|
|
(cl-loop for (key value) on properties by #'cddr do
|
|
(when (memq key seen)
|
|
(error "Ebox interaction property repeated: %S" key))
|
|
(push key seen)
|
|
(pcase key
|
|
(:help-echo
|
|
(unless (or (null value) (stringp value) (functionp value))
|
|
(error "Ebox :help-echo requires nil, a string or a function")))
|
|
(:pointer
|
|
(unless (memq value '(nil text arrow vdrag modeline hand
|
|
hdrag nhdrag hourglass))
|
|
(error "Ebox :pointer has unsupported shape: %S" value)))
|
|
(:keymap
|
|
(unless (or (null value) (keymapp value))
|
|
(error "Ebox :keymap requires nil or a native keymap")))
|
|
(:hover-style (ebox-interaction--hover-face value))
|
|
(_ (error "Ebox has no interaction property %S" key)))))
|
|
(let ((owned (tp-property-value-copy properties)))
|
|
(when (plist-get properties :keymap)
|
|
(setq owned (plist-put owned :keymap
|
|
(ebox-interaction--keymap-snapshot
|
|
(plist-get properties :keymap)))))
|
|
owned))
|
|
|
|
(defun ebox-interaction-surface-properties (properties)
|
|
"Project normalized node PROPERTIES to native surface facts."
|
|
(cl-loop for (key value) on properties by #'cddr
|
|
append (if (eq key :hover-style)
|
|
(let* ((face (ebox-interaction--hover-face value))
|
|
(decoration
|
|
(cl-loop for (property entry) on value by #'cddr
|
|
when (memq property
|
|
'(:text-decoration-line
|
|
:text-decoration-color
|
|
:text-decoration-style))
|
|
append (list property entry)))
|
|
(paint
|
|
(cl-loop for (property entry) on face by #'cddr
|
|
unless (memq property
|
|
'(:underline :overline
|
|
:strike-through))
|
|
append (list property entry))))
|
|
(list 'ebox--hover-style
|
|
(when value (list :face paint :decoration decoration))
|
|
'mouse-face face))
|
|
(list (pcase key
|
|
(:help-echo 'help-echo) (:pointer 'pointer)
|
|
(:keymap 'keymap)) value))))
|
|
|
|
(defun ebox-interaction--face-attribute (face attribute)
|
|
"Return FACE's explicit ATTRIBUTE entry, following native face precedence."
|
|
(cond
|
|
((null face) nil)
|
|
((and (consp face) (keywordp (car face)))
|
|
(if-let* ((entry (plist-member face attribute)))
|
|
(unless (eq (cadr entry) 'unspecified) (list attribute (cadr entry)))
|
|
(ebox-interaction--face-attribute (plist-get face :inherit) attribute)))
|
|
((listp face)
|
|
(cl-some (lambda (entry) (ebox-interaction--face-attribute entry attribute))
|
|
face))
|
|
((facep face)
|
|
(let ((value (face-attribute face attribute nil t)))
|
|
(unless (eq value 'unspecified) (list attribute value))))))
|
|
|
|
(defun ebox-interaction--hover-decoration-face (declarations base)
|
|
"Apply partial decoration DECLARATIONS to the effective BASE face."
|
|
(when declarations
|
|
(let* ((line-entry (plist-member declarations :text-decoration-line))
|
|
(line (cadr line-entry))
|
|
(lines (if (listp line) line (list line)))
|
|
(color-entry (plist-member declarations :text-decoration-color))
|
|
(color (cadr color-entry))
|
|
(style-entry (plist-member declarations :text-decoration-style))
|
|
(style (alist-get (cadr style-entry) ebox-buffer--decoration-style-map))
|
|
face)
|
|
(dolist (entry '((underline . :underline) (overline . :overline)
|
|
(line-through . :strike-through)))
|
|
(let* ((property (cdr entry))
|
|
(old (cadr (ebox-interaction--face-attribute base property)))
|
|
(active (if line-entry (memq (car entry) lines) old)))
|
|
(when (or line-entry active)
|
|
(setq face
|
|
(plist-put
|
|
face property
|
|
(when active
|
|
(if (eq property :underline)
|
|
(let ((value (cond ((stringp old) (list :color old))
|
|
((consp old) (copy-sequence old)))))
|
|
(when color-entry
|
|
(if (eq color 'currentColor)
|
|
(cl-remf value :color)
|
|
(setq value (plist-put value :color color))))
|
|
(when style-entry
|
|
(if (eq style 'line)
|
|
(cl-remf value :style)
|
|
(setq value (plist-put value :style style))))
|
|
(or value t))
|
|
(if color-entry
|
|
(if (eq color 'currentColor) t color)
|
|
(or old t)))))))))
|
|
face)))
|
|
|
|
(defvar ebox-interaction--hover-face-cache
|
|
(make-hash-table :test #'equal :weakness 'value)
|
|
"Weak cache preserving one native face identity per hover owner and paint.")
|
|
|
|
(defun ebox-interaction--node-surface-properties (node)
|
|
"Return NODE's native surface facts with its computed hover base.
|
|
Native mouse highlighting paints one face across a contiguous region. Its
|
|
unspecified attributes therefore use the hover owner's style, even when its
|
|
children have different ordinary text colors. Explicit child hover remains
|
|
an independent region. Physical border paint is handled during projection."
|
|
(let* ((properties (ebox-get node :surface-properties))
|
|
(declaration (plist-get properties 'ebox--hover-style)))
|
|
(if (null declaration)
|
|
properties
|
|
(plist-put
|
|
(copy-sequence properties) 'ebox--hover-style
|
|
(append declaration
|
|
(list :owner (ebox--ensure-region-id node)
|
|
:base (plist-get
|
|
(ebox-buffer-paint-text-properties node 'content)
|
|
'face)))))))
|
|
|
|
(defun ebox-interaction--hover-owner-base (declaration state)
|
|
"Return DECLARATION's current owner face, resolving it in STATE when supplied."
|
|
(let* ((owner (plist-get declaration :owner))
|
|
(node-id (and state owner
|
|
(ebox-runtime-index-get
|
|
owner (plist-get state :region-node-table))))
|
|
(node (and node-id
|
|
(ebox-runtime-index-get node-id (plist-get state :node-table))))
|
|
(box (and node (ebox-fragment-style-source-node node))))
|
|
(if box
|
|
(plist-get (ebox-buffer-paint-text-properties box 'content) 'face)
|
|
(plist-get declaration :base))))
|
|
|
|
(defun ebox-interaction--refresh-hover! (string start end &optional face state)
|
|
"Project owned hover paint in STRING between START and END.
|
|
FACE supplies a fallback for legacy declarations without an owner. STATE
|
|
resolves current owner paint during retained updates. All interior runs with
|
|
the same owner and paint share the exact same native mouse face, including
|
|
padding. Border glyphs are excluded; horizontal strokes keep their own paint."
|
|
(let ((position start))
|
|
(while (< position end)
|
|
(setq position (or (text-property-not-all
|
|
position end 'ebox--hover-style nil string) end))
|
|
(when (< position end)
|
|
(let* ((next (next-property-change position string end))
|
|
(declaration (get-text-property position 'ebox--hover-style string))
|
|
(normal (or face (get-text-property position 'face string)))
|
|
(base (if (plist-member declaration :owner)
|
|
(ebox-interaction--hover-owner-base declaration state)
|
|
normal))
|
|
(hover (append
|
|
(ebox-interaction--hover-decoration-face
|
|
(plist-get declaration :decoration) base)
|
|
(plist-get declaration :face)))
|
|
(faces (cond ((null base) nil)
|
|
((and (consp base) (keywordp (car base))) (list base))
|
|
((listp base) base)
|
|
(t (list base))))
|
|
(side (or (get-text-property position 'ebox-bl string)
|
|
(get-text-property position 'ebox-br string)))
|
|
(strokes
|
|
(append
|
|
(when (get-text-property position 'ebox-bt string)
|
|
(ebox-interaction--face-attribute normal :overline))
|
|
(when (get-text-property position 'ebox-bb string)
|
|
(ebox-interaction--face-attribute normal :underline))))
|
|
(combined (append (when strokes (list strokes))
|
|
(when hover (list hover)) faces))
|
|
(value (if (cdr combined) combined (car combined)))
|
|
(key (list (plist-get declaration :owner) value))
|
|
(shared (or (gethash key ebox-interaction--hover-face-cache)
|
|
(when value
|
|
(puthash key value ebox-interaction--hover-face-cache)))))
|
|
(when (and state (plist-member declaration :owner)
|
|
(not (equal base (plist-get declaration :base))))
|
|
(put-text-property
|
|
position next 'ebox--hover-style
|
|
(plist-put (copy-sequence declaration) :base base) string))
|
|
(put-text-property position next 'mouse-face
|
|
(unless side shared) string)
|
|
(setq position next)))))
|
|
string)
|
|
|
|
(defun ebox-interaction-surface-equal-p (left right)
|
|
"Compare native surface plists LEFT and RIGHT without collapsing commands.
|
|
Literal callbacks retain identity; keymap snapshots use TP's native property
|
|
policy, which compares bindings while retaining command identity. Paint and
|
|
data values use native value equality, before surface publication loads."
|
|
(or (eq left right)
|
|
(and (= (length left) (length right))
|
|
(cl-loop for (property value) on left by #'cddr
|
|
for entry = (plist-member right property)
|
|
always (and entry
|
|
(cond
|
|
((or (keymapp value) (keymapp (cadr entry)))
|
|
(funcall
|
|
(tp-property-policy-equality
|
|
(tp-register-text-property property))
|
|
value (cadr entry)))
|
|
((or (functionp value) (functionp (cadr entry)))
|
|
(eq value (cadr entry)))
|
|
(t (equal-including-properties
|
|
value (cadr entry)))))))))
|
|
|
|
(defun ebox-interaction--fill-property (string start end property value)
|
|
"Fill surface PROPERTY with VALUE in STRING between START and END.
|
|
Newlines are structural. An inner explicit nil blocks enclosing values of
|
|
the four supported native properties, just as an inner non-nil value does."
|
|
(let ((position start)
|
|
(presence-p (memq property '(help-echo pointer mouse-face keymap
|
|
ebox--hover-style))))
|
|
(when (or value presence-p)
|
|
(while (< position end)
|
|
(let ((next (min (or (next-property-change position string end) end)
|
|
(or (string-match "\n" string position) end))))
|
|
(if (= position next)
|
|
(setq position (1+ position))
|
|
(unless (if presence-p
|
|
(let ((props (text-properties-at position string)))
|
|
(or (plist-member props property)
|
|
(and (eq property 'ebox--hover-style)
|
|
(plist-member props 'mouse-face))))
|
|
(get-text-property position property string))
|
|
(add-text-properties position next (list property value) string))
|
|
(when (eq property 'keymap)
|
|
;; Key lookup otherwise consults the preceding character at
|
|
;; the start of a non-front-sticky text-property interval.
|
|
(dolist (sticky '(front-sticky rear-nonsticky))
|
|
(let ((existing (get-text-property position sticky string)))
|
|
(unless (eq existing t)
|
|
(put-text-property
|
|
position next sticky
|
|
(cons 'keymap (remq 'keymap (copy-sequence existing)))
|
|
string)))))
|
|
(setq position next)))))))
|
|
|
|
(provide 'ebox-interaction)
|
|
|
|
;;; ebox-interaction.el ends here
|