From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp12.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms0.migadu.com with LMTPS id IMW3Nesq9WGcAwAAgWs5BA (envelope-from ) for ; Sat, 29 Jan 2022 12:54:19 +0100 Received: from aspmx1.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp12.migadu.com with LMTPS id wJJXMusq9WFxiAAAauVa8A (envelope-from ) for ; Sat, 29 Jan 2022 12:54:19 +0100 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 3591C37B57 for ; Sat, 29 Jan 2022 12:54:19 +0100 (CET) Received: from localhost ([::1]:38664 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1nDmJ8-0007XI-9k for larch@yhetil.org; Sat, 29 Jan 2022 06:54:18 -0500 Received: from eggs.gnu.org ([209.51.188.92]:58716) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nDm1E-0002v9-8y for emacs-orgmode@gnu.org; Sat, 29 Jan 2022 06:35:48 -0500 Received: from [2607:f8b0:4864:20::102d] (port=40452 helo=mail-pj1-x102d.google.com) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1nDm1A-0000YO-OK; Sat, 29 Jan 2022 06:35:47 -0500 Received: by mail-pj1-x102d.google.com with SMTP id z10-20020a17090acb0a00b001b520826011so13415550pjt.5; Sat, 29 Jan 2022 03:35:44 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=from:to:cc:subject:date:message-id:in-reply-to:references :mime-version:content-transfer-encoding; bh=rc6OtlUS8LGiLu2DRQbgHZtnEHeIvM8aoysWXGXEYho=; b=kJnRNDLAM0++Tn4tMRCBWWq6B4TBcoBHCivt1EuJJRCXHU+NFQN1Zh9zH6vy5lhybC YmpwKeEd+rnIwMJ0ybLvPQTMgk5DQhx3UfEYcKkZ1H3ot5I7ETEyVu5Z7CkhmzuJtV75 6rOhmtbvKPZUO4ybBP+ADdD8fGqgpj8DsQriczaBfK0ieLo6Q/hwVUwq74nIkB0gNVmV mycZj9hgmAZh8MAyPVPWfp7hKbLstz+zBmOp+lsjQZnk6SbhF7GgvEPCsQ+/PCcZPKjZ zqwhMJ5Gr9YGRjeOg5q7lj9991lK+/tWr6c0seuFSAGml3l5blEqCCkkM4arQxlezZiB LW/g== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:from:to:cc:subject:date:message-id:in-reply-to :references:mime-version:content-transfer-encoding; bh=rc6OtlUS8LGiLu2DRQbgHZtnEHeIvM8aoysWXGXEYho=; b=N6p4tenZ7t33T8VIc92BPlSVzl+CIpyq+RjWFqCqZQP87X8TZECKdQg1jOCjcySi7R 5vi0ZFBHY2mPpfyFxdE9Ymt/f3jT/UOFLGSImBQSYL1JC2q0z1VXYDLXYclwRdNSSFDs Uz8sXurpdBquuS4WSp0V5wti0vpQ15bBTeNmZCSxuYnNVlOnb00p7Axrikcwd+aKCbOy k1RzqHCw3BtsI5H6Ui0ldlCky4E4E2bZHLjPda+DgXsLpKOfFR1HO+6kielp47jEd9sK 3vioda3Jo9LdjRcH86AntuO5KQh70/+0wMq9RUZClrqTQ9y9wQPXWc3fkGvAuVs8AE1U J4ow== X-Gm-Message-State: AOAM530g26l39IsCrsXs4YXNkSggDytOWPxbiUh2BXx8fF+DZgFb4XRI 2HLj4L4vRPethTzW9PViGRlO/NJ2dbKb8JXm X-Google-Smtp-Source: ABdhPJwOpczV/3Lww2hZMni+hOB/IAZBHAsJ0dgoVNWHNYtaic87JnlnqYEFuIkY6XpL6zGUI+lbaQ== X-Received: by 2002:a17:90a:741:: with SMTP id s1mr24834177pje.161.1643456142913; Sat, 29 Jan 2022 03:35:42 -0800 (PST) Received: from localhost ([209.95.60.92]) by smtp.gmail.com with ESMTPSA id lr7sm5856804pjb.42.2022.01.29.03.35.39 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 29 Jan 2022 03:35:42 -0800 (PST) From: Ihor Radchenko To: Bastien , Kyle Meyer , Nicolas Goaziou , Karl Voit , Christian Heinrich , emacs-orgmode@gnu.org Subject: [PATCH 11/35] Implement overlay- and text-property-based versions of some functions Date: Sat, 29 Jan 2022 19:38:03 +0800 Message-Id: <048c8535c5a59d800c79cb84666c5f6f504346a1.1643454546.git.yantar92@gmail.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: <87y2cvloay.fsf@gnu.org> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="------------2.34.1" Content-Transfer-Encoding: 8bit X-Host-Lookup-Failed: Reverse DNS lookup failed for 2607:f8b0:4864:20::102d (failed) Received-SPF: pass client-ip=2607:f8b0:4864:20::102d; envelope-from=yantar92@gmail.com; helo=mail-pj1-x102d.google.com X-Spam_score_int: -10 X-Spam_score: -1.1 X-Spam_bar: - X-Spam_report: (-1.1 / 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, PDS_HP_HELO_NORDNS=0.001, RCVD_IN_DNSWL_NONE=-0.0001, RDNS_NONE=0.793, SPF_HELO_NONE=0.001, SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=no 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: , Cc: Ihor Radchenko Errors-To: emacs-orgmode-bounces+larch=yhetil.org@gnu.org Sender: "Emacs-orgmode" X-Migadu-Flow: FLOW_IN X-Migadu-Country: US ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1643457259; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding: in-reply-to:in-reply-to:references:references:list-id:list-help: list-unsubscribe:list-subscribe:list-post:dkim-signature; bh=4rkCINtE9SlXM/dhZ/Vd0r225eaaLG5PKohCcTuFepc=; b=KpSTC4+KgO/ykLeFDHf/rPBV4cYi9ht3ukwv5WO47usaPPMzh9l6p+I+SR8NouWF5Zd1yE nacUwc8em7b++j/bDiKJ5z2SOjN8LYROqYU3xs4qbxemE87iu1or5PCNq04aVkZ9gnkZyS qfAWaM+Y1lKgP4Z6R3VJLmD2iMFWimPJktPlwIwvXvOx5fgdbmHY3Zl1ze/QyunLkJQQ/K q6FnWq3rArHnNo6wh1HZmXNJ5ua0eCNZegR+gnkoLpW+oL//To5w003iCIj5tmNRVpOj7y qyCEAC/1KUze3bUU8l8YoHPxdLmkKvSwRUFviTabzN48l4TWM6F6ahojxSb85w== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1643457259; a=rsa-sha256; cv=none; b=s61WiaW1Mg7GwViNt5/QHezllKiFBDk8O0+fcdQilbq4y1mz35UBK2WdTGRl1nDlMI8OI8 OVi1w042o5RpsbBO89idxrsCrw4k495Gxgwan/ks+BZ2Wog2LfpgyKIZGKuFv9g9Xm2Ps+ v7zHz7Qk6jWgJr4K0sr2YRiRxnYnBn70QDgYuYEUSOhGIveVY2S5wxrQLKgvlPmnSbaHca +XSgkbtLhXvKoNNqZc3mi9DdDAHPQxZpWGlU/kSHOI9GSLEJTOcJ4P6y2x0/9esZ1jAjFt jE82YfXw2Rwgp+PohdM1pXDf0ONa6WTByesVcrSTlMbgrtdVu9TEzYzv/aBhBw== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=gmail.com header.s=20210112 header.b=kJnRNDLA; 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: -1.03 Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=gmail.com header.s=20210112 header.b=kJnRNDLA; 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: 3591C37B57 X-Spam-Score: -1.03 X-Migadu-Scanner: scn1.migadu.com X-TUID: TW01sl7JY4+T This is a multi-part message in MIME format. --------------2.34.1 Content-Type: text/plain; charset=UTF-8; format=fixed Content-Transfer-Encoding: 8bit --- 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(-) --------------2.34.1 Content-Type: text/x-patch; name="0011-Implement-overlay-and-text-property-based-versions-o.patch" Content-Transfer-Encoding: 8bit Content-Disposition: attachment; filename="0011-Implement-overlay-and-text-property-based-versions-o.patch" diff --git a/lisp/org-element.el b/lisp/org-element.el index 99999fb32..bf9f3b69d 100644 --- a/lisp/org-element.el +++ b/lisp/org-element.el @@ -7905,7 +7905,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." @@ -7973,6 +7973,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 187e9a9ff..3e76eb6b2 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 2968e2ba5..8f2133dd0 100644 --- a/lisp/org-macs.el +++ b/lisp/org-macs.el @@ -1103,7 +1103,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 @@ -1112,7 +1123,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-truely-invisible-p () "Check if point is at a character currently not visible. @@ -1130,17 +1150,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 5465ed3ea..0967cbf1c 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -4911,7 +4911,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 @@ -4926,13 +4926,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)))) @@ -4982,6 +4982,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) @@ -6739,81 +6832,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. @@ -19996,7 +20090,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") @@ -20022,6 +20116,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. @@ -20154,7 +20277,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) @@ -20226,8 +20349,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) @@ -20329,6 +20528,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.34.1--