(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
projects / emacs.git / commitdiff