From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp2.migadu.com ([2001:41d0:403:58f0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms13.migadu.com with LMTPS id iFhIOzUUcWfqmwAAe85BDQ:P1 (envelope-from ) for ; Sun, 29 Dec 2024 09:19:50 +0000 Received: from aspmx1.migadu.com ([2001:41d0:403:58f0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp2.migadu.com with LMTPS id iFhIOzUUcWfqmwAAe85BDQ (envelope-from ) for ; Sun, 29 Dec 2024 10:19:50 +0100 X-Envelope-To: larch@yhetil.org Authentication-Results: aspmx1.migadu.com; dkim=pass header.d=gmail.com header.s=20230601 header.b="J/T4FMbI"; spf=pass (aspmx1.migadu.com: domain of "emacs-orgmode-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="emacs-orgmode-bounces+larch=yhetil.org@gnu.org"; dmarc=pass (policy=none) header.from=gmail.com ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1735463989; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=5KF17QCSuoL8mIV19WKDLlnWnfPHcrm2cubSYlSQErw=; b=CPV4K8iSMsV//sdSE571Oa/26ti5G8c5lbce23svwSSopCp+dJWoRzXjXLb4vOdWdI+CNI 4xijo3FBOa/1x27QJQ33DgfESCBVk8oGQgFcZDHCme7Kp4JGL+Ofn5qS2KGJBEO+M6wPYV jwnhnHTk3QFuL3Uu1Kd9CnGIBGW+V/nmPqghstTiA7SpTO/Y/8GKtxX6cxIHbd0HGhU2cM 2qfXVeVgUBlplV1i3/28hHQyPGGR8bJL364qIU5tIru3fjrpW+t0607cdcTbFTDWesHbkk vKaYycGaQcXnkbph3uMcFaNVbjZTWvRgTrETgM3V/4qiCR+cSxy4oliEiwshaQ== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=pass header.d=gmail.com header.s=20230601 header.b="J/T4FMbI"; spf=pass (aspmx1.migadu.com: domain of "emacs-orgmode-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="emacs-orgmode-bounces+larch=yhetil.org@gnu.org"; dmarc=pass (policy=none) header.from=gmail.com ARC-Seal: i=1; s=key1; d=yhetil.org; t=1735463989; a=rsa-sha256; cv=none; b=VfuzoqTlzaripCjnkcYgn0Nu4R2Bkz79CpD4/bp4CybP7CYSDdLUZ+iMJdXyYkhZo0CkAx sUNoypSXEXNBg0qiQaJdF3/fSgrvpvuOdxvAg6UsAXNaeEmxlp5qmIlWvpjKYghL0H4OUb 9Rw+V0K0ADfdDFDL1zFBvH6L1d9/xzYSDDRJp43LVqGRhS33e/rIog+PCNw0TO0aKTFlZ1 t0dRJnT9ncP2p1t7bZow4DBosBxKa4Mag3OBfssTVy1R7Z8TaLcrR5JwEzH24VMdp49TQZ o26r1rNyVugZPmk8nBpCDwnJnybSa+6tmCx29bghPKugYITWvEcszAXEvkTYVg== Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 9B0DD7F315 for ; Sun, 29 Dec 2024 10:19:49 +0100 (CET) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tRpRr-0001iF-B7; Sun, 29 Dec 2024 04:18:59 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tRpRp-0001i2-Ga for emacs-orgmode@gnu.org; Sun, 29 Dec 2024 04:18:57 -0500 Received: from mail-pl1-x631.google.com ([2607:f8b0:4864:20::631]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tRpRl-0008LH-Na for emacs-orgmode@gnu.org; Sun, 29 Dec 2024 04:18:57 -0500 Received: by mail-pl1-x631.google.com with SMTP id d9443c01a7336-21649a7bcdcso104063155ad.1 for ; Sun, 29 Dec 2024 01:18:50 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1735463928; x=1736068728; darn=gnu.org; h=mime-version:message-id:date:references:in-reply-to:subject:cc:to :from:from:to:cc:subject:date:message-id:reply-to; bh=5KF17QCSuoL8mIV19WKDLlnWnfPHcrm2cubSYlSQErw=; b=J/T4FMbIZmuKOonXNzJVehSzfrieOAoX1zL9YEHetHl9aK84liNvYb/LAm04U65mOX 0aecEbSS3X7Mdjdf9OmQExZ1k3OsRZSGo9Zim43j8Pv5HFXwEB+ZU7IBgyJsU1bhfd95 7b1nHCeVsReZ0TVJ1Nls6O1ApdbLOfBbstTaod56U5pElWP093GAxo46cFqAJkxbqGNL Dz9RaB3Cke90O6fFMWFBTqndjijgi9Ji6ktPEL0LQoMEd61TIS0PDh8j7alBqSftkFLf J1WAX2G7mln/UeyixBeiJW+ThImIkNUrqsaBGJpB1pN/Nz2BvFE87NJJsCx3U0ovWrFT hCbw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1735463928; x=1736068728; h=mime-version:message-id:date:references:in-reply-to:subject:cc:to :from:x-gm-message-state:from:to:cc:subject:date:message-id:reply-to; bh=5KF17QCSuoL8mIV19WKDLlnWnfPHcrm2cubSYlSQErw=; b=FevU8b1k7zyTFc+I34V5u+rRtikvFxMu9MFu1zsx7ggjKxqkxmKqEc/jeWUDgZ3UJ+ mDysgyqanKYod3vFkjehDkxSQppEZrQBx6TwfAxASsfOWs/pAa/bztaCR3ZPTL2hH18H 4zuXkUIvBvwRNiqBYT25sZ2jpizcTVyUA+s3vXPuWbT0qAp2M/Bhc7vTTGkij1+JHzHy wcq55vmyIciZijtbW2aQzzynE7xb183clepN+wBfZDQXM95mI2lBj9zjE7ZBKXTET069 Za39j4rhVZ+JiLpDZjIsK9UeJGwh8N/OawD75zDxfG/xPFOee4AZRUeIa9mlZaIhmdo/ WsjA== X-Gm-Message-State: AOJu0YxKVUz5ujQznEppLqa0pFXaF3/VyjJ0WVI/cmbqxoRdaioQ6/z6 BBzpi8PTGlVeAEC2vw621n6XOPyUGc1dD9aiAuU3Dzyb3fce6ZqP1Up+4w== X-Gm-Gg: ASbGncsqEwAJl2xvLxRNe67DGEewe06QazT34wg38QCKo312rf9vPliEl3NY7Wrw9pj NV0DdNTLwuZA2dHRAey77zCWK7jC2EL56n+Vm4/w5RVwRpcmJ86+xvFpF+vTBCNu/M5MbnFNq5j l3AupZPUH117rZEQYyNQDc+LxmgZRgCOjVsULmLF/st6T2CgQBY/ChgGtDq1XKg4lEuT7ru/GwA 9RyyHZ+wjf2g326lXQNHkepXli1SBRMFx44COs4MkUw+3+21rktI97HCgCUC1vtokU4eEHlLK9V KE9+0gKMnTwMLGnon4U= X-Google-Smtp-Source: AGHT+IFSsddbYYF5EKvIbuX5anoUi9BOXjJSZ/Lwyy23QaqPyWcVxblWUtrd+Zr+VHHGyqEaPP8kbQ== X-Received: by 2002:a17:903:8c6:b0:216:1ad4:d8fd with SMTP id d9443c01a7336-219e6e89bd3mr476215295ad.8.1735463927684; Sun, 29 Dec 2024 01:18:47 -0800 (PST) Received: from localhost (157-131-77-158.fiber.dynamic.sonic.net. [157.131.77.158]) by smtp.gmail.com with ESMTPSA id d9443c01a7336-219dc962cb8sm160569785ad.10.2024.12.29.01.18.46 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sun, 29 Dec 2024 01:18:46 -0800 (PST) From: Jack Kamm To: Ihor Radchenko Cc: emacs-orgmode@gnu.org Subject: Re: Month-week and quarter-week datetrees (RFC and package announcement) In-Reply-To: <87msgvcvku.fsf@localhost> References: <878r5b1nr2.fsf@gmail.com> <87o7e677ex.fsf@localhost> <87y1daz186.fsf@gmail.com> <87msgvcvku.fsf@localhost> Date: Sun, 29 Dec 2024 01:18:45 -0800 Message-ID: <87ttametje.fsf@gmail.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Received-SPF: pass client-ip=2607:f8b0:4864:20::631; envelope-from=jackkamm@gmail.com; helo=mail-pl1-x631.google.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: emacs-orgmode@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-orgmode-bounces+larch=yhetil.org@gnu.org Sender: emacs-orgmode-bounces+larch=yhetil.org@gnu.org X-Migadu-Flow: FLOW_IN X-Migadu-Country: US X-Migadu-Scanner: mx11.migadu.com X-Migadu-Spam-Score: -9.26 X-Spam-Score: -9.26 X-Migadu-Queue-Id: 9B0DD7F315 X-TUID: YAAc4vanMQb2 --=-=-= Content-Type: text/plain Ihor Radchenko writes: > Jack Kamm 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). --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-org-datetree-Add-unit-tests-for-incorrect-sorting.patch >From b890687ec6732eaf90d4aa03c6ab450504a5988a Mon Sep 17 00:00:00 2001 From: Jack Kamm 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 --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0002-org-datetree-Add-additional-tree-types-e.g.-quarter-.patch >From b8cc188103baec26c7af337417f8ef84c2af81da Mon Sep 17 00:00:00 2001 From: Jack Kamm 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 --=-=-=--