From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp11.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms5.migadu.com with LMTPS id qFDEBn0NYGKq+QAAbAwnHQ (envelope-from ) for ; Wed, 20 Apr 2022 15:41:17 +0200 Received: from aspmx1.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp11.migadu.com with LMTPS id sFW8Bn0NYGJQ1AAA9RJhRA (envelope-from ) for ; Wed, 20 Apr 2022 15:41:17 +0200 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 83E0617B27 for ; Wed, 20 Apr 2022 15:41:16 +0200 (CEST) Received: from localhost ([::1]:47650 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1nhAa3-0002XK-MH for larch@yhetil.org; Wed, 20 Apr 2022 09:41:15 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:36934) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nhAK0-00041z-NP for emacs-orgmode@gnu.org; Wed, 20 Apr 2022 09:24:41 -0400 Received: from mail-pl1-x631.google.com ([2607:f8b0:4864:20::631]:40631) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1nhAJw-0003OS-42 for emacs-orgmode@gnu.org; Wed, 20 Apr 2022 09:24:40 -0400 Received: by mail-pl1-x631.google.com with SMTP id t12so1756073pll.7 for ; Wed, 20 Apr 2022 06:24:35 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=from:to:subject:in-reply-to:references:message-id:date:mime-version; bh=ZeLlDIyGCbILS+5IPcKydEMyKPBSAUKoxs8Jzx7CxWs=; b=nqbgHtKBV5Z90Occ2EZee/jQaHHwZQmInIBQrkIxYe8FaxG0CBrXEaOHDhkzWPYcKn zjF3TmycjWuCbLdBrLwggwrZvD3iL4C8QRwGAcdEbt/mGpHliuLU6bI+zUiMfZCw73d6 Y8IVmJtB8tHlV0KG2+h7fqRiec7OxBj+Hl9Zz6lCkx0pquW90A6qqhA3QiVn/5BYTSgh HevBbYC6s5Vr4v27wFBsCEFIHCNJIWtnhqr4eszY5U9iBq7ykHMECRpeXIcjfQA9HOyk rmRNkKSxv0lyrGjbFAigv6/fVndgXxdAaQpz+LhK1y2mHFvp+ZMdi3ZxB55qrBkbGWtG jVrA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:from:to:subject:in-reply-to:references :message-id:date:mime-version; bh=ZeLlDIyGCbILS+5IPcKydEMyKPBSAUKoxs8Jzx7CxWs=; b=dcoGjebg3f3aW9CLfpH8Ul7aHNz2fu6qVXjAyU3f7xL1h47vvgfD3BIgn6baRuZobr sjWRgl8b4LA+etuKDnclBX4D6tlBTW+2l0Ka6NQs9CaKMfCC5ysRixkGp3HdZG0CIULP kYEinpM6e+kGRPMNcK/ii4cFIw7PqtjpPoBaSj1O6VmDiaC2KG5Hlg4q7gdQ/xMDSZZ7 /1no4zxyH4r7x3bPSJ9kr4rjZYcSWcXVpxh2nfWbieOUEF1EMkGLcQ6dbQ1dfHDgv+0I F3W0hNjrGpKgb0ppF5EgoMa4Jr3lm8a85Z897CpQgKjZCAQLmLbMGGPjW7Mw2nQzrIhn kFhg== X-Gm-Message-State: AOAM531PsCSq+gTyPZ887ULKu7V25Dxfm2CiBa3Qjh68cxmqFY0GAh5J KrQ3TtyUIK0M3Hh+CX1cyFlrAHEoYhs3Zg== X-Google-Smtp-Source: ABdhPJwv6gfo5xmHVBsx7RFGv1MjP7bhE4bqMDqQo+iQMiMWzoZpm8qcn9FxiH2kp2iujLYmXYpU2w== X-Received: by 2002:a17:902:b692:b0:14c:935b:2b03 with SMTP id c18-20020a170902b69200b0014c935b2b03mr20638691pls.81.1650461073775; Wed, 20 Apr 2022 06:24:33 -0700 (PDT) Received: from localhost ([64.32.23.62]) by smtp.gmail.com with ESMTPSA id e5-20020a656785000000b003a566365b8esm14360194pgr.35.2022.04.20.06.24.32 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 20 Apr 2022 06:24:33 -0700 (PDT) From: Ihor Radchenko To: emacs-orgmode@gnu.org Subject: [PATCH v2 11/38] Implement overlay- and text-property-based versions of some functions In-Reply-To: References: Message-Id: <42bb568b8c7d5d7efa9285aecfa86be7faf745aa.1650460489.git.yantar92@gmail.com> Date: Wed, 20 Apr 2022 21:25:26 +0800 MIME-Version: 1.0 Content-Type: text/plain Received-SPF: pass client-ip=2607:f8b0:4864:20::631; envelope-from=yantar92@gmail.com; helo=mail-pl1-x631.google.com X-Spam_score_int: -18 X-Spam_score: -1.9 X-Spam_bar: - X-Spam_report: (-1.9 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_ENVFROM_END_DIGIT=0.25, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: emacs-orgmode@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-orgmode-bounces+larch=yhetil.org@gnu.org Sender: "Emacs-orgmode" X-Migadu-Flow: FLOW_IN X-Migadu-To: larch@yhetil.org X-Migadu-Country: US ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1650462076; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:mime-version:mime-version: content-type:content-type:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=kRHvnBja3S2wUHh0b5u/geWQCt0GRkPCrBkT+vxP//E=; b=CYcsefTb5hBQn75iaEb1RF7CXu2M05j7ydqeq9L1nbS84BRmpwIGhHh3t/2cFku2QCyd32 FVe4kXmby5rUVaNJTU6gnYfCSJcQZeW2oUndSF4dAoq8Nv9qPKqwnkyvRcyKutgAggeana ve59INI8gMukoMyemLwtkuvRhyFUGqn0+RXlmWACgntKmN1Nwcw8jCrsoh0c9bAVaTpNv3 IQpp9bWi/5NQBFh2WjVBJD0eFKuQATnJp/0/21ybQSYYGHt8d3eo6Kl7gc8aunTEfNj+2b 2S08JXcBxAEo9zi1gQDU4aQfb1rzB9eqii9BOpGZbgfMBY4MzRjL3FVPic0GOw== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1650462076; a=rsa-sha256; cv=none; b=efJTQl6wJUMfPSVyIbCf24PWGca4/b61vl6keZt4lSQlOys5GWNhNau826MdNdX+Mh1CxH C6GnrFAHDkO2NfriSqGXPGjoQOt0VvnZjq17oDEjf5jA7n4YzYImM/4IHaPIaQMUR8Q8W8 b46pwptkDazYwBXE8aOVOVcdc24pXNXzqL0jcsPxi73TDsVGQr5e9pV4i+Zr+JBATL/pUj zfETcMcZaMeCymR4YwjytFUd2GuEoEcWUsddBp7tNcRFpgo5O7/I4ABv5Q1lsyw6NCwSGY m+EHRmfTgdEGBGPejR9Nkp0oe4ZAjzCReup0RZXFXTNZJz1VuSiVX+t7Z0GXsg== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=gmail.com header.s=20210112 header.b=nqbgHtKB; dmarc=fail reason="SPF not aligned (relaxed)" header.from=gmail.com (policy=none); spf=pass (aspmx1.migadu.com: domain of "emacs-orgmode-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="emacs-orgmode-bounces+larch=yhetil.org@gnu.org" X-Migadu-Spam-Score: 7.16 Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=gmail.com header.s=20210112 header.b=nqbgHtKB; dmarc=fail reason="SPF not aligned (relaxed)" header.from=gmail.com (policy=none); spf=pass (aspmx1.migadu.com: domain of "emacs-orgmode-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="emacs-orgmode-bounces+larch=yhetil.org@gnu.org" X-Migadu-Queue-Id: 83E0617B27 X-Spam-Score: 7.16 X-Migadu-Scanner: scn1.migadu.com X-TUID: 4eKM/Fpqk05F --- 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