* Re: Month-week and quarter-week datetrees (RFC and package announcement)
2024-12-16 18:49 ` Ihor Radchenko
2024-12-28 6:09 ` Jack Kamm
@ 2024-12-29 9:18 ` Jack Kamm
2024-12-29 10:33 ` Ihor Radchenko
1 sibling, 1 reply; 7+ messages in thread
From: Jack Kamm @ 2024-12-29 9:18 UTC (permalink / raw)
To: Ihor Radchenko; +Cc: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 1177 bytes --]
Ihor Radchenko <yantar92@posteo.net> writes:
> Jack Kamm <jackkamm@gmail.com> writes:
>
>>> The API of `org-datetree--find-create' is generally very limiting.
>>> It would be nice to come up with something less limiting.
>>
>> Thanks for the feedback -- I'll start working on something along these
>> lines. Though this might take me a little while since the holiday is
>> ending soon :''-(
>
> Maybe the holiday is just beginning this year? Bumping this thread just
> in case ;)
I attach a pair of patches for this.
The first patch is just a prelude, it adds a couple unit tests for bugs
I noticed in the current implementation.
The second patch is the main work. It is a substantial reworking of
org-datetree.el that allows for arbitrary number of datetree levels.
For capture datetrees, :tree-type can now be any subset of (year quarter
month week day), and a datetree with the corresponding levels will be
constructed. Another notable addition is the elisp function
`org-datetree-find-create-hierarchy', which should allow constructing
general datetrees for other calendar systems (e.g. lunar calendars,
university academic calendars, retail 4-4-5 calendars, etc).
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-org-datetree-Add-unit-tests-for-incorrect-sorting.patch --]
[-- Type: text/x-patch, Size: 2547 bytes --]
From b890687ec6732eaf90d4aa03c6ab450504a5988a Mon Sep 17 00:00:00 2001
From: Jack Kamm <jackkamm@gmail.com>
Date: Sun, 29 Dec 2024 00:48:35 -0800
Subject: [PATCH 1/2] org-datetree: Add unit tests for incorrect sorting
*
testing/lisp/test-org-datetree.el (test-org-datetree/find-date-create):
Add test that a subtree is inserted in the correct location, even if
there exists another subtree that looks like a datetree.
(test-org-datetree/find-iso-week-create): Add test that days within a
week spanning 2 years are sorted correctly.
---
testing/lisp/test-org-datetree.el | 39 +++++++++++++++++++++++++++++++
1 file changed, 39 insertions(+)
diff --git a/testing/lisp/test-org-datetree.el b/testing/lisp/test-org-datetree.el
index bd06462f2..620a916df 100644
--- a/testing/lisp/test-org-datetree.el
+++ b/testing/lisp/test-org-datetree.el
@@ -108,6 +108,30 @@ (ert-deftest test-org-datetree/find-date-create ()
(let ((org-datetree-add-timestamp nil))
(org-datetree-find-date-create '(3 29 2012)))
(org-trim (buffer-string)))))
+ ;; Insert at correct location, even if some other heading has a
+ ;; subtree that looks like a datetree
+ (should
+ (string-match
+ "\\`\\* Dummy heading
+
+\\*\\* 2012
+
+\\* 2012
+
+\\*\\* 2012-03 March
+
+\\*\\*\\* 2012-03-29 .*\\'"
+ (org-test-with-temp-text "\
+* Dummy heading
+
+** 2012
+
+* 2012
+
+** 2012-03 March"
+ (let ((org-datetree-add-timestamp nil))
+ (org-datetree-find-date-create '(3 29 2012)))
+ (org-trim (buffer-string)))))
;; Always leave point at beginning of day entry.
(should
(string-match
@@ -188,6 +212,21 @@ (ert-deftest test-org-datetree/find-iso-week-create ()
(org-datetree-find-iso-week-create '(9 1 2015))
(org-datetree-find-iso-week-create '(12 31 2014)))
(org-trim (buffer-string)))))
+ ;; Sort new entry in correct order within its week when
+ ;; iso-week-year is not calendar year
+ (should
+ (string-match
+ "\\`\\* 2015
+
+\\*\\* 2015-W01
+
+\\*\\*\\* 2014-12-31 .*
+\\*\\*\\* 2015-01-01 .*"
+ (org-test-with-temp-text "* 2015"
+ (let ((org-datetree-add-timestamp nil))
+ (org-datetree-find-iso-week-create '(1 1 2015))
+ (org-datetree-find-iso-week-create '(12 31 2014)))
+ (org-trim (buffer-string)))))
;; When `org-datetree-add-timestamp' is non-nil, insert a timestamp
;; in entry. When set to `inactive', insert an inactive one.
(should
--
2.47.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-org-datetree-Add-additional-tree-types-e.g.-quarter-.patch --]
[-- Type: text/x-patch, Size: 29206 bytes --]
From b8cc188103baec26c7af337417f8ef84c2af81da Mon Sep 17 00:00:00 2001
From: Jack Kamm <jackkamm@gmail.com>
Date: Sun, 29 Dec 2024 00:52:59 -0800
Subject: [PATCH 2/2] org-datetree: Add additional tree types (e.g. quarter,
month+week)
* lisp/org-capture.el (org-capture-templates): Update docstring for
new datetree tree-type options.
(org-capture-set-target-location): Allow tree-type to be a set, and
switch to using `org-datetree-find-create-entry' to support this.
* lisp/org-datetree.el: Add requirements on cal-iso and org-element.
(org-datetree-find-date-create,org-datetree-find-month-create): Replace
`org-datetree--find-create-group' with `org-datetree-find-create-entry'.
(org-datetree--find-create-group): Removed in favor of
`org-datetree-find-create-entry'.
(org-datetree-find-iso-week-create): Turn into a wrapper for
`org-datetree-find-create-entry'.
(org-datetree-find-create-entry): Generalizes the now removed
`org-datetree--find-create-group' to handle more general tree type
sets. It is in turn a wrapper around
`org-datetree-find-create-hierarchy' which allows for constructing
other datetree hierarchies.
(org-datetree--compare-fun-from-regex): Generator for
string-comparison functions, used by `org-datetree-find-create-entry'
when calling `org-datetree-find-create-hierarchy'.
(org-datetree-find-create-hierarchy): New function that allows
constructing generic types of datetrees for other calendar systems.
(org-datetree-insert-line): Delete undocumented helper function.
(org-datetree--find-create-subheading): Generic replacement for
`org-datetree--find-create', that doesn't assume year/month/day
calendar system.
*
testing/lisp/test-org-datetree.el (test-org-datetree/find-quarter-month-create):
Test year-quarter-month datetree.
(test-org-datetree/find-quarter-month-day-create): Test
year-quarter-month-day datetree.
(test-org-datetree/find-quarter-week-create): Test year-quarter-week
datetree.
(test-org-datetree/find-month-week-create): Test year-month-week datetree.
---
doc/org-manual.org | 13 +-
etc/ORG-NEWS | 43 ++++
lisp/org-capture.el | 13 +-
lisp/org-datetree.el | 372 +++++++++++++++++-------------
testing/lisp/test-org-datetree.el | 48 ++++
5 files changed, 325 insertions(+), 164 deletions(-)
diff --git a/doc/org-manual.org b/doc/org-manual.org
index 1b3c33f96..93786f3f3 100644
--- a/doc/org-manual.org
+++ b/doc/org-manual.org
@@ -8177,10 +8177,15 @@ Now lets look at the elements of a template definition. Each entry in
- ~:tree-type~ ::
- Use ~week~ to make a week tree instead of the month-day tree,
- i.e., place the headings for each day under a heading with the
- current ISO week. Use ~month~ to group entries by month
- only. Default is to group entries by day.
+ Default is to group entries by day. Use ~week~ to make a week
+ tree instead of the month-day tree, i.e., place the headings for
+ each day under a heading with the current ISO week. Use ~month~
+ to group entries by month only. Use any subset of ~(year quarter
+ month week day)~ to group by the specified levels. In case
+ ~month~ and ~week~ are both specified, weeks are assigned to the
+ month containing Thursday, to be consistent with the ISO year-week
+ rule. In case ~quarter~ and ~week~ but not ~month~ are specified,
+ quarters are 13-week periods; otherwise they are 3-month periods.
- ~:unnarrowed~ ::
diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index 85411ecc1..eb9967e96 100644
--- a/etc/ORG-NEWS
+++ b/etc/ORG-NEWS
@@ -141,6 +141,30 @@ See the new [[info:org#Repeating commands]["Repeating commands"]] section in Org
Tables copied into the clipboard from LibreOffice Calc documents can
now be pasted as an Org table using ~yank-media~.
+*** New datetree capture ~:tree-type~ options
+:PROPERTIES:
+:CUSTOM_ID: 9.8-datetree-treetype
+:END:
+
+For datetree capture, ~:tree-type~ can now be any subset of ~(year
+quarter month week day)~ to construct a datetree with the specified
+levels. For back-compatibility, the default value of ~nil~ is an
+alias for ~(year month day)~, ~month~ is an alias for ~(year month)~,
+and ~week~ is an alias for ~(year week day)~.
+
+If ~:tree-type~ is a superset of ~(month week)~, then weeks are
+assigned to the month containing Thursday, to be consistent with the
+ISO-8601 year-week rule. If ~:tree-type~ contains ~(quarter week)~
+but does not contain ~month~, then quarters are defined as 13-week
+periods (the final quarter of a 53-week year has 14-weeks).
+Otherwise, quarters are defined as 3-month periods.
+
+Furthermore, the new elisp function ~org-datetree-find-create-entry~
+generalizes ~org-datetree-find-date-create~,
+~org-datetree-find-month-create~, and
+~org-datetree-find-iso-week-create~ to handle the new available
+datetree hierarchies.
+
** New and changed options
# Changes deadling with changing default values of customizations,
@@ -281,6 +305,18 @@ leave extra prompts after evaluation, and skipping the prompt
filtering can be more robust for such languages (as this avoids
removing false positive prompts).
+*** Elisp functions for new datetree tree-types
+
+Accompanying the [[#9.8-datetree-treetype][new datetree capture ~:tree-type~ options]], on the
+elisp level ~org-datetree-find-create-entry~ provides the new tree
+type options to generalize ~org-datetree-find-date-create~,
+~org-datetree-find-month-create~, and
+~org-datetree-find-iso-week-create~.
+
+In addition, ~org-datetree-find-create-hierarchy~ provides a mechanism
+for constructing datetrees for other calendar systems (e.g. lunar
+calendar, school semesters, the retail 4-4-5 calendar, etc).
+
** Removed or renamed functions and variables
*** ~org-cycle-display-inline-images~ is renamed to ~org-cycle-display-link-previews~
@@ -299,6 +335,13 @@ previews of supported link types besides image links.
The behavior is unchanged, except in that the new variable now affects
previews of supported link types besides image links.
+*** Obsolete functions and variables removed from ~org-datetree~
+
+Due to the refactoring of ~org-datetree~ to support the [[#9.8-datetree-treetype][new datetree
+capture ~:tree-type~ options]], the internal variable
+~org-datetree-base-level~ has been removed, as well as the
+undocumented helper function ~org-datetree-insert-line~.
+
** Miscellaneous
*** Org mode no longer prevents =flyspell= from spell-checking inside =LOGBOOK= drawers
diff --git a/lisp/org-capture.el b/lisp/org-capture.el
index 486304df2..5d6f1df2d 100644
--- a/lisp/org-capture.el
+++ b/lisp/org-capture.el
@@ -293,7 +293,9 @@ (defcustom org-capture-templates nil
:tree-type When `week', make a week tree instead of the month-day
tree. When `month', make a month tree instead of the
- month-day tree.
+ month-day tree. When any subset of
+ `(year quarter month week day)', create a datetree
+ hierarchy with the specified levels.
:unnarrowed Do not narrow the target buffer, simply show the
full buffer. Default is to narrow it so that you
@@ -1090,10 +1092,13 @@ (defun org-capture-set-target-location (&optional target)
;; yesterday, if we are extending dates for a couple of
;; hours)
(funcall
+ #'org-datetree-find-create-entry
(pcase (org-capture-get :tree-type)
- (`week #'org-datetree-find-iso-week-create)
- (`month #'org-datetree-find-month-create)
- (_ #'org-datetree-find-date-create))
+ (`week '(year week day))
+ (`month '(year month))
+ (`day '(year month day))
+ ((pred not) '(year month day))
+ (grouping grouping))
(calendar-gregorian-from-absolute
(cond
(org-overriding-default-time
diff --git a/lisp/org-datetree.el b/lisp/org-datetree.el
index d0cc1fabb..7101cbf93 100644
--- a/lisp/org-datetree.el
+++ b/lisp/org-datetree.el
@@ -24,23 +24,20 @@
;;
;;; Commentary:
-;; This file contains code to create entries in a tree where the top-level
-;; nodes represent years, the level 2 nodes represent the months, and the
-;; level 1 entries days.
+;; This file contains code to create entries in a tree where the
+;; top-level nodes represent years, the level 2 nodes represent the
+;; months, and the level 1 entries days. It also implements
+;; extensions to the datetree that allow for other levels such as
+;; quarters and weeks.
;;; Code:
(require 'org-macs)
(org-assert-version)
+(require 'cal-iso)
(require 'org)
-
-(defvar org-datetree-base-level 1
- "The level at which years should be placed in the date tree.
-This is normally one, but if the buffer has an entry with a
-DATE_TREE (or WEEK_TREE for ISO week entries) property (any
-value), the date tree will become a subtree under that entry, so
-the base level will be properly adjusted.")
+(require 'org-element)
(defcustom org-datetree-add-timestamp nil
"When non-nil, add a time stamp matching date of entry.
@@ -59,174 +56,237 @@ (defun org-datetree-find-date-create (d &optional keep-restriction)
When it is nil, the buffer will be widened to make sure an existing date
tree can be found. If it is the symbol `subtree-at-point', then the tree
will be built under the headline at point."
- (org-datetree--find-create-group d 'day keep-restriction))
+ (org-datetree-find-create-entry '(year month day) d keep-restriction))
;;;###autoload
(defun org-datetree-find-month-create (d &optional keep-restriction)
"Find or create a month entry for date D.
Compared to `org-datetree-find-date-create' this function creates
-entries grouped by month instead of days.
+entries grouped by year-month instead of year-month-day.
If KEEP-RESTRICTION is non-nil, do not widen the buffer.
When it is nil, the buffer will be widened to make sure an existing date
tree can be found. If it is the symbol `subtree-at-point', then the tree
will be built under the headline at point."
- (org-datetree--find-create-group d 'month keep-restriction))
-
-(defun org-datetree--find-create-group
- (d time-grouping &optional keep-restriction)
- "Find or create an entry for date D.
-If time-period is day, group entries by day.
-If time-period is month, then group entries by month."
- (setq-local org-datetree-base-level 1)
- (save-restriction
- (if (eq keep-restriction 'subtree-at-point)
- (progn
- (unless (org-at-heading-p) (error "Not at heading"))
- (widen)
- (org-narrow-to-subtree)
- (setq-local org-datetree-base-level
- (org-get-valid-level (org-current-level) 1)))
- (unless keep-restriction (widen))
- ;; Support the old way of tree placement, using a property
- (let ((prop (org-find-property "DATE_TREE")))
- (when prop
- (goto-char prop)
- (setq-local org-datetree-base-level
- (org-get-valid-level (org-current-level) 1))
- (org-narrow-to-subtree))))
- (goto-char (point-min))
- (let ((year (calendar-extract-year d))
- (month (calendar-extract-month d))
- (day (calendar-extract-day d)))
- (org-datetree--find-create
- "\\([12][0-9]\\{3\\}\\)"
- year nil nil nil t)
- (org-datetree--find-create
- "%d-\\([01][0-9]\\) \\w+"
- year month nil nil t)
- (when (eq time-grouping 'day)
- (org-datetree--find-create
- "%d-%02d-\\([0123][0-9]\\) \\w+"
- year month day nil t)))))
+ (org-datetree-find-create-entry '(year month) d keep-restriction))
;;;###autoload
(defun org-datetree-find-iso-week-create (d &optional keep-restriction)
"Find or create an ISO week entry for date D.
Compared to `org-datetree-find-date-create' this function creates
-entries ordered by week instead of months.
-When it is nil, the buffer will be widened to make sure an existing date
-tree can be found. If it is the symbol `subtree-at-point', then the tree
-will be built under the headline at point."
- (setq-local org-datetree-base-level 1)
- (save-restriction
- (if (eq keep-restriction 'subtree-at-point)
- (progn
- (unless (org-at-heading-p) (error "Not at heading"))
- (widen)
- (org-narrow-to-subtree)
- (setq-local org-datetree-base-level
- (org-get-valid-level (org-current-level) 1)))
- (unless keep-restriction (widen))
- ;; Support the old way of tree placement, using a property
- (let ((prop (org-find-property "WEEK_TREE")))
- (when prop
- (goto-char prop)
- (setq-local org-datetree-base-level
- (org-get-valid-level (org-current-level) 1))
- (org-narrow-to-subtree))))
- (goto-char (point-min))
- (require 'cal-iso)
- (let* ((year (calendar-extract-year d))
- (month (calendar-extract-month d))
- (day (calendar-extract-day d))
- (time (org-encode-time 0 0 0 day month year))
- (iso-date (calendar-iso-from-absolute
- (calendar-absolute-from-gregorian d)))
- (weekyear (nth 2 iso-date))
- (week (nth 0 iso-date)))
- ;; ISO 8601 week format is %G-W%V(-%u)
- (org-datetree--find-create
- "\\([12][0-9]\\{3\\}\\)"
- weekyear nil nil (format-time-string "%G" time) t)
- (org-datetree--find-create
- "%d-W\\([0-5][0-9]\\)"
- weekyear week nil (format-time-string "%G-W%V" time) t)
- ;; For the actual day we use the regular date instead of ISO week.
- (org-datetree--find-create
- "%d-%02d-\\([0123][0-9]\\) \\w+" year month day nil t))))
+entries grouped by year-week-day instead of year-month-day. If
+KEEP-RESTRICTION is non-nil, do not widen the buffer. When it is
+nil, the buffer will be widened to make sure an existing date
+tree can be found. If it is the symbol `subtree-at-point', then
+the tree will be built under the headline at point."
+ (org-datetree-find-create-entry '(year week day) d keep-restriction))
-(defun org-datetree--find-create
- (regex-template year &optional month day insert match-title)
- "Find the datetree matched by REGEX-TEMPLATE for YEAR, MONTH, or DAY.
-REGEX-TEMPLATE is passed to `format' with YEAR, MONTH, and DAY as
-arguments.
+;;;###autoload
+(defun org-datetree-find-create-entry
+ (time-grouping d &optional keep-restriction)
+ "Find or create an entry for date D.
+TIME-GROUPING specifies the grouping levels of the datetree, and
+should be a subset of `(year quarter month week day)'. Weeks are
+assigned to years according to ISO-8601. If TIME-GROUPING
+contains both `month' and `week', then weeks are assigned to the
+month containing Thursday, for consistency with the ISO-8601
+year-week rule. If TIME-GROUPING contains `quarter' and `week'
+but not `month', quarters are defined as 13-week periods;
+otherwise they are defined as 3-month periods.
-If MATCH-TITLE is non-nil, REGEX-TEMPLATE is matched against
-heading title and the exact regexp matched against heading line is:
+If KEEP-RESTRICTION is non-nil, do not widen the buffer. When it
+is nil, the buffer will be widened to make sure an existing date
+tree can be found. If it is the symbol `subtree-at-point', then
+the tree will be built under the headline at point."
+ (let* ((year (calendar-extract-year d))
+ (month (calendar-extract-month d))
+ (day (calendar-extract-day d))
+ (time (org-encode-time 0 0 0 day month year))
+ (iso-date (calendar-iso-from-absolute
+ (calendar-absolute-from-gregorian d)))
+ (week (nth 0 iso-date))
+ (nominal-year
+ (if (memq 'week time-grouping)
+ (nth 2 iso-date)
+ year))
+ (nominal-month
+ (if (memq 'week time-grouping)
+ (calendar-extract-month
+ ;; anchor on Thurs, to be consistent with weekyear
+ (calendar-gregorian-from-absolute
+ (calendar-iso-to-absolute
+ `(,week 4 ,nominal-year))))
+ month))
+ (quarter (if (and (memq 'week time-grouping)
+ (not (memq 'month time-grouping)))
+ (min 4 (1+ (/ (1- week) 13)))
+ (1+ (/ (1- nominal-month) 3)))))
+ (org-datetree-find-create-hierarchy
+ (append
+ (when (memq 'year time-grouping)
+ (list (list (number-to-string nominal-year)
+ (org-datetree--compare-fun-from-regex
+ "\\([12][0-9]\\{3\\}\\)"))))
+ (when (memq 'quarter time-grouping)
+ (list (list (format "%d-Q%d" nominal-year quarter)
+ (org-datetree--compare-fun-from-regex
+ "\\([12][0-9]\\{3\\}-Q[1-4]\\)"))))
+ (when (memq 'month time-grouping)
+ (list (list (format-time-string
+ "%Y-%m %B" (org-encode-time 0 0 0 1 nominal-month
+ nominal-year))
+ (org-datetree--compare-fun-from-regex
+ "\\([12][0-9]\\{3\\}-[01][0-9]\\) \\w+"))))
+ (when (memq 'week time-grouping)
+ (list (list (format-time-string "%G-W%V" time)
+ (org-datetree--compare-fun-from-regex
+ "\\([12][0-9]\\{3\\}-W[0-5][0-9]\\)"))))
+ (when (memq 'day time-grouping)
+ ;; Use regular date instead of ISO-week year/month
+ (list (list (format-time-string
+ "%Y-%m-%d %A" (org-encode-time 0 0 0 day month year))
+ (org-datetree--compare-fun-from-regex
+ "\\([12][0-9]\\{3\\}-[01][0-9]-[0123][0-9]\\) \\w+")))))
+ keep-restriction
+ ;; Support the old way of tree placement, using a property
+ (cond
+ ((seq-set-equal-p time-grouping '(year month day))
+ "DATE_TREE")
+ ((seq-set-equal-p time-grouping '(year month))
+ "DATE_TREE")
+ ((seq-set-equal-p time-grouping '(year week day))
+ "WEEK_TREE")))
+ (when (memq 'day time-grouping)
+ (when org-datetree-add-timestamp
+ (save-excursion
+ (end-of-line)
+ (insert "\n")
+ (org-indent-line)
+ (org-insert-timestamp
+ (org-encode-time 0 0 0 day month year)
+ nil
+ (eq org-datetree-add-timestamp 'inactive)))))))
- (format org-complex-heading-regexp-format
- (format regex-template year month day))
+(defun org-datetree--compare-fun-from-regex (sibling-regex)
+ "Construct comparison function based on regular expression.
+SIBLING-REGEX should be a regex that matches the headline and its
+siblings, with 1 match group. Headlines are compared by the
+lexicographic ordering of match group 1."
+ (lambda (sibling-title new-title)
+ (let ((target-match (and (string-match sibling-regex new-title)
+ (match-string 1 new-title)))
+ (sibling-match (and (string-match sibling-regex sibling-title)
+ (match-string 1 sibling-title))))
+ (cond
+ ((not (and target-match sibling-match)) nil)
+ ((string< sibling-match target-match) -1)
+ ((string> sibling-match target-match) 1)
+ (t 0)))))
-If MATCH-TITLE is nil, the regexp matched against heading line is
-REGEX-TEMPLATE:
+(defun org-datetree-find-create-hierarchy
+ (hier-pairs &optional keep-restriction legacy-prop)
+ "Insert a new entry into a datetree from the entry's full date hierarchy.
+HIER-PAIRS is a list whose first entry corresponds to the outermost element
+(e.g. year) and last entry corresponds to the innermost (e.g. day).
+Each entry of the list is a pair, the car is the headline for that level
+(e.g. \"2024\" or \"2024-12-28\"), and the cadr is a string
+comparison function for sorting each headline among its siblings.
+The comparison function should take 2 arguments, corresponding to
+the titles of 2 headlines, and return a negative number of the
+first headline precedes the second, a positive number of the
+second has precedence, 0 if the headlines are at the same time,
+or `nil' if a headline isn't a valid datetree subheading. For
+example, HIER-PAIRS could look like
- (format regex-template year month day)
+ ((\"2024\" compare-year-fun)
+ (\"2024-12 December\" compare-month-fun)
+ (\"2024-12-28 Saturday\" compare-day-fun))
-Match group 1 in REGEX-TEMPLATE is compared against the specified date
-component. If INSERT is non-nil and there is no match then it is
-inserted into the buffer."
- (when (or month day)
- (org-narrow-to-subtree))
- ;; ensure that the first match group in REGEX-TEMPLATE
- ;; is the first inside `org-complex-heading-regexp-format'
- (when (and match-title
- (not (string-match-p "\\\\(\\?1:" regex-template))
- (string-match "\\\\(" regex-template))
- (setq regex-template (replace-match "\\(?1:" nil t regex-template)))
- (let ((re (if match-title
- (format org-complex-heading-regexp-format
- (format regex-template year month day))
- (format regex-template year month day)))
- match)
- (goto-char (point-min))
- (while (and (setq match (re-search-forward re nil t))
- (goto-char (match-beginning 1))
- (< (string-to-number (match-string 1)) (or day month year))))
- (cond
- ((not match)
- (goto-char (point-max))
- (unless (bolp) (insert "\n"))
- (org-datetree-insert-line year month day insert))
- ((= (string-to-number (match-string 1)) (or day month year))
- (forward-line 0))
- (t
- (forward-line 0)
- (org-datetree-insert-line year month day insert)))))
+where compare-month-fun would be some function where
+(compare-month-fun \"2024-12-December\" \"2024-12-November\") is
+negative, and (compare-month-fun \"2024-12-December\" \"Potato\")
+is nil.
-(defun org-datetree-insert-line (year &optional month day text)
- (delete-region (save-excursion (skip-chars-backward " \t\n") (point)) (point))
- (when (org--blank-before-heading-p) (insert "\n"))
- (insert "\n" (make-string org-datetree-base-level ?*) " \n")
- (backward-char)
- (when month (org-do-demote))
- (when day (org-do-demote))
- (if text
- (insert text)
- (insert (format "%d" year))
- (when month
+If KEEP-RESTRICTION is non-nil, do not widen the buffer.
+When it is nil, the buffer will be widened to make sure an existing date
+tree can be found. If it is the symbol `subtree-at-point', then the tree
+will be built under the headline at point.
+
+If LEGACY-PROP is non-nil, the tree is located by searching for a
+headline with property LEGACY-PROP, supporting the old way of
+tree placement via a property."
+ (let (tree)
+ (save-restriction
+ ;; get the datetree base and narrow to it
+ (if (eq keep-restriction 'subtree-at-point)
+ (progn
+ (unless (org-at-heading-p) (error "Not at heading"))
+ (widen)
+ (org-narrow-to-subtree)
+ (setq tree (car (org-element-contents (org-element-parse-buffer 'headline)))))
+ (unless keep-restriction (widen))
+ ;; Support the old way of tree placement, using a property
+ (let ((prop (and legacy-prop (org-find-property legacy-prop))))
+ (if prop
+ (progn
+ (goto-char prop)
+ (org-narrow-to-subtree)
+ (setq tree (car (org-element-contents (org-element-parse-buffer 'headline)))))
+ (setq tree (org-element-parse-buffer)))))
+ (cl-loop
+ for pair in hier-pairs
+ do
+ (setq tree
+ (org-datetree--find-create-subheading
+ (cadr pair) (car pair) tree)))
+ tree)))
+
+(defun org-datetree--find-create-subheading
+ (compare-fun new-title tree)
+ "Find datetree subheading, or create it if it doesn't exist.
+After insertion, move point to beginning of the subheading, and
+narrow to its subtree. NEW-TITLE is the subheading to be found
+or created. TREE is the parent headline, or an element of type
+`org-data' if NEW-TITLE is to be at level 1. COMPARE-FUN is a
+function of 2 arguments for comparing headline titles; it should
+return a negative number if the first headline precedes the
+second, a positive number if the second number has precedence, 0
+if the headlines are at the same time, and `nil' if a headline
+isn't a valid datetree subheading at this level."
+ (let* ((level (if (eq (org-element-type tree) 'org-data)
+ 1
+ (1+ (org-element-property :level tree))))
+ (sibling (org-element-map tree 'headline
+ (lambda (d)
+ (when (= (org-element-property :level d) level)
+ (let ((compare-result
+ (funcall compare-fun
+ (org-element-property :raw-value d)
+ new-title)))
+ (and compare-result (>= compare-result 0) d))))
+ nil t)))
+ ;; go to headline, or first successor sibling, or end of buffer
+ (if sibling
+ (goto-char (org-element-property :begin sibling))
+ (goto-char (point-max))
+ (unless (bolp) (insert "\n")))
+ (if (and sibling
+ (= 0 (funcall compare-fun
+ (org-element-property :raw-value sibling)
+ new-title)))
+ ;; narrow and return the matched headline
+ (progn
+ (org-narrow-to-subtree)
+ sibling)
+ ;; insert new headline, narrow, and return it
+ (delete-region (save-excursion (skip-chars-backward " \t\n") (point)) (point))
+ (when (org--blank-before-heading-p) (insert "\n"))
(insert
- (if day
- (format-time-string "-%m-%d %A" (org-encode-time 0 0 0 day month year))
- (format-time-string "-%m %B" (org-encode-time 0 0 0 1 month year))))))
- (when (and day org-datetree-add-timestamp)
- (save-excursion
- (insert "\n")
- (org-indent-line)
- (org-insert-timestamp
- (org-encode-time 0 0 0 day month year)
- nil
- (eq org-datetree-add-timestamp 'inactive))))
- (forward-line 0))
+ (format "\n%s %s\n"
+ (make-string (if org-odd-levels-only (1- (* 2 level)) level) ?*)
+ new-title))
+ (forward-line -1)
+ (org-narrow-to-subtree)
+ (org-element-at-point))))
(defun org-datetree-file-entry-under (txt d)
"Insert a node TXT into the date tree under date D."
diff --git a/testing/lisp/test-org-datetree.el b/testing/lisp/test-org-datetree.el
index 620a916df..585bd692c 100644
--- a/testing/lisp/test-org-datetree.el
+++ b/testing/lisp/test-org-datetree.el
@@ -160,6 +160,54 @@ (ert-deftest test-org-datetree/find-month-create ()
(org-datetree-find-month-create '(3 29 2012)))
(org-trim (buffer-string)))))))
+(ert-deftest test-org-datetree/find-quarter-month-create ()
+ "Test `org-datetree-find-quarter-month-create' specifications."
+ (let ((org-blank-before-new-entry '((heading . t))))
+ ;; When date is missing, create it with the entry under month.
+ (should
+ (string-match
+ "\\`\\* 2012\n\n\\*\\* 2012-Q1\n\n\\*\\*\\* 2012-03 .*\\'"
+ (org-test-with-temp-text ""
+ (let ((org-datetree-add-timestamp nil))
+ (org-datetree-find-create-entry '(year quarter month) '(3 29 2012)))
+ (org-trim (buffer-string)))))))
+
+(ert-deftest test-org-datetree/find-quarter-month-day-create ()
+ "Test `org-datetree-find-quarter-month-day-create' specifications."
+ (let ((org-blank-before-new-entry '((heading . t))))
+ ;; When date is missing, create it with the entry under month.
+ (should
+ (string-match
+ "\\`\\* 2012\n\n\\*\\* 2012-Q1\n\n\\*\\*\\* 2012-03 .*\n\n\\*\\*\\*\\* 2012-03-29 .*\\'"
+ (org-test-with-temp-text ""
+ (let ((org-datetree-add-timestamp nil))
+ (org-datetree-find-create-entry '(year quarter month day) '(3 29 2012)))
+ (org-trim (buffer-string)))))))
+
+(ert-deftest test-org-datetree/find-quarter-week-create ()
+ "Test `org-datetree-find-quarter-week-create' specifications."
+ (let ((org-blank-before-new-entry '((heading . t))))
+ ;; When date is missing, create it with the entry under month.
+ (should
+ (string-match
+ "\\`\\* 2024\n\n\\*\\* 2024-Q4\n\n\\*\\*\\* 2024-W52\\'"
+ (org-test-with-temp-text ""
+ (let ((org-datetree-add-timestamp nil))
+ (org-datetree-find-create-entry '(year quarter week) '(12 27 2024)))
+ (org-trim (buffer-string)))))))
+
+(ert-deftest test-org-datetree/find-month-week-create ()
+ "Test `org-datetree-find-month-week-create' specifications."
+ (let ((org-blank-before-new-entry '((heading . t))))
+ ;; When date is missing, create it with the entry under month.
+ (should
+ (string-match
+ "\\`\\* 2024\n\n\\*\\* 2024-12 .*\n\n\\*\\*\\* 2024-W52\\'"
+ (org-test-with-temp-text ""
+ (let ((org-datetree-add-timestamp nil))
+ (org-datetree-find-create-entry '(year month week) '(12 27 2024)))
+ (org-trim (buffer-string)))))))
+
(ert-deftest test-org-datetree/find-iso-week-create ()
"Test `org-datetree-find-iso-date-create' specification."
(let ((org-blank-before-new-entry '((heading . t))))
--
2.47.1
^ permalink raw reply related [flat|nested] 7+ messages in thread