|
Warning: this is an htmlized version!
The original is here, and the conversion rules are here. |
;; ttp.el - tools for editing text with arbitrary text properties
;; Author and version: Edrx, 2005feb02
;; (find-anggfile "TCL/tcl.ttp")
;;;;
;;;; ttp-pack and ttp-unpack: use the format ^Atext^Bprops^C
;;;; (or just the text when there are no properties)
;;;;
(defvar ttp-regexp
"\\(\^A\\)\\([^\^A\^B\^C]+\\)\\(\^B\\([^\^A\^B\^C]+\\)\^C\\)")
(defun ttp-pack (start end)
(interactive "r")
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char (point-min))
(while (search-forward-regexp ttp-regexp nil t)
(let ((props (read (match-string 4))))
(set-text-properties (match-beginning 2) (match-end 2) props)
(delete-region (match-beginning 3) (match-end 3))
(goto-char (match-end 2))
(delete-region (match-beginning 1) (match-end 1))))
(point-max))))
;; Experimental: pack by the ^A and ^B...^C parts invisible.
;; Invisibily of the ^A and of the ^B...^C must be done by text
;; properties, not overlays, because we need to be able to move links
;; around preserving the invisible prefixes and suffixes.
;; (find-efile "outline.el" "defun outline-flag-region")
;;
(setq ttp-left '(invisible t))
(setq ttp-right '(invisible t))
(defun ttp-ipack (start end)
(interactive "r")
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char (point-min))
(while (search-forward-regexp ttp-regexp nil t)
(let ((props (read (match-string 4)))) ; change to support L: and B:
(set-text-properties (match-beginning 1) (match-end 1) ttp-left)
(set-text-properties (match-beginning 2) (match-end 2) props)
(set-text-properties (match-beginning 3) (match-end 3) ttp-right)
(goto-char (match-end 0)))))))
(defun ttp-unpack (start end)
(interactive "r")
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char (point-min))
(while (not (eobp))
(let ((plist (text-properties-at (point)))
(next-change (copy-marker
(or (next-property-change (point))
(point-max)))))
(when plist
(set-text-properties (point) next-change nil)
(insert "\^A")
(goto-char next-change)
(insert-before-markers "\^B\n" (prin1-to-string plist) "\n\^C"))
(goto-char next-change))))))
;;;;
;;;; region-as-insert: use the formats "text" and (p "text" p1 v2 p2 v2 ...)
;;;; 2005jan27
;;;;
;; (find-elnode "Property Search" "while (not (eobp))")
;; (find-elnode "Expansion")
(defmacro p (&rest args) `(propertize ',args))
(defun region-as-objects-to-insert (start end &optional fun)
(or fun (setq fun (lambda (&rest args) (cons 'p args))))
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char (point-min))
(let (inserts-reversed)
(while (not (eobp))
(let* ((nextpos (or (next-property-change (point)) (point-max)))
(plist (text-properties-at (point)))
(string (buffer-substring-no-properties (point) nextpos))
(code (if plist
(apply fun string plist)
string)))
(setq inserts-reversed (cons code inserts-reversed))
(goto-char nextpos)))
(nreverse inserts-reversed)))))
(defun region-as-insert (start end)
(let ((objects-to-insert (region-as-objects-to-insert start end))
(print-escape-newlines t))
(with-temp-buffer
(insert "(insert\n")
(mapc (lambda (obj) (prin1 obj (current-buffer)) (insert "\n"))
objects-to-insert)
(insert ")\n")
(buffer-substring (point-min) (point-max)))))
;; For tests:
;; (foo (point) (mark))
'
(defun foo (start end)
(interactive "r")
(find-estring (region-as-insert start end)))
;;;;
;;;; ttp-all-properties and ttp-filter-keep
;;;; These are used by `tunpack' to filter out irrelevant properties.
;;;;
;; (find-elnode "Creating Markers")
;; (find-elnode "Marker Insertion Types")
;; (find-elnode "Index" "* while:")
;; (find-elnode "Iteration")
;; (find-elnode "Property Search")
;; (find-elnode "Changing Properties")
;; (find-elnode "Property Search" "(while (not (eobp))")
(defun ttp-plist-to-keys (pvlist)
"Take a list of the form (p1 v1 p2 v2 ...) and return a list like (p1 p2 ...)."
(if pvlist (cons (car pvlist) (ttp-plist-to-keys (cddr pvlist)))))
(defun ttp-keys-to-plist (keys)
"Take a list of the form (p1 p2 ...) and return a list like (p1 v1 p2 v2 ...)."
(if keys (cons (car keys) (cons nil (ttp-keys-to-plist (cdr keys))))))
(if (not (fboundp 'remove-list-of-text-properties))
(defun remove-list-of-text-properties (start end keys &optional object)
(remove-text-properties start end (ttp-keys-to-plist keys) object))
)
(defun ttp-get-text-properties-and-erase-them ()
(let ((proplist (ttp-plist-to-keys (text-properties-at (point)))))
(remove-list-of-text-properties (point) (point-max) proplist)
proplist))
(defun ttp-next-property-change ()
(goto-char (or (next-property-change (point)) (point-max))))
(defun ttp-all-properties (beg end)
"Determine the \"names\" of all text properties that appear from BEG to END.
The answer is a list of symbols - for example, `(face fontified category)'."
(let ((contents (buffer-substring beg end)))
(with-temp-buffer
(insert contents)
(goto-char 0)
(let ((proplist (ttp-get-text-properties-and-erase-them)))
(while (progn (ttp-next-property-change)
(not (eobp)))
(setq proplist (append (ttp-get-text-properties-and-erase-them)
proplist)))
proplist))))
;; (ttp-all-properties (point) (mark))
(defun ttp-set-difference (list1 list2)
"Example: (ttp-set-difference '(a b c d) '(c b f)) |--> (a c)."
(if list1 (let ((diff (ttp-set-difference (cdr list1) list2)))
(if (member (car list1) list2)
diff
(cons (car list1) diff)))))
(defun ttp-filter-keep (beg end ttp-good-properties)
(let* ((ttp-all-properties (ttp-all-properties beg end))
(ttp-bad-properties (ttp-set-difference ttp-all-properties
ttp-good-properties)))
(remove-list-of-text-properties beg end ttp-bad-properties)))
;;;;
;;;; qref - buttons for "quick reference" pages
;;;;
(defun eeflash-prop-region ()
(interactive)
(eeflash (previous-char-property-change (1+ (point)))
(next-char-property-change (point))
'(:background "Orange")))
(defun qref-do-help ()
(interactive)
(message "%S" (get-text-property (point) 'action))
(eeflash-prop-region))
(defun qref-do-action ()
(interactive)
(eval (get-text-property (point) 'action)))
(defvar qref-keymap
'(keymap (13 . qref-do-action)
(?? . qref-do-help)))
(defvar qref-link nil
"Text properties for qref's \"underlined\" links.
Only the proplist of this variable matters.
See: (find-epp (symbol-plist 'qref-link))")
(defvar qref-button nil
"Text properties for qref's \"button\" links.
Only the proplist of this variable matters.
See: (find-epp (symbol-plist 'qref-link))")
(setplist 'qref-link
`(face (:underline t)
active-face (:background "Orange")
mouse-face (:foreground "green")
keymap ,qref-keymap))
(setplist 'qref-button
`(face (:foreground "LightGray"
:background "DarkOliveGreen4")
active-face (:background "Orange")
mouse-face (:foreground "green")
keymap ,qref-keymap))
;;;;
;;;; highlighting the link and showing its action
;;;;
(setq qref-overlay nil)
(defun qref-point-at-link-p ()
(get-text-property (point) 'action))
(defun qref-point-at-overlay-p ()
(if qref-overlay
(memq qref-overlay (overlays-at (point)))))
(defun qref-destroy-overlay ()
(delete-overlay qref-overlay)
(setq qref-overlay nil))
(defun qref-create-overlay ()
(setq qref-overlay
(make-overlay (previous-char-property-change (1+ (point)))
(next-char-property-change (point))))
(overlay-put qref-overlay 'face
(get-text-property (point) 'active-face)))
(defun qref-show-target ()
(message (ee-pp1 (get-text-property (point) 'action))))
(defun qref-highlight-current-link ()
(if qref-overlay
(qref-destroy-overlay))
(when (qref-point-at-link-p)
(qref-create-overlay)
(qref-show-target)))
;;;;
;;;; <f3>
;;;;
(setq ttp-good-properties '(category action face))
(defun tpack (start end)
(interactive "r")
(ttp-pack start end))
(defun tunpack (start end)
(interactive "r")
(ttp-filter-keep start end ttp-good-properties)
(ttp-unpack start end))
(defun tflip (start end)
(interactive "r")
(cond ((eq current-prefix-arg 1) (tpack start end))
((eq current-prefix-arg 2) (tunpack start end))
(t (error "Bad prefix arg; must be 1 to pack or 2 to unpack"))))
(eeb-define 'eeb-tpack 'tpack 'ee-delimiter-semicolon nil t t)
(eeb-define 'eeb-tunpack 'tunpack 'ee-delimiter-semicolon nil t t)
(eeb-define 'eeb-tflip 'tflip 'ee-delimiter-semicolon nil t t)
;;;;
;;;; Tests / demos
;;;;
;; (find-efunction 'yank)
;; (find-efunction 'insert-for-yank-1)
;; (find-efunction 'remove-yank-excluded-properties)
;; (find-es "emacs" "flet")
;;
(defun ttp-yank (&optional arg)
(interactive "*P")
(flet ((remove-yank-excluded-properties (start end)))
(yank arg)))
(defun ttp-mode (arg)
"Determine if links are highlighted and targets shown or not."
(interactive "p")
(if (> arg 0)
(add-hook 'post-command-hook 'qref-highlight-current-link nil 'local)
(remove-hook 'post-command-hook 'qref-highlight-current-link nil 'local)))
;; (add-hook 'post-command-hook 'qref-highlight-current-link nil 'local)
;; (remove-hook 'post-command-hook 'qref-highlight-current-link nil 'local)
(defun pq (text category action)
(propertize text 'category category 'action action))
'
(insert "\n;;*\n"
";; (ttp-mode 1)\n"
";; (setq eeb-defaults eeb-tflip)\n"
(pq "'foo" 'qref-button '(next-line 1)) "\n"
(pq "'foo" 'qref-button '(previous-line 1)) "\n"
";;*\n"
)
;; (find-elnode "Special Properties" "`invisible'")
;; (find-elnode "Sticky Properties")
;; (find-elnode "Invisible Text" "main editing loop moves point")
'
(insert "\n;;*\n"
";; (ttp-mode 1)\n"
";; (setq eeb-defaults eeb-tflip)\n"
(pq "'foo" 'qref-button '(next-line 1)) "\n"
(pq "'foo" 'qref-button '(previous-line 1)) "\n"
";;*\n"
)
;; (ttp-ipack (point) (ee-search-forward ";;\^O"))
;; (set-text-properties (point) (ee-search-forward ";;\^O") nil)
;; foogreen(face (:foreground "green"))bar
;;*
foo<green>green</green>bar
;;*
;; (ttp-mode 1)
;; (setq eeb-defaults eeb-tflip)
'foo
'foo
;;*
;; (load "~/elisp/ttp.el")
(provide 'ttp)
;; Local Variables:
;; coding: raw-text-unix
;; modes: (fundamental-mode emacs-lisp-mode)
;; End: