[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH v2 11/38] Implement overlay- and text-property-based versions of
|
From: |
Ihor Radchenko |
|
Subject: |
[PATCH v2 11/38] Implement overlay- and text-property-based versions of some functions |
|
Date: |
Wed, 20 Apr 2022 21:25:26 +0800 |
---
lisp/org-element.el | 54 ++++-
lisp/org-fold.el | 5 +-
lisp/org-inlinetask.el | 26 ++-
lisp/org-list.el | 74 ++++++-
lisp/org-macs.el | 54 ++++-
lisp/org.el | 469 +++++++++++++++++++++++++++++++++--------
6 files changed, 585 insertions(+), 97 deletions(-)
diff --git a/lisp/org-element.el b/lisp/org-element.el
index f627dd4ea..203695c71 100644
--- a/lisp/org-element.el
+++ b/lisp/org-element.el
@@ -7912,7 +7912,7 @@ (defun org-element-nested-p (elem-A elem-B)
(or (and (>= beg-A beg-B) (<= end-A end-B))
(and (>= beg-B beg-A) (<= end-B end-A)))))
-(defun org-element-swap-A-B (elem-A elem-B)
+(defun org-element-swap-A-B--overlays (elem-A elem-B)
"Swap elements ELEM-A and ELEM-B.
Assume ELEM-B is after ELEM-A in the buffer. Leave point at the
end of ELEM-A."
@@ -7980,6 +7980,58 @@ (defun org-element-swap-A-B (elem-A elem-B)
(dolist (o (cdr overlays))
(move-overlay (car o) (- (nth 1 o) offset) (- (nth 2 o) offset))))
(goto-char (org-element-property :end elem-B)))))
+(defun org-element-swap-A-B--text-properties (elem-A elem-B)
+ "Swap elements ELEM-A and ELEM-B.
+Assume ELEM-B is after ELEM-A in the buffer. Leave point at the
+end of ELEM-A."
+ (goto-char (org-element-property :begin elem-A))
+ ;; There are two special cases when an element doesn't start at bol:
+ ;; the first paragraph in an item or in a footnote definition.
+ (let ((specialp (not (bolp))))
+ ;; Only a paragraph without any affiliated keyword can be moved at
+ ;; ELEM-A position in such a situation. Note that the case of
+ ;; a footnote definition is impossible: it cannot contain two
+ ;; paragraphs in a row because it cannot contain a blank line.
+ (when (and specialp
+ (or (not (eq (org-element-type elem-B) 'paragraph))
+ (/= (org-element-property :begin elem-B)
+ (org-element-property :contents-begin elem-B))))
+ (error "Cannot swap elements"))
+ ;; In a special situation, ELEM-A will have no indentation. We'll
+ ;; give it ELEM-B's (which will in, in turn, have no indentation).
+ (org-fold-core-ignore-modifications ;; Preserve folding state
+ (let* ((ind-B (when specialp
+ (goto-char (org-element-property :begin elem-B))
+ (current-indentation)))
+ (beg-A (org-element-property :begin elem-A))
+ (end-A (save-excursion
+ (goto-char (org-element-property :end elem-A))
+ (skip-chars-backward " \r\t\n")
+ (point-at-eol)))
+ (beg-B (org-element-property :begin elem-B))
+ (end-B (save-excursion
+ (goto-char (org-element-property :end elem-B))
+ (skip-chars-backward " \r\t\n")
+ (point-at-eol)))
+ ;; Get contents.
+ (body-A (buffer-substring beg-A end-A))
+ (body-B (delete-and-extract-region beg-B end-B)))
+ (goto-char beg-B)
+ (when specialp
+ (setq body-B (replace-regexp-in-string "\\`[ \t]*" "" body-B))
+ (indent-to-column ind-B))
+ (insert body-A)
+ (goto-char beg-A)
+ (delete-region beg-A end-A)
+ (insert body-B)
+ (goto-char (org-element-property :end elem-B))))))
+(defsubst org-element-swap-A-B (elem-A elem-B)
+ "Swap elements ELEM-A and ELEM-B.
+Assume ELEM-B is after ELEM-A in the buffer. Leave point at the
+end of ELEM-A."
+ (if (eq org-fold-core-style 'text-properties)
+ (org-element-swap-A-B--text-properties elem-A elem-B)
+ (org-element-swap-A-B--overlays elem-A elem-B)))
(provide 'org-element)
diff --git a/lisp/org-fold.el b/lisp/org-fold.el
index 52717fd86..e48a528bf 100644
--- a/lisp/org-fold.el
+++ b/lisp/org-fold.el
@@ -53,10 +53,7 @@ (defvar org-drawer-regexp)
(defvar org-property-end-re)
(defvar org-link-descriptive)
(defvar org-outline-regexp-bol)
-(defvar org-custom-properties-hidden-p)
(defvar org-archive-tag)
-
-;; Needed for overlays only
(defvar org-custom-properties-overlays)
(declare-function isearch-filter-visible "isearch" (beg end))
@@ -1101,7 +1098,7 @@ (defun
org-fold-check-before-invisible-edit--text-properties (kind)
(when (or invisible-at-point invisible-before-point)
(when (eq org-fold-catch-invisible-edits 'error)
(user-error "Editing in invisible areas is prohibited, make them
visible first"))
- (if (and org-custom-properties-hidden-p
+ (if (and org-custom-properties-overlays
(y-or-n-p "Display invisible properties in this buffer? "))
(org-toggle-custom-properties-visibility)
;; Make the area visible
diff --git a/lisp/org-inlinetask.el b/lisp/org-inlinetask.el
index 581370bb5..a63704a05 100644
--- a/lisp/org-inlinetask.el
+++ b/lisp/org-inlinetask.el
@@ -305,7 +305,22 @@ (defun org-inlinetask-fontify (limit)
(add-text-properties (match-beginning 3) (match-end 3)
'(face org-inlinetask font-lock-fontified t)))))
-(defun org-inlinetask-toggle-visibility ()
+(defun org-inlinetask-toggle-visibility--text-properties ()
+ "Toggle visibility of inline task at point."
+ (let ((end (save-excursion
+ (org-inlinetask-goto-end)
+ (if (bolp) (1- (point)) (point))))
+ (start (save-excursion
+ (org-inlinetask-goto-beginning)
+ (point-at-eol))))
+ (cond
+ ;; Nothing to show/hide.
+ ((= end start))
+ ;; Inlinetask was folded: expand it.
+ ((org-fold-get-folding-spec 'headline (1+ start))
+ (org-fold-region start end nil 'headline))
+ (t (org-fold-region start end t 'headline)))))
+(defun org-inlinetask-toggle-visibility--overlays ()
"Toggle visibility of inline task at point."
(let ((end (save-excursion
(org-inlinetask-goto-end)
@@ -318,8 +333,13 @@ (defun org-inlinetask-toggle-visibility ()
((= end start))
;; Inlinetask was folded: expand it.
((eq (get-char-property (1+ start) 'invisible) 'outline)
- (org-flag-region start end nil 'outline))
- (t (org-flag-region start end t 'outline)))))
+ (org-fold-region start end nil 'outline))
+ (t (org-fold-region start end t 'outline)))))
+(defsubst org-inlinetask-toggle-visibility ()
+ "Toggle visibility of inline task at point."
+ (if (eq org-fold-core-style 'text-properties)
+ (org-inlinetask-toggle-visibility--text-properties)
+ (org-inlinetask-toggle-visibility--overlays)))
(defun org-inlinetask-hide-tasks (state)
"Hide inline tasks in buffer when STATE is `contents' or `children'.
diff --git a/lisp/org-list.el b/lisp/org-list.el
index 05a73a609..f72151460 100644
--- a/lisp/org-list.el
+++ b/lisp/org-list.el
@@ -1079,7 +1079,65 @@ (defsubst org-list-bullet-string (bullet)
(replace-match spaces nil nil bullet 1)
bullet))))
-(defun org-list-swap-items (beg-A beg-B struct)
+(defun org-list-swap-items--text-properties (beg-A beg-B struct)
+ "Swap item starting at BEG-A with item starting at BEG-B in STRUCT.
+
+Blank lines at the end of items are left in place. Item
+visibility is preserved. Return the new structure after the
+changes.
+
+Assume BEG-A is lesser than BEG-B and that BEG-A and BEG-B belong
+to the same sub-list.
+
+This function modifies STRUCT."
+ (save-excursion
+ (org-fold-core-ignore-modifications
+ (let* ((end-A-no-blank (org-list-get-item-end-before-blank beg-A
struct))
+ (end-B-no-blank (org-list-get-item-end-before-blank beg-B
struct))
+ (end-A (org-list-get-item-end beg-A struct))
+ (end-B (org-list-get-item-end beg-B struct))
+ (size-A (- end-A-no-blank beg-A))
+ (size-B (- end-B-no-blank beg-B))
+ (body-A (buffer-substring beg-A end-A-no-blank))
+ (body-B (buffer-substring beg-B end-B-no-blank))
+ (between-A-no-blank-and-B (buffer-substring end-A-no-blank
beg-B))
+ (sub-A (cons beg-A (org-list-get-subtree beg-A struct)))
+ (sub-B (cons beg-B (org-list-get-subtree beg-B struct))))
+ ;; 1. Move effectively items in buffer.
+ (goto-char beg-A)
+ (delete-region beg-A end-B-no-blank)
+ (insert (concat body-B between-A-no-blank-and-B body-A))
+ ;; 2. Now modify struct. No need to re-read the list, the
+ ;; transformation is just a shift of positions. Some special
+ ;; attention is required for items ending at END-A and END-B
+ ;; as empty spaces are not moved there. In others words,
+ ;; item BEG-A will end with whitespaces that were at the end
+ ;; of BEG-B and the same applies to BEG-B.
+ (dolist (e struct)
+ (let ((pos (car e)))
+ (cond
+ ((< pos beg-A))
+ ((memq pos sub-A)
+ (let ((end-e (nth 6 e)))
+ (setcar e (+ pos (- end-B-no-blank end-A-no-blank)))
+ (setcar (nthcdr 6 e)
+ (+ end-e (- end-B-no-blank end-A-no-blank)))
+ (when (= end-e end-A) (setcar (nthcdr 6 e) end-B))))
+ ((memq pos sub-B)
+ (let ((end-e (nth 6 e)))
+ (setcar e (- (+ pos beg-A) beg-B))
+ (setcar (nthcdr 6 e) (+ end-e (- beg-A beg-B)))
+ (when (= end-e end-B)
+ (setcar (nthcdr 6 e)
+ (+ beg-A size-B (- end-A end-A-no-blank))))))
+ ((< pos beg-B)
+ (let ((end-e (nth 6 e)))
+ (setcar e (+ pos (- size-B size-A)))
+ (setcar (nthcdr 6 e) (+ end-e (- size-B size-A))))))))
+ (setq struct (sort struct #'car-less-than-car))
+ ;; Return structure.
+ struct))))
+(defun org-list-swap-items--overlays (beg-A beg-B struct)
"Swap item starting at BEG-A with item starting at BEG-B in STRUCT.
Blank lines at the end of items are left in place. Item
@@ -1164,6 +1222,20 @@ (defun org-list-swap-items (beg-A beg-B struct)
(+ (nth 2 ov) (- beg-A beg-B))))
;; Return structure.
struct)))
+(defsubst org-list-swap-items (beg-A beg-B struct)
+ "Swap item starting at BEG-A with item starting at BEG-B in STRUCT.
+
+Blank lines at the end of items are left in place. Item
+visibility is preserved. Return the new structure after the
+changes.
+
+Assume BEG-A is lesser than BEG-B and that BEG-A and BEG-B belong
+to the same sub-list.
+
+This function modifies STRUCT."
+ (if (eq org-fold-core-style 'text-properties)
+ (org-list-swap-items--text-properties beg-A beg-B struct)
+ (org-list-swap-items--overlays beg-A beg-B struct)))
(defun org-list-separating-blank-lines-number (pos struct prevs)
"Return number of blank lines that should separate items in list.
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index 7703e09e4..a894d4323 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -1109,7 +1109,18 @@ (defun org-find-text-property-in-string (prop s)
(get-text-property (or (next-single-property-change 0 prop s) 0)
prop s)))
-(defun org-invisible-p (&optional pos folding-only)
+;; FIXME: move to org-fold?
+(defun org-invisible-p--text-properties (&optional pos folding-only)
+ "Non-nil if the character after POS is invisible.
+If POS is nil, use `point' instead. When optional argument
+FOLDING-ONLY is non-nil, only consider invisible parts due to
+folding of a headline, a block or a drawer, i.e., not because of
+fontification."
+ (let ((value (invisible-p (or pos (point)))))
+ (cond ((not value) nil)
+ (folding-only (org-fold-folded-p (or pos (point))))
+ (t value))))
+(defun org-invisible-p--overlays (&optional pos folding-only)
"Non-nil if the character after POS is invisible.
If POS is nil, use `point' instead. When optional argument
FOLDING-ONLY is non-nil, only consider invisible parts due to
@@ -1118,7 +1129,16 @@ (defun org-invisible-p (&optional pos folding-only)
(let ((value (get-char-property (or pos (point)) 'invisible)))
(cond ((not value) nil)
(folding-only (memq value '(org-hide-block outline)))
- (t value))))
+ (t (and (invisible-p (or pos (point))) value)))))
+(defsubst org-invisible-p (&optional pos folding-only)
+ "Non-nil if the character after POS is invisible.
+If POS is nil, use `point' instead. When optional argument
+FOLDING-ONLY is non-nil, only consider invisible parts due to
+folding of a headline, a block or a drawer, i.e., not because of
+fontification."
+ (if (eq org-fold-core-style 'text-properties)
+ (org-invisible-p--text-properties pos folding-only)
+ (org-invisible-p--overlays pos folding-only)))
(defun org-truly-invisible-p ()
"Check if point is at a character currently not visible.
@@ -1136,17 +1156,43 @@ (defun org-invisible-p2 ()
(backward-char 1))
(org-invisible-p)))
-(defun org-find-visible ()
+(defun org-region-invisible-p (beg end)
+ "Check if region if completely hidden."
+ (org-with-wide-buffer
+ (and (org-invisible-p beg)
+ (org-invisible-p (org-fold-next-visibility-change beg end)))))
+
+(defun org-find-visible--overlays ()
"Return closest visible buffer position, or `point-max'."
(if (org-invisible-p)
(next-single-char-property-change (point) 'invisible)
(point)))
+(defun org-find-visible--text-properties ()
+ "Return closest visible buffer position, or `point-max'."
+ (if (org-invisible-p)
+ (org-fold-next-visibility-change (point))
+ (point)))
+(defsubst org-find-visible ()
+ "Return closest visible buffer position, or `point-max'."
+ (if (eq org-fold-core-style 'text-properties)
+ (org-find-visible--text-properties)
+ (org-find-visible--overlays)))
-(defun org-find-invisible ()
+(defun org-find-invisible--overlays ()
"Return closest invisible buffer position, or `point-max'."
(if (org-invisible-p)
(point)
(next-single-char-property-change (point) 'invisible)))
+(defun org-find-invisible--text-properties ()
+ "Return closest invisible buffer position, or `point-max'."
+ (if (org-invisible-p)
+ (point)
+ (org-fold-next-visibility-change (point))))
+(defsubst org-find-invisible ()
+ "Return closest invisible buffer position, or `point-max'."
+ (if (eq org-fold-core-style 'text-properties)
+ (org-find-invisible--text-properties)
+ (org-find-invisible--overlays)))
;;; Time
diff --git a/lisp/org.el b/lisp/org.el
index f6709f4cc..0b50e30d9 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -4912,7 +4912,7 @@ (defconst org-nonsticky-props
(defsubst org-rear-nonsticky-at (pos)
(add-text-properties (1- pos) pos (list 'rear-nonsticky
org-nonsticky-props)))
-(defun org-activate-links (limit)
+(defun org-activate-links--overlays (limit)
"Add link properties to links.
This includes angle, plain, and bracket links."
(catch :exit
@@ -4927,13 +4927,13 @@ (defun org-activate-links (limit)
(when (and (memq style org-highlight-links)
;; Do not span over paragraph boundaries.
(not (string-match-p org-element-paragraph-separate
- (match-string 0)))
+ (match-string 0)))
;; Do not confuse plain links with tags.
(not (and (eq style 'plain)
- (let ((face (get-text-property
- (max (1- start) (point-min)) 'face)))
- (if (consp face) (memq 'org-tag face)
- (eq 'org-tag face))))))
+ (let ((face (get-text-property
+ (max (1- start) (point-min)) 'face)))
+ (if (consp face) (memq 'org-tag face)
+ (eq 'org-tag face))))))
(let* ((link-object (save-excursion
(goto-char start)
(save-match-data (org-element-link-parser))))
@@ -4983,6 +4983,99 @@ (defun org-activate-links (limit)
(funcall f start end path (eq style 'bracket))))
(throw :exit t))))) ;signal success
nil))
+(defun org-activate-links--text-properties (limit)
+ "Add link properties to links.
+This includes angle, plain, and bracket links."
+ (catch :exit
+ (while (re-search-forward org-link-any-re limit t)
+ (let* ((start (match-beginning 0))
+ (end (match-end 0))
+ (visible-start (or (match-beginning 3) (match-beginning 2)))
+ (visible-end (or (match-end 3) (match-end 2)))
+ (style (cond ((eq ?< (char-after start)) 'angle)
+ ((eq ?\[ (char-after (1+ start))) 'bracket)
+ (t 'plain))))
+ (when (and (memq style org-highlight-links)
+ ;; Do not span over paragraph boundaries.
+ (not (string-match-p org-element-paragraph-separate
+ (match-string 0)))
+ ;; Do not confuse plain links with tags.
+ (not (and (eq style 'plain)
+ (let ((face (get-text-property
+ (max (1- start) (point-min)) 'face)))
+ (if (consp face) (memq 'org-tag face)
+ (eq 'org-tag face))))))
+ (let* ((link-object (save-excursion
+ (goto-char start)
+ (save-match-data (org-element-link-parser))))
+ (link (org-element-property :raw-link link-object))
+ (type (org-element-property :type link-object))
+ (path (org-element-property :path link-object))
+ (face-property (pcase (org-link-get-parameter type :face)
+ ((and (pred functionp) face) (funcall face
path))
+ ((and (pred facep) face) face)
+ ((and (pred consp) face) face) ;anonymous
+ (_ 'org-link)))
+ (properties ;for link's visible part
+ (list 'mouse-face (or (org-link-get-parameter type
:mouse-face)
+ 'highlight)
+ 'keymap (or (org-link-get-parameter type :keymap)
+ org-mouse-map)
+ 'help-echo (pcase (org-link-get-parameter type
:help-echo)
+ ((and (pred stringp) echo) echo)
+ ((and (pred functionp) echo) echo)
+ (_ (concat "LINK: " link)))
+ 'htmlize-link (pcase (org-link-get-parameter type
+ :htmlize-link)
+ ((and (pred functionp) f) (funcall f))
+ (_ `(:uri ,link)))
+ 'font-lock-multiline t)))
+ (org-remove-flyspell-overlays-in start end)
+ (org-rear-nonsticky-at end)
+ (if (not (eq 'bracket style))
+ (progn
+ (add-face-text-property start end face-property)
+ (add-text-properties start end properties))
+ ;; Initialise folding when used ouside org-mode.
+ (unless (or (derived-mode-p 'org-mode)
+ (and (org-fold-folding-spec-p 'org-link-description)
+ (org-fold-folding-spec-p 'org-link)))
+ (org-fold-initialize (or (and (stringp org-ellipsis) (not
(equal "" org-ellipsis)) org-ellipsis)
+ "...")))
+ ;; Handle invisible parts in bracket links.
+ (let ((spec (or (org-link-get-parameter type :display)
+ 'org-link)))
+ (unless (org-fold-folding-spec-p spec)
+ (org-fold-add-folding-spec spec
+ (cdr org-link--link-folding-spec)
+ nil
+ 'append)
+ (org-fold-core-set-folding-spec-property spec :visible t))
+ (org-fold-region start end nil 'org-link)
+ (org-fold-region start end nil 'org-link-description)
+ ;; We are folding the whole emphasised text with SPEC
+ ;; first. It makes everything invisible (or whatever
+ ;; the user wants).
+ (org-fold-region start end t spec)
+ ;; The visible part of the text is folded using
+ ;; 'org-link-description, which is forcing this part of
+ ;; the text to be visible.
+ (org-fold-region visible-start visible-end t
'org-link-description)
+ (add-text-properties start end properties)
+ (add-face-text-property start end face-property)
+ (org-rear-nonsticky-at visible-start)
+ (org-rear-nonsticky-at visible-end)))
+ (let ((f (org-link-get-parameter type :activate-func)))
+ (when (functionp f)
+ (funcall f start end path (eq style 'bracket))))
+ (throw :exit t))))) ;signal success
+ nil))
+(defsubst org-activate-links (limit)
+ "Add link properties to links.
+This includes angle, plain, and bracket links."
+ (if (eq org-fold-core-style 'text-properties)
+ (org-activate-links--text-properties limit)
+ (org-activate-links--overlays limit)))
(defun org-activate-code (limit)
(when (re-search-forward "^[ \t]*\\(:\\(?: .*\\|$\\)\n?\\)" limit t)
@@ -6740,81 +6833,82 @@ (defun org-paste-subtree (&optional level tree for-yank
remove)
(substitute-command-keys
"The kill is not a (set of) tree(s). Use `\\[yank]' to yank anyway")))
(org-with-limited-levels
- (let* ((visp (not (org-invisible-p)))
- (txt tree)
- (old-level (if (string-match org-outline-regexp-bol txt)
- (- (match-end 0) (match-beginning 0) 1)
- -1))
- (force-level
- (cond
- (level (prefix-numeric-value level))
- ;; When point is after the stars in an otherwise empty
- ;; headline, use the number of stars as the forced level.
- ((and (org-match-line "^\\*+[ \t]*$")
- (not (eq ?* (char-after))))
- (org-outline-level))
- ((looking-at-p org-outline-regexp-bol) (org-outline-level))))
- (previous-level
- (save-excursion
- (org-previous-visible-heading 1)
- (if (org-at-heading-p) (org-outline-level) 1)))
- (next-level
- (save-excursion
- (if (org-at-heading-p) (org-outline-level)
- (org-next-visible-heading 1)
- (if (org-at-heading-p) (org-outline-level) 1))))
- (new-level (or force-level (max previous-level next-level)))
- (shift (if (or (= old-level -1)
- (= new-level -1)
- (= old-level new-level))
- 0
- (- new-level old-level)))
- (delta (if (> shift 0) -1 1))
- (func (if (> shift 0) #'org-demote #'org-promote))
- (org-odd-levels-only nil)
- beg end newend)
- ;; Remove the forced level indicator.
- (when (and force-level (not level))
- (delete-region (line-beginning-position) (point)))
- ;; Paste before the next visible heading or at end of buffer,
- ;; unless point is at the beginning of a headline.
- (unless (and (bolp) (org-at-heading-p))
- (org-next-visible-heading 1)
- (unless (bolp) (insert "\n")))
- (setq beg (point))
- ;; Avoid re-parsing cache elements when i.e. level 1 heading
- ;; is inserted and then promoted.
- (combine-change-calls beg beg
- (when (fboundp 'org-id-paste-tracker) (org-id-paste-tracker txt))
- (insert-before-markers txt)
- (unless (string-suffix-p "\n" txt) (insert "\n"))
- (setq newend (point))
- (org-reinstall-markers-in-region beg)
- (setq end (point))
- (goto-char beg)
- (skip-chars-forward " \t\n\r")
- (setq beg (point))
- (when (and (org-invisible-p) visp)
- (save-excursion (outline-show-heading)))
- ;; Shift if necessary.
- (unless (= shift 0)
- (save-restriction
- (narrow-to-region beg end)
- (while (not (= shift 0))
- (org-map-region func (point-min) (point-max))
- (setq shift (+ delta shift)))
- (goto-char (point-min))
- (setq newend (point-max)))))
- (when (or for-yank (called-interactively-p 'interactive))
- (message "Clipboard pasted as level %d subtree" new-level))
- (when (and (not for-yank) ; in this case, org-yank will decide about
folding
- kill-ring
- (equal org-subtree-clip (current-kill 0))
- org-subtree-clip-folded)
- ;; The tree was folded before it was killed/copied
- (org-flag-subtree t))
- (when for-yank (goto-char newend))
- (when remove (pop kill-ring)))))
+ (org-fold-core-ignore-fragility-checks
+ (let* ((visp (not (org-invisible-p)))
+ (txt tree)
+ (old-level (if (string-match org-outline-regexp-bol txt)
+ (- (match-end 0) (match-beginning 0) 1)
+ -1))
+ (force-level
+ (cond
+ (level (prefix-numeric-value level))
+ ;; When point is after the stars in an otherwise empty
+ ;; headline, use the number of stars as the forced level.
+ ((and (org-match-line "^\\*+[ \t]*$")
+ (not (eq ?* (char-after))))
+ (org-outline-level))
+ ((looking-at-p org-outline-regexp-bol) (org-outline-level))))
+ (previous-level
+ (save-excursion
+ (org-previous-visible-heading 1)
+ (if (org-at-heading-p) (org-outline-level) 1)))
+ (next-level
+ (save-excursion
+ (if (org-at-heading-p) (org-outline-level)
+ (org-next-visible-heading 1)
+ (if (org-at-heading-p) (org-outline-level) 1))))
+ (new-level (or force-level (max previous-level next-level)))
+ (shift (if (or (= old-level -1)
+ (= new-level -1)
+ (= old-level new-level))
+ 0
+ (- new-level old-level)))
+ (delta (if (> shift 0) -1 1))
+ (func (if (> shift 0) #'org-demote #'org-promote))
+ (org-odd-levels-only nil)
+ beg end newend)
+ ;; Remove the forced level indicator.
+ (when (and force-level (not level))
+ (delete-region (line-beginning-position) (point)))
+ ;; Paste before the next visible heading or at end of buffer,
+ ;; unless point is at the beginning of a headline.
+ (unless (and (bolp) (org-at-heading-p))
+ (org-next-visible-heading 1)
+ (unless (bolp) (insert "\n")))
+ (setq beg (point))
+ ;; Avoid re-parsing cache elements when i.e. level 1 heading
+ ;; is inserted and then promoted.
+ (combine-change-calls beg beg
+ (when (fboundp 'org-id-paste-tracker) (org-id-paste-tracker txt))
+ (insert-before-markers txt)
+ (unless (string-suffix-p "\n" txt) (insert "\n"))
+ (setq newend (point))
+ (org-reinstall-markers-in-region beg)
+ (setq end (point))
+ (goto-char beg)
+ (skip-chars-forward " \t\n\r")
+ (setq beg (point))
+ (when (and (org-invisible-p) visp)
+ (save-excursion (org-fold-heading nil)))
+ ;; Shift if necessary.
+ (unless (= shift 0)
+ (save-restriction
+ (narrow-to-region beg end)
+ (while (not (= shift 0))
+ (org-map-region func (point-min) (point-max))
+ (setq shift (+ delta shift)))
+ (goto-char (point-min))
+ (setq newend (point-max)))))
+ (when (or for-yank (called-interactively-p 'interactive))
+ (message "Clipboard pasted as level %d subtree" new-level))
+ (when (and (not for-yank) ; in this case, org-yank will decide about
folding
+ kill-ring
+ (equal org-subtree-clip (current-kill 0))
+ org-subtree-clip-folded)
+ ;; The tree was folded before it was killed/copied
+ (org-fold-subtree t))
+ (when for-yank (goto-char newend))
+ (when remove (pop kill-ring))))))
(defun org-kill-is-subtree-p (&optional txt)
"Check if the current kill is an outline subtree, or a set of trees.
@@ -20013,7 +20107,7 @@ (defun org-backward-heading-same-level (arg &optional
invisible-ok)
(interactive "p")
(org-forward-heading-same-level (if arg (- arg) -1) invisible-ok))
-(defun org-next-visible-heading (arg)
+(defun org-next-visible-heading--overlays (arg)
"Move to the next visible heading line.
With ARG, repeats or can move backward if negative."
(interactive "p")
@@ -20039,6 +20133,35 @@ (defun org-next-visible-heading (arg)
nil))) ;leave the loop
(cl-decf arg))
(if (> arg 0) (goto-char (point-max)) (beginning-of-line))))
+(defun org-next-visible-heading--text-properties (arg)
+ "Move to the next visible heading line.
+With ARG, repeats or can move backward if negative."
+ (interactive "p")
+ (let ((regexp (concat "^" (org-get-limited-outline-regexp))))
+ (if (< arg 0)
+ (beginning-of-line)
+ (end-of-line))
+ (while (and (< arg 0) (re-search-backward regexp nil :move))
+ (unless (bobp)
+ (when (org-fold-folded-p)
+ (goto-char (org-fold-previous-visibility-change))
+ (unless (looking-at-p regexp)
+ (re-search-backward regexp nil :mode))))
+ (cl-incf arg))
+ (while (and (> arg 0) (re-search-forward regexp nil :move))
+ (when (org-fold-folded-p)
+ (goto-char (org-fold-next-visibility-change))
+ (skip-chars-forward " \t\n")
+ (end-of-line))
+ (cl-decf arg))
+ (if (> arg 0) (goto-char (point-max)) (beginning-of-line))))
+(defun org-next-visible-heading (arg)
+ "Move to the next visible heading line.
+With ARG, repeats or can move backward if negative."
+ (interactive "p")
+ (if (eq org-fold-core-style 'text-properties)
+ (org-next-visible-heading--text-properties arg)
+ (org-next-visible-heading--overlays arg)))
(defun org-previous-visible-heading (arg)
"Move to the previous visible heading.
@@ -20171,7 +20294,7 @@ (defun org--paragraph-at-point ()
(list :begin b :end e :parent p :post-blank 0 :post-affiliated b)))
(_ e))))
-(defun org--forward-paragraph-once ()
+(defun org--forward-paragraph-once--overlays ()
"Move forward to end of paragraph or equivalent, once.
See `org-forward-paragraph'."
(interactive)
@@ -20243,8 +20366,84 @@ (defun org--forward-paragraph-once ()
(goto-char end)
(skip-chars-backward " \t\n")
(forward-line))))))))
+(defun org--forward-paragraph-once--text-properties ()
+ "Move forward to end of paragraph or equivalent, once.
+See `org-forward-paragraph'."
+ (interactive)
+ (save-restriction
+ (widen)
+ (skip-chars-forward " \t\n")
+ (cond
+ ((eobp) nil)
+ ;; When inside a folded part, move out of it.
+ ((when (org-invisible-p nil t)
+ (goto-char (cdr (org-fold-get-region-at-point)))
+ (forward-line)
+ t))
+ (t
+ (let* ((element (org--paragraph-at-point))
+ (type (org-element-type element))
+ (contents-begin (org-element-property :contents-begin element))
+ (end (org-element-property :end element))
+ (post-affiliated (org-element-property :post-affiliated element)))
+ (cond
+ ((eq type 'plain-list)
+ (forward-char)
+ (org--forward-paragraph-once))
+ ;; If the element is folded, skip it altogether.
+ ((when (org-with-point-at post-affiliated (org-invisible-p
(line-end-position) t))
+ (goto-char (cdr (org-fold-get-region-at-point
+ nil
+ (org-with-point-at post-affiliated
+ (line-end-position)))))
+ (forward-line)
+ t))
+ ;; At a greater element, move inside.
+ ((and contents-begin
+ (> contents-begin (point))
+ (not (eq type 'paragraph)))
+ (goto-char contents-begin)
+ ;; Items and footnote definitions contents may not start at
+ ;; the beginning of the line. In this case, skip until the
+ ;; next paragraph.
+ (cond
+ ((not (bolp)) (org--forward-paragraph-once))
+ ((org-previous-line-empty-p) (forward-line -1))
+ (t nil)))
+ ;; Move between empty lines in some blocks.
+ ((memq type '(comment-block example-block export-block src-block
+ verse-block))
+ (let ((contents-start
+ (org-with-point-at post-affiliated
+ (line-beginning-position 2))))
+ (if (< (point) contents-start)
+ (goto-char contents-start)
+ (let ((contents-end
+ (org-with-point-at end
+ (skip-chars-backward " \t\n")
+ (line-beginning-position))))
+ (cond
+ ((>= (point) contents-end)
+ (goto-char end)
+ (skip-chars-backward " \t\n")
+ (forward-line))
+ ((re-search-forward "^[ \t]*\n" contents-end :move)
+ (forward-line -1))
+ (t nil))))))
+ (t
+ ;; Move to element's end.
+ (goto-char end)
+ (skip-chars-backward " \t\n")
+ (forward-line))))))))
+(defun org--forward-paragraph-once ()
+ "Move forward to end of paragraph or equivalent, once.
+See `org-forward-paragraph'."
+ (interactive)
+ (if (eq org-fold-core-style 'text-properties)
+ (org--forward-paragraph-once--text-properties)
+ (org--forward-paragraph-once--overlays)))
-(defun org--backward-paragraph-once ()
+(defun org--backward-paragraph-once--overlays ()
"Move backward to start of paragraph or equivalent, once.
See `org-backward-paragraph'."
(interactive)
@@ -20346,6 +20545,108 @@ (defun org--backward-paragraph-once ()
;; Move to element's start.
(t
(funcall reach begin))))))))
+(defun org--backward-paragraph-once--text-properties ()
+ "Move backward to start of paragraph or equivalent, once.
+See `org-backward-paragraph'."
+ (interactive)
+ (save-restriction
+ (widen)
+ (cond
+ ((bobp) nil)
+ ;; Blank lines at the beginning of the buffer.
+ ((and (org-match-line "^[ \t]*$")
+ (save-excursion (skip-chars-backward " \t\n") (bobp)))
+ (goto-char (point-min)))
+ ;; When inside a folded part, move out of it.
+ ((when (org-invisible-p (1- (point)) t)
+ (goto-char (1- (car (org-fold-get-region-at-point nil (1- (point))))))
+ (org--backward-paragraph-once)
+ t))
+ (t
+ (let* ((element (org--paragraph-at-point))
+ (type (org-element-type element))
+ (begin (org-element-property :begin element))
+ (post-affiliated (org-element-property :post-affiliated element))
+ (contents-end (org-element-property :contents-end element))
+ (end (org-element-property :end element))
+ (parent (org-element-property :parent element))
+ (reach
+ ;; Move to the visible empty line above position P, or
+ ;; to position P. Return t.
+ (lambda (p)
+ (goto-char p)
+ (when (and (org-previous-line-empty-p)
+ (let ((end (line-end-position 0)))
+ (or (= end (point-min))
+ (not (org-invisible-p (1- end))))))
+ (forward-line -1))
+ t)))
+ (cond
+ ;; Already at the beginning of an element.
+ ((= begin (point))
+ (cond
+ ;; There is a blank line above. Move there.
+ ((and (org-previous-line-empty-p)
+ (not (org-invisible-p (1- (line-end-position 0)))))
+ (forward-line -1))
+ ;; At the beginning of the first element within a greater
+ ;; element. Move to the beginning of the greater element.
+ ((and parent
+ (not (eq 'section (org-element-type parent)))
+ (= begin (org-element-property :contents-begin parent)))
+ (funcall reach (org-element-property :begin parent)))
+ ;; Since we have to move anyway, find the beginning
+ ;; position of the element above.
+ (t
+ (forward-char -1)
+ (org--backward-paragraph-once))))
+ ;; Skip paragraphs at the very beginning of footnote
+ ;; definitions or items.
+ ((and (eq type 'paragraph)
+ (org-with-point-at begin (not (bolp))))
+ (funcall reach (progn (goto-char begin) (line-beginning-position))))
+ ;; If the element is folded, skip it altogether.
+ ((org-with-point-at post-affiliated (org-invisible-p
(line-end-position) t))
+ (funcall reach begin))
+ ;; At the end of a greater element, move inside.
+ ((and contents-end
+ (<= contents-end (point))
+ (not (eq type 'paragraph)))
+ (cond
+ ((memq type '(footnote-definition plain-list))
+ (skip-chars-backward " \t\n")
+ (org--backward-paragraph-once))
+ ((= contents-end (point))
+ (forward-char -1)
+ (org--backward-paragraph-once))
+ (t
+ (goto-char contents-end))))
+ ;; Move between empty lines in some blocks.
+ ((and (memq type '(comment-block example-block export-block src-block
+ verse-block))
+ (let ((contents-start
+ (org-with-point-at post-affiliated
+ (line-beginning-position 2))))
+ (when (> (point) contents-start)
+ (let ((contents-end
+ (org-with-point-at end
+ (skip-chars-backward " \t\n")
+ (line-beginning-position))))
+ (if (> (point) contents-end)
+ (progn (goto-char contents-end) t)
+ (skip-chars-backward " \t\n" begin)
+ (re-search-backward "^[ \t]*\n" contents-start :move)
+ t))))))
+ ;; Move to element's start.
+ (t
+ (funcall reach begin))))))))
+(defun org--backward-paragraph-once ()
+ "Move backward to start of paragraph or equivalent, once.
+See `org-backward-paragraph'."
+ (interactive)
+ (if (eq org-fold-core-style 'text-properties)
+ (org--backward-paragraph-once--text-properties)
+ (org--backward-paragraph-once--overlays)))
(defun org-forward-element ()
"Move forward by one element.
--
2.35.1
--
Ihor Radchenko,
PhD,
Center for Advancing Materials Performance from the Nanoscale (CAMP-nano)
State Key Laboratory for Mechanical Behavior of Materials, Xi'an Jiaotong
University, Xi'an, China
Email: yantar92@gmail.com, ihor_radchenko@alumni.sutd.edu.sg
- [PATCH v2 02/38] Separate folding functions from org.el into new library: org-fold, (continued)
- [PATCH v2 02/38] Separate folding functions from org.el into new library: org-fold, Ihor Radchenko, 2022/04/20
- [PATCH v2 03/38] Separate cycling functions from org.el into new library: org-cycle, Ihor Radchenko, 2022/04/20
- [PATCH v2 04/38] Remove functions from org.el that are now moved elsewhere, Ihor Radchenko, 2022/04/20
- [PATCH v2 05/38] Disable native-comp in agendaIt caused cryptic bugs in the past., Ihor Radchenko, 2022/04/20
- [PATCH v2 06/38] org-macs: New function org-find-text-property-region---, Ihor Radchenko, 2022/04/20
- [PATCH v2 07/38] org-at-heading-p: Accept optional argument* lisp/org.el (org-at-heading-p): Use second argument to allow, Ihor Radchenko, 2022/04/20
- [PATCH v2 08/38] org-string-width: Reimplement to work with new folding, Ihor Radchenko, 2022/04/20
- [PATCH v2 09/38] Rename old function call to use org-fold---, Ihor Radchenko, 2022/04/20
- [PATCH v2 10/38] Implement link folding* lisp/ol.el (org-link--link-folding-spec):, Ihor Radchenko, 2022/04/20
- [PATCH v2 12/38] org-fold: Handle indirect buffer visibility---, Ihor Radchenko, 2022/04/20
- [PATCH v2 11/38] Implement overlay- and text-property-based versions of some functions,
Ihor Radchenko <=
- [PATCH v2 13/38] Fix subtle differences between overlays and invisible text properties, Ihor Radchenko, 2022/04/20
- [PATCH v2 14/38] Support extra org-fold optimisations for huge buffers, Ihor Radchenko, 2022/04/20
- [PATCH v2 15/38] Alias new org-fold functions to their old shorter names, Ihor Radchenko, 2022/04/20
- [PATCH v2 16/38] Obsolete old function names that are now in org-fold---, Ihor Radchenko, 2022/04/20
- [PATCH v2 18/38] Move `org-buffer-list' to org-macs.el---, Ihor Radchenko, 2022/04/20
- [PATCH v2 19/38] Restore old visibility behaviour of org-refile---, Ihor Radchenko, 2022/04/20
- [PATCH v2 17/38] org-compat: Work around some third-party packages using outline-* functions, Ihor Radchenko, 2022/04/20
- [PATCH v2 20/38] Add org-fold-related tests---, Ihor Radchenko, 2022/04/20
- [PATCH v2 22/38] ORG-NEWS: Add list of changes---, Ihor Radchenko, 2022/04/20
- [PATCH v2 23/38] Backport contributed commits---, Ihor Radchenko, 2022/04/20