From: Eshel Yaron Date: Sun, 30 Jun 2024 16:36:43 +0000 (+0200) Subject: New command 'propertize-region' X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=19c5ec6ee3cdce28b562030de8e325661a40374d;p=emacs.git New command 'propertize-region' --- diff --git a/lisp/simple.el b/lisp/simple.el index 947735fec91..ad20ef3156d 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -11121,6 +11121,135 @@ particular action on the input you type there." (interactive "sIgnore: ") (ignore string)) +(defvar text-property-alist + '((category . "Symbol with properties that apply to text") + (face . "Text appearance") + (font-lock-face . "Appearance under Font Lock mode") + (mouse-face . "Appearance when mouse is over text") + (cursor-face . "Appearance when point is in text") + (fontified . "Whether text is ready for display") + (display . "Advanced display specification") + (help-echo . "Help for when mouse is over text") + (help-echo-inhibit-substitution . "Whether to use `help-echo' property value as is") + (left-fringe-help . "Help for when mouse is on left fringe of line") + (right-fringe-help . "Help for when mouse is on right fringe of line") + (keymap . "Additional keymap for when point is at text") + (local-map . "Replacement local keymap for when point is at text") + (syntax-table . "Syntax table of text") + (read-only . "Whether text is read-only") + (inhibit-read-only . "Whether text can be edited even in read-only buffers") + (invisible . "Whether text is invisible") + (inhibit-isearch . "Whether Isearch skips text") + (intangible . "Whether to prevent point from entering text") + (cursor-intangible . "Whether to prevent point from entering text") + (field . "Field that text belongs to") + (cursor . "Where to show cursor when point is at text") + (pointer . "Pointer shape for when mouse is over text") + (line-spacing . "For newline, height of terminated line") + (line-height . "For newline, total height of terminated line") + (wrap-prefix . "Prefix added to continuation lines") + (line-prefix . "Prefix added to non-continuation lines") + (modification-hooks . "Functions to call when modifying text") + (insert-in-front-hooks . "Functions to call when inserting before text") + (insert-behind-hooks . "Functions to call when inserting after text") + (point-entered . "Functions to call when point enters text") + (point-left . "Functions to call when point leaves text") + (cursor-sensor-functions . "Functions to call when point moves in or out of text") + (composition . "Internal property for composing text characters") + (minibuffer-message . "Where to show messages when text is in minibuffer") + (front-sticky . "Properties to inherit when inserting before text") + (rear-nonsticky . "Properties not to inherit when inserting after text") + (button . "Object identifying text as a button")) + "Alist of text properties and strings describing them.") + +(cl-defgeneric read-text-property-value (property &optional prompt) + "Prompt with PROMPT for a value of text property PROPERTY." + (minibuffer-with-setup-hook + (lambda () + (setq-local + minibuffer-default-add-function + (lambda () + (with-current-buffer (window-buffer (minibuffer-selected-window)) + (when-let ((current (get-text-property (point) property))) + (prin1-to-string current)))))) + (read-minibuffer + (or prompt (substitute-quotes (format "Value for `%S': " property)))))) + +(cl-defmethod read-text-property-value ((_ (eql 'face)) + &optional prompt) + (read-face-name (or prompt "Face"))) + +(cl-defmethod read-text-property-value ((_ (eql 'font-lock-face)) + &optional prompt) + (read-face-name (or prompt "Font Lock face"))) + +(cl-defmethod read-text-property-value ((_ (eql 'mouse-face)) + &optional prompt) + (read-face-name (or prompt "Mouse face"))) + +(cl-defmethod read-text-property-value ((_ (eql 'cursor-face)) + &optional prompt) + (read-face-name (or prompt "Cursor face"))) + +(cl-defmethod read-text-property-value ((_ (eql 'fontified)) + &optional prompt) + (y-or-n-p (or prompt "Fontified? "))) + +(cl-defmethod read-text-property-value ((_ (eql 'help-echo)) + &optional prompt) + (read-string (or prompt "Help text: "))) + +(cl-defmethod read-text-property-value + ((_ (eql 'help-echo-inhibit-substitution)) &optional prompt) + (y-or-n-p (or prompt (substitute-quotes + "Inhibit substitutions in `help-echo' text? ")))) + +(defun read-text-property-affixation (cands) + "Add annotations to text property completion candidates CANDS." + (let ((max (seq-max (cons 0 (mapcar #'string-width cands))))) + (mapcar + (lambda (cand) + (list cand "" (if-let ((desc (alist-get (intern cand) text-property-alist))) + (concat (make-string (1+ (- max (string-width cand))) ?\s) + (propertize + (substitute-quotes desc) + 'face 'completions-annotations)) + ""))) + cands))) + +(defvar read-text-property-history nil) + +(defun read-text-property-and-value (&optional prompt) + (let ((prop (intern + (completing-read + (format-prompt (or prompt "Property") "face") + (completion-table-with-metadata + (let ((alist text-property-alist) + (plist (text-properties-at (point)))) + (while plist + (unless (assq (car plist) alist) + (push (cons (car plist) "") alist)) + (setq plist (cddr plist))) + (mapcar (compose #'symbol-name #'car) alist)) + '((category . text-property) + (affixation-function . read-text-property-affixation))) + nil nil nil + 'read-text-property-history "face")))) + (list prop (read-text-property-value prop)))) + +(defun propertize-region (beg end prop val) + "Put property PROP with value VAL on text from BEG to END. + +Interactively, use the boundaries of the region as BEG and END, and +prompt for PROP and VAL." + (declare (interactive-only put-text-property)) + (interactive + (progn + ;; TODO: With prefix arg, inhibit read-only. + (barf-if-buffer-read-only) + `(,(region-beginning) ,(region-end) ,@(read-text-property-and-value)))) + (put-text-property beg end prop val)) + (provide 'simple) ;;; simple.el ends here