* Month-week and quarter-week datetrees (RFC and package announcement) @ 2023-12-30 19:41 Jack Kamm 2023-12-31 14:50 ` Ihor Radchenko 0 siblings, 1 reply; 12+ messages in thread From: Jack Kamm @ 2023-12-30 19:41 UTC (permalink / raw) To: emacs-orgmode I have started a package that defines org-capture datetrees following year-quarter-week and year-month-week formats: https://gitlab.com/jackkamm/org-grouped-weektree I'd appreciate feedback on 2 points: 1. Are any of these datetree formats worth upstreaming into org-mode proper? 2. Can we add a public interface for `org-datetree--find-create', and are there any suggestions on how to do it? Regarding #2, an ugly aspect of my current implementation is the abuse of the private function `org-datetree--find-create'. I also pass in the week or quarter for the DAY and MONTH arguments of this function, though I note that `org-datetree-find-iso-week-create' does something similar in its implementation. ^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: Month-week and quarter-week datetrees (RFC and package announcement) 2023-12-30 19:41 Month-week and quarter-week datetrees (RFC and package announcement) Jack Kamm @ 2023-12-31 14:50 ` Ihor Radchenko 2023-12-31 18:16 ` Jack Kamm 0 siblings, 1 reply; 12+ messages in thread From: Ihor Radchenko @ 2023-12-31 14:50 UTC (permalink / raw) To: Jack Kamm; +Cc: emacs-orgmode Jack Kamm <jackkamm@gmail.com> writes: > https://gitlab.com/jackkamm/org-grouped-weektree > > I'd appreciate feedback on 2 points: > > 1. Are any of these datetree formats worth upstreaming into org-mode > proper? That would make sense. > 2. Can we add a public interface for `org-datetree--find-create', and > are there any suggestions on how to do it? > > Regarding #2, an ugly aspect of my current implementation is the abuse > of the private function `org-datetree--find-create'. I also pass in > the week or quarter for the DAY and MONTH arguments of this function, > though I note that `org-datetree-find-iso-week-create' does something > similar in its implementation. The API of `org-datetree--find-create' is generally very limiting. It would be nice to come up with something less limiting. -- Ihor Radchenko // yantar92, Org mode contributor, Learn more about Org mode at <https://orgmode.org/>. Support Org development at <https://liberapay.com/org-mode>, or support my work at <https://liberapay.com/yantar92> ^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: Month-week and quarter-week datetrees (RFC and package announcement) 2023-12-31 14:50 ` Ihor Radchenko @ 2023-12-31 18:16 ` Jack Kamm 2024-12-16 18:49 ` Ihor Radchenko 0 siblings, 1 reply; 12+ messages in thread From: Jack Kamm @ 2023-12-31 18:16 UTC (permalink / raw) To: Ihor Radchenko; +Cc: emacs-orgmode Ihor Radchenko <yantar92@posteo.net> writes: >> https://gitlab.com/jackkamm/org-grouped-weektree >> >> I'd appreciate feedback on 2 points: >> >> 1. Are any of these datetree formats worth upstreaming into org-mode >> proper? > > That would make sense. > >> 2. Can we add a public interface for `org-datetree--find-create', and >> are there any suggestions on how to do it? >> >> Regarding #2, an ugly aspect of my current implementation is the abuse >> of the private function `org-datetree--find-create'. I also pass in >> the week or quarter for the DAY and MONTH arguments of this function, >> though I note that `org-datetree-find-iso-week-create' does something >> similar in its implementation. > > 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 :''-( ^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: Month-week and quarter-week datetrees (RFC and package announcement) 2023-12-31 18:16 ` Jack Kamm @ 2024-12-16 18:49 ` Ihor Radchenko 2024-12-28 6:09 ` Jack Kamm 2024-12-29 9:18 ` Jack Kamm 0 siblings, 2 replies; 12+ messages in thread From: Ihor Radchenko @ 2024-12-16 18:49 UTC (permalink / raw) To: Jack Kamm; +Cc: emacs-orgmode 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 ;) -- Ihor Radchenko // yantar92, Org mode maintainer, Learn more about Org mode at <https://orgmode.org/>. Support Org development at <https://liberapay.com/org-mode>, or support my work at <https://liberapay.com/yantar92> ^ permalink raw reply [flat|nested] 12+ messages in thread
* 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 1 sibling, 0 replies; 12+ messages in thread From: Jack Kamm @ 2024-12-28 6:09 UTC (permalink / raw) To: Ihor Radchenko; +Cc: emacs-orgmode 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 ;) Hi Ihor -- Sorry for the delayed response. I'm working on this now and should have something ready for review in the coming days. Best, Jack ^ permalink raw reply [flat|nested] 12+ messages in thread
* 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; 12+ 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] 12+ messages in thread
* Re: Month-week and quarter-week datetrees (RFC and package announcement) 2024-12-29 9:18 ` Jack Kamm @ 2024-12-29 10:33 ` Ihor Radchenko 2024-12-30 16:20 ` Jack Kamm 2024-12-31 1:56 ` Jack Kamm 0 siblings, 2 replies; 12+ messages in thread From: Ihor Radchenko @ 2024-12-29 10:33 UTC (permalink / raw) To: Jack Kamm; +Cc: emacs-orgmode Jack Kamm <jackkamm@gmail.com> writes: > I attach a pair of patches for this. Thanks! See my comments inline. > +(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." Please also document how `org-datetree-add-timestamp' affects this function. > + ;; 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"))) It would be a good idea to add a few tests for this scenario. To make sure that refactoring did not break things. > + ;; 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))))) Why do you need object granularity by default (second call to `org-element-parse-buffer')? Also, more importantly, do you have to run the full parsing here? Maybe utilize `org-element-cache-map' instead? Full parsing is going to be much slower. > + (cl-loop > + for pair in hier-pairs > + do > + (setq tree > + (org-datetree--find-create-subheading > + (cadr pair) (car pair) tree))) It is undocumented in the `org-datetree--find-create-subheading' docstring that it returns something. -- Ihor Radchenko // yantar92, Org mode maintainer, Learn more about Org mode at <https://orgmode.org/>. Support Org development at <https://liberapay.com/org-mode>, or support my work at <https://liberapay.com/yantar92> ^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: Month-week and quarter-week datetrees (RFC and package announcement) 2024-12-29 10:33 ` Ihor Radchenko @ 2024-12-30 16:20 ` Jack Kamm 2024-12-30 17:11 ` Ihor Radchenko 2024-12-31 1:56 ` Jack Kamm 1 sibling, 1 reply; 12+ messages in thread From: Jack Kamm @ 2024-12-30 16:20 UTC (permalink / raw) To: Ihor Radchenko; +Cc: emacs-orgmode Ihor Radchenko <yantar92@posteo.net> writes: >> + ;; 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))))) > > Why do you need object granularity by default (second call to > `org-element-parse-buffer')? > Also, more importantly, do you have to run the full parsing here? Maybe > utilize `org-element-cache-map' instead? Full parsing is going to be > much slower. We don't need object granularity, that was an oversight on my part -- should have specified headline granularity. Does `org-element-cache-map' traverse elements in the order they're in the buffer? That is something we need for this. On my working branch I have an earlier commit that implements many of the improvements here but using the old regexp search way instead of the org-element way. Would it be worth reverting to that point? Specifically, the new `org-datetree-find-create-entry' that allows for nested years/quarters/months/weeks/days is still pretty straightforward to implement in the regexp approach. The more general `org-datetree-find-create-hierarchy' (that allows elisp hackers to build new kinds of datetrees) might be trickier without org-element, but we could also defer that for future work. ^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: Month-week and quarter-week datetrees (RFC and package announcement) 2024-12-30 16:20 ` Jack Kamm @ 2024-12-30 17:11 ` Ihor Radchenko 0 siblings, 0 replies; 12+ messages in thread From: Ihor Radchenko @ 2024-12-30 17:11 UTC (permalink / raw) To: Jack Kamm; +Cc: emacs-orgmode Jack Kamm <jackkamm@gmail.com> writes: > Does `org-element-cache-map' traverse elements in the order they're in > the buffer? That is something we need for this. Yes, it does. You can even edit buffer along the way. `org-element-cache-map' combines regexp search and parser cache trying to be as fast as possible. > On my working branch I have an earlier commit that implements many of > the improvements here but using the old regexp search way instead of the > org-element way. Would it be worth reverting to that point? > Specifically, the new `org-datetree-find-create-entry' that allows for > nested years/quarters/months/weeks/days is still pretty straightforward > to implement in the regexp approach. The more general > `org-datetree-find-create-hierarchy' (that allows elisp hackers to build > new kinds of datetrees) might be trickier without org-element, but we > could also defer that for future work. I believe that `org-element-cache-map' should be good enough to do everything. -- Ihor Radchenko // yantar92, Org mode maintainer, Learn more about Org mode at <https://orgmode.org/>. Support Org development at <https://liberapay.com/org-mode>, or support my work at <https://liberapay.com/yantar92> ^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: Month-week and quarter-week datetrees (RFC and package announcement) 2024-12-29 10:33 ` Ihor Radchenko 2024-12-30 16:20 ` Jack Kamm @ 2024-12-31 1:56 ` Jack Kamm 2025-01-01 9:14 ` Ihor Radchenko 1 sibling, 1 reply; 12+ messages in thread From: Jack Kamm @ 2024-12-31 1:56 UTC (permalink / raw) To: Ihor Radchenko; +Cc: emacs-orgmode [-- Attachment #1: Type: text/plain, Size: 2075 bytes --] Thanks for the feedback. I attach a squashed updated patch for part 2. You can also see the unsquashed changes at https://github.com/jackkamm/org-mode/tree/2024-grouped-weektree-rebase >> +(defun org-datetree-find-create-entry > Please also document how `org-datetree-add-timestamp' affects this function. Done. On reviewing this I also found a bug (datestamp added again if entry already existed) -- I fixed it and added a unit test. >> + ;; 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"))) > > It would be a good idea to add a few tests for this scenario. > To make sure that refactoring did not break things. There was already a couple tests for DATE_TREE and WEEK_TREE, but I've added a few more now, mainly around finding existing headings (the previous tests only created new headings under the DATE_TREE or WEEK_TREE). > Why do you need object granularity by default (second call to > `org-element-parse-buffer')? > Also, more importantly, do you have to run the full parsing here? Maybe > utilize `org-element-cache-map' instead? Full parsing is going to be > much slower. I've switched to `org-element-cache-map' now -- thanks for the info about it. > It is undocumented in the `org-datetree--find-create-subheading' > docstring that it returns something. I changed the return behavior and documented it. It now returns non-nil if the subheading already exists -- this is needed to prevent adding a datestamp twice when `org-datetree-add-timestamp'. Finally, I made one more substantial change -- I now allow :tree-type to be a function in the org-capture template. This allows using new types of datetrees from `org-datetree-find-create-hierarchy' with org-capture. Relatedly, I made `org-datetree-comparefun-from-regex' public to help with building new types of datetrees. [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #2: 0002-org-datetree-Add-additional-tree-types-e.g.-quarter-.patch --] [-- Type: text/x-patch, Size: 39212 bytes --] From b8447f23c5618239bb3926a59d111fd21d985afe 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: Declare `org-datetree-find-create-hierarchy'. (org-capture-templates): Update docstring for new datetree tree-type options. (org-capture-set-target-location): Allow tree-type to be a set or function, and call `org-datetree-find-create-entry' or `org-datetree-find-create-hierarchy' in those cases. * 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-comparefun-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-capture.el (test-org-capture/entry): Add tests for datetree capture with list or function :tree-type. * testing/lisp/test-org-datetree.el (test-org-datetree/find-date-create): Add test to not add the timestamp twice. Add additional test for legacy DATE_TREE method. (test-org-datetree/find-month-create): Add tests for legacy DATE_TREE method. (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. (test-org-datetree/find-iso-week-create): Additional test for legacy WEEK_TREE method. --- doc/org-manual.org | 18 +- etc/ORG-NEWS | 39 +++ lisp/org-capture.el | 27 +- lisp/org-datetree.el | 399 ++++++++++++++++++------------ testing/lisp/test-org-capture.el | 45 ++++ testing/lisp/test-org-datetree.el | 103 +++++++- 6 files changed, 466 insertions(+), 165 deletions(-) diff --git a/doc/org-manual.org b/doc/org-manual.org index 1b3c33f96..f59f46f91 100644 --- a/doc/org-manual.org +++ b/doc/org-manual.org @@ -8177,10 +8177,20 @@ 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. + + #+findex: org-datetree-find-create-hierarchy + ~:tree-type~ can also be a function, in which it should take the + date as an argument and generate a list of pairs for + ~org-datetree-find-create-hierarchy~. - ~:unnarrowed~ :: diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS index 85411ecc1..8779bdad1 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. + +Additionally, ~:tree-type~ can be a function, in which case it should +take the date as an argument, and generate a list of pairs for +~org-datetree-find-create-hierarchy~. This allows for creating new +types of datetrees (e.g. for lunar calendars, academic calendars, +retail 4-4-5 calendars, etc). + ** New and changed options # Changes deadling with changing default values of customizations, @@ -281,6 +305,14 @@ 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~ and +~org-datetree-find-create-hierarchy~ generalize +~org-datetree-find-date-create~, ~org-datetree-find-month-create~, and +~org-datetree-find-iso-week-create~ to new datetree types. + ** Removed or renamed functions and variables *** ~org-cycle-display-inline-images~ is renamed to ~org-cycle-display-link-previews~ @@ -299,6 +331,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..818ed179b 100644 --- a/lisp/org-capture.el +++ b/lisp/org-capture.el @@ -59,6 +59,7 @@ (declare-function org-at-table-p "org-table" (&optional table-type)) (declare-function org-clock-update-mode-line "org-clock" (&optional refresh)) (declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction)) (declare-function org-datetree-find-month-create "org-datetree" (d &optional keep-restriction)) +(declare-function org-datetree-find-create-hierarchy "org-datetree" (hier-pairs &optional keep-restriction legacy-prop)) (declare-function org-decrypt-entry "org-crypt" ()) (declare-function org-element-at-point "org-element" (&optional pom cached-only)) (declare-function org-element-lineage "org-element-ast" (datum &optional types with-self)) @@ -293,7 +294,13 @@ (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. Can also be a function, in which + case it should take the date as an argument + and generate a list of pairs to pass to + `org-datetree-find-create-hierarchy'. :unnarrowed Do not narrow the target buffer, simply show the full buffer. Default is to narrow it so that you @@ -1090,10 +1097,22 @@ (defun org-capture-set-target-location (&optional target) ;; yesterday, if we are extending dates for a couple of ;; hours) (funcall - (pcase (org-capture-get :tree-type) - (`week #'org-datetree-find-iso-week-create) + (pcase (org-capture-get :tree-type) + (`week #'org-datetree-find-iso-week-create) (`month #'org-datetree-find-month-create) - (_ #'org-datetree-find-date-create)) + (`day #'org-datetree-find-date-create) + ((pred not) #'org-datetree-find-date-create) + ;; NOTE function case needs to be before list case to + ;; handle lambda forms correctly + ((and (pred functionp) fun) + (lambda (d keep-restriction) + (org-datetree-find-create-hierarchy + (funcall fun d) keep-restriction))) + ((and (pred listp) grouping) + (lambda (d keep-restriction) + (funcall #'org-datetree-find-create-entry grouping + d keep-restriction))) + (_ (error "Unrecognized :tree-type"))) (calendar-gregorian-from-absolute (cond (org-overriding-default-time diff --git a/lisp/org-datetree.el b/lisp/org-datetree.el index d0cc1fabb..4da3c8dc8 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,264 @@ (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. +Moves point to the beginning of the entry. -If MATCH-TITLE is non-nil, REGEX-TEMPLATE is matched against -heading title and the exact regexp matched against heading line is: +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. - (format org-complex-heading-regexp-format - (format regex-template 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. -If MATCH-TITLE is nil, the regexp matched against heading line is -REGEX-TEMPLATE: +If `org-datetree-add-timestamp' is non-nil and TIME-GROUPING +includes `day' and a new entry is created, adds a time stamp +after the new headline." + (when-let ((setdiff (seq-difference time-grouping + '(year quarter month week day)))) + (error (format "Unrecognized datetree grouping elements %s" setdiff))) + (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)))) + (found-p + (org-datetree-find-create-hierarchy + (append + (when (memq 'year time-grouping) + (list (list (number-to-string nominal-year) + (org-datetree-comparefun-from-regex + "\\([12][0-9]\\{3\\}\\)")))) + (when (memq 'quarter time-grouping) + (list (list (format "%d-Q%d" nominal-year quarter) + (org-datetree-comparefun-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-comparefun-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-comparefun-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-comparefun-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 (and (not found-p) 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 regex-template year month day) +(defun org-datetree-comparefun-from-regex (sibling-regex) + "Construct comparison function based on regular expression. +The generated comparison function can be used with +`org-datetree-find-create-hierarchy'. 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. The generated function returns -1 if the first +argument is earlier, 1 if later, 0 if equal, or nil if either +argument doesn't match." + (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))))) -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))))) +(defun org-datetree-find-create-hierarchy + (hier-pairs &optional keep-restriction legacy-prop) + "Find or create entry in datetree using the full date hierarchy. +Moves point to the beginning of the entry. Returns non-nil if an +existing entry was found, or nil if a new entry was created. + +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 Saturday\"), 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 if the first headline is earlier, a positive number if the +second headline is earlier, 0 or t 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 -(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 + ((\"2024\" compare-year-fun) + (\"2024-12 December\" compare-month-fun) + (\"2024-12-28 Saturday\" compare-day-fun)) + +where compare-month-fun would be some function where +(compare-month-fun \"2024-11 November\" \"2024-12 December\") is +negative, and (compare-month-fun \"2024-12-December\" \"Potato\") +is nil. One way to construct such a comparison function is with +`org-datetree-comparefun-from-regex'. + +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 ((level 1) + found-p) + (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 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 (and legacy-prop (org-find-property legacy-prop)))) + (when prop + (progn + (goto-char prop) + (org-narrow-to-subtree) + (setq level (org-get-valid-level (org-current-level) 1)))))) + (cl-loop + for pair in hier-pairs + do + (setq found-p (org-datetree--find-create-subheading + (cadr pair) (car pair) level)) + (setq level (1+ level)))) + found-p)) + +(defun org-datetree--find-create-subheading + (compare-fun new-title level) + "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. Returns non-nil if the heading was found, +or nil if a new heading was created. + +NEW-TITLE is the title of the subheading to be found or created. +LEVEL is the level of the headline to be found or created. +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 or t if the headlines are at the same time, and nil +if a headline isn't a valid datetree subheading at this level." + (let* ((nstars (if org-odd-levels-only (1- (* 2 level)) level)) + (heading-re (format "^\\*\\{%d\\}" nstars)) + (sibling (car (org-element-cache-map + (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 + (or (eq compare-result t) (>= compare-result 0)) + d)))) + :granularity 'headline + :restrict-elements '(headline) + :next-re heading-re + :fail-re heading-re + :narrow t + :limit-count 1)))) + ;; 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 + (memq (funcall compare-fun + (org-element-property :raw-value sibling) + new-title) + '(0 t))) + ;; narrow and return the matched headline + (progn + (org-narrow-to-subtree) + t) + ;; 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 nstars ?*) + new-title)) + (forward-line -1) + (org-narrow-to-subtree) + nil))) (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-capture.el b/testing/lisp/test-org-capture.el index 4aed0e99e..ff7e242d2 100644 --- a/testing/lisp/test-org-capture.el +++ b/testing/lisp/test-org-capture.el @@ -324,6 +324,51 @@ (ert-deftest test-org-capture/entry () (insert "Capture text") (org-capture-finalize))) (buffer-string)))) + ;; test datetree capture with list tree-type + (should + (equal + "* A\n** B\n*** 2024\n**** 2024-Q2\n***** 2024-06 June\n****** 2024-06-16 Sunday\n******* H1 Capture text\n** C\n" + (org-test-with-temp-text-in-file "* A\n** B\n** C\n" + (let* ((file (buffer-file-name)) + (org-capture-templates + `(("t" + "Todo" + entry + (file+olp+datetree ,file (lambda () + (should (equal ,file (buffer-file-name))) + '("A" "B"))) + "* H1 %?" + :tree-type + (year quarter month day))))) + (org-test-at-time "2024-06-16" + (org-capture nil "t") + (insert "Capture text") + (org-capture-finalize))) + (buffer-string)))) + ;; test datetree capture with function tree-type + (should + (equal + "* A\n** B\n*** 2024\n**** 06\n***** 16\n****** H1 Capture text\n** C\n" + (org-test-with-temp-text-in-file "* A\n** B\n** C\n" + (let* ((file (buffer-file-name)) + (org-capture-templates + `(("t" + "Todo" + entry + (file+olp+datetree ,file (lambda () + (should (equal ,file (buffer-file-name))) + '("A" "B"))) + "* H1 %?" + :tree-type + (lambda (d) + `((,(format "%d" (calendar-extract-year d)) compare-strings) + (,(format "%02d" (calendar-extract-month d)) compare-strings) + (,(format "%02d" (calendar-extract-day d)) compare-strings))))))) + (org-test-at-time "2024-06-16" + (org-capture nil "t") + (insert "Capture text") + (org-capture-finalize))) + (buffer-string)))) (should (equal "* A\n** B\n*** 2024\n**** 2024-06 June\n***** 2024-06-16 Sunday\n****** H1 Capture text\n** C\n" diff --git a/testing/lisp/test-org-datetree.el b/testing/lisp/test-org-datetree.el index 620a916df..d6ba32887 100644 --- a/testing/lisp/test-org-datetree.el +++ b/testing/lisp/test-org-datetree.el @@ -91,6 +91,15 @@ (ert-deftest test-org-datetree/find-date-create () (let ((org-datetree-add-timestamp 'inactive)) (org-datetree-find-date-create '(3 29 2012))) (org-trim (buffer-string))))) + ;; don't add the timestamp twice + (should + (string-match + "\\`\\* 2012\n\n\\*\\* 2012-03 .*\n\n\\*\\*\\* \\(2012-03-29\\) .*\n[ \t]*<\\1.*?>\\'" + (org-test-with-temp-text "* 2012\n" + (let ((org-datetree-add-timestamp t)) + (org-datetree-find-date-create '(3 29 2012)) + (org-datetree-find-date-create '(3 29 2012))) + (org-trim (buffer-string))))) ;; Insert at top level, unless some node has DATE_TREE property. In ;; this case, date tree becomes one of its sub-trees. (should @@ -108,6 +117,15 @@ (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))))) + ;; Do not create new year/month node in DATE_TREE when it already exists + (should + (string-match + "\\`\\* H1\n\n\\*\\* H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n\\*\\*\\* 2012\n\n\\*\\*\\*\\* 2012-03 month\n\n\\*\\*\\*\\*\\* 2012-03-29 .*\n\n\\* H2\\'" + (org-test-with-temp-text + "* H1\n\n** H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n*** 2012\n\n**** 2012-03 month\n\n* H2" + (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 @@ -155,9 +173,83 @@ (ert-deftest test-org-datetree/find-month-create () (should (string-match "\\`\\* 2012\n\n\\*\\* 2012-03 .*\\'" + (org-test-with-temp-text "" + (let ((org-datetree-add-timestamp nil)) + (org-datetree-find-month-create '(3 29 2012))) + (org-trim (buffer-string))))) + ;; Insert at top level, unless some node has DATE_TREE property. In + ;; this case, date tree becomes one of its sub-trees. + (should + (string-match + "\\* 2012" + (org-test-with-temp-text "* Top" + (let ((org-datetree-add-timestamp nil)) + (org-datetree-find-month-create '(3 29 2012))) + (org-trim (buffer-string))))) + (should + (string-match + "\\*\\* H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n\\*\\*\\* 2012" + (org-test-with-temp-text + "* H1\n\n** H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n* H2" + (let ((org-datetree-add-timestamp nil)) + (org-datetree-find-month-create '(3 29 2012))) + (org-trim (buffer-string))))) + ;; Do not create new year/month node in DATE_TREE when it already exists + (should + (string-match + "\\`\\* H1\n\n\\*\\* H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n\\*\\*\\* 2012\n\n\\*\\*\\*\\* 2012-03 month\n\n\\* H2\\'" + (org-test-with-temp-text + "* H1\n\n** H1.1\n:PROPERTIES:\n:DATE_TREE: t\n:END:\n\n*** 2012\n\n**** 2012-03 month\n\n* H2" + (let ((org-datetree-add-timestamp nil)) + (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-month-create '(3 29 2012))) + (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 () @@ -260,6 +352,15 @@ (ert-deftest test-org-datetree/find-iso-week-create () (let ((org-datetree-add-timestamp nil)) (org-datetree-find-iso-week-create '(12 31 2014))) (org-trim (buffer-string))))) + ;; Do not create new year/week node when it exists in WEEK_TREE + (should + (string-match + "\\`\\* H1\n\\*\\* H1.1\n:PROPERTIES:\n:WEEK_TREE: t\n:END:\n\n\\*\\*\\* 2015\n\n\\*\\*\\*\\* 2015-W01\n\n\\*\\*\\*\\*\\* 2014-12-31 .*\n\n\\* H2\\'" + (org-test-with-temp-text + "* H1\n** H1.1\n:PROPERTIES:\n:WEEK_TREE: t\n:END:\n\n*** 2015\n\n**** 2015-W01\n\n* H2" + (let ((org-datetree-add-timestamp nil)) + (org-datetree-find-iso-week-create '(12 31 2014))) + (org-trim (buffer-string))))) ;; Always leave point at beginning of day entry. (should (string-match -- 2.47.1 ^ permalink raw reply related [flat|nested] 12+ messages in thread
* Re: Month-week and quarter-week datetrees (RFC and package announcement) 2024-12-31 1:56 ` Jack Kamm @ 2025-01-01 9:14 ` Ihor Radchenko 2025-01-01 18:30 ` Jack Kamm 0 siblings, 1 reply; 12+ messages in thread From: Ihor Radchenko @ 2025-01-01 9:14 UTC (permalink / raw) To: Jack Kamm; +Cc: emacs-orgmode Jack Kamm <jackkamm@gmail.com> writes: > Thanks for the feedback. I attach a squashed updated patch for part 2. > You can also see the unsquashed changes at https://github.com/jackkamm/org-mode/tree/2024-grouped-weektree-rebase > ... I have no further comments. Feel free to push. -- Ihor Radchenko // yantar92, Org mode maintainer, Learn more about Org mode at <https://orgmode.org/>. Support Org development at <https://liberapay.com/org-mode>, or support my work at <https://liberapay.com/yantar92> ^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: Month-week and quarter-week datetrees (RFC and package announcement) 2025-01-01 9:14 ` Ihor Radchenko @ 2025-01-01 18:30 ` Jack Kamm 0 siblings, 0 replies; 12+ messages in thread From: Jack Kamm @ 2025-01-01 18:30 UTC (permalink / raw) To: Ihor Radchenko; +Cc: emacs-orgmode Ihor Radchenko <yantar92@posteo.net> writes: > I have no further comments. > Feel free to push. Pushed now. Thank you and happy new year! ^ permalink raw reply [flat|nested] 12+ messages in thread
end of thread, other threads:[~2025-01-01 18:31 UTC | newest] Thread overview: 12+ messages (download: mbox.gz follow: Atom feed -- links below jump to the message on this page -- 2023-12-30 19:41 Month-week and quarter-week datetrees (RFC and package announcement) Jack Kamm 2023-12-31 14:50 ` Ihor Radchenko 2023-12-31 18:16 ` Jack Kamm 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 2024-12-30 16:20 ` Jack Kamm 2024-12-30 17:11 ` Ihor Radchenko 2024-12-31 1:56 ` Jack Kamm 2025-01-01 9:14 ` Ihor Radchenko 2025-01-01 18:30 ` Jack Kamm
Code repositories for project(s) associated with this external index https://git.savannah.gnu.org/cgit/emacs.git https://git.savannah.gnu.org/cgit/emacs/org-mode.git This is an external index of several public inboxes, see mirroring instructions on how to clone and mirror all data and code used by this external index.