Re: [POLL] Dealing with +1m/y repeaters when jumping to impossible date (should 05-31 +1m be 07-01 or 06-30?) (was: Leap-year bug with todo-cycle)

[Ihor Radchenko <yantar92@posteo.net>]

[-- Attachment #1: Type: text/plain, Size: 1629 bytes --]

Ihor Radchenko <yantar92@posteo.net> writes:

>> I have a TODO-entry which looks like this:
>>
>> SCHEDULED: <2024-02-29 Thu ++1y>
>>
>> When I cycle the TODO-entry with c-c c-t it becomes
>>
>> SCHEDULED: <2025-03-01 Sat ++1y>
>
> This is expected. When we try to add 1 year to 2024-02-29, it is
> 2025-02-29. However, because 02-29 does not exist in 2025, we glibc
> takes the closest existing date and adds the difference in days:
> 2025-02-28 + 1d = 2025-03-01.
>
> We apply the same logic to +1m repeaters:
>
> SCHEDULED: <2024-05-31 Fri ++1m>
> will become
> SCHEDULED: <2024-07-01 Mon ++1m>
> since 2024-06-31 does not exist.
>
>> In my opinion it should become "2025-02-28 Fri" instead.

Given the positive responses on changing the date rounding, I went ahead
and tried to implement it (see the attached; note that some tests still
need to be fixed to address the below divergence in edge cases).

However, there are still some issues remaining.
When updating timestamps repeating monthly across months with 30, 31,
and 28 days we get 

<2025-01-31 Fri +1m>
<2025-02-28 Fri +1m>
<2025-03-28 Fri +1m>
...
<2026-01-28 Wed +1m>

As you can see, because we pass through February that only has 28 days,
the timestamp tends to drift towards 28th within one year.

With the existing approach the drift would not be much better though:

<2025-01-31 Fri +1m>
<2025-03-03 Mon +1m>
<2025-03-03 Mon +1m>
...
<2026-01-03 Sat +1m>

I am wondering if we should do something with this kind of edge case.
(Not that the proposed patch is going to make things worse, but maybe
you have some ideas on what can be done, while we are at it)


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Make-m-y-repeater-intervals-round-down-from-non-exis.patch --]
[-- Type: text/x-patch, Size: 10204 bytes --]

From 99e4d3c0afd438499ab55314d30a01da54b15d53 Mon Sep 17 00:00:00 2001
Message-ID: <99e4d3c0afd438499ab55314d30a01da54b15d53.1715594311.git.yantar92@posteo.net>
From: Ihor Radchenko <yantar92@posteo.net>
Date: Mon, 13 May 2024 11:36:09 +0300
Subject: [PATCH] Make m/y repeater intervals round down from non-existing
 calendar dates

* lisp/org.el (org-repeat-round-time): New customization controlling
the new behavior.  It allows falling back to the historic rounding.
(org-time-inc): New helper function to increment date by Xm/d/w/m/y.
The new function, when `org-repeat-round-time' is non-nil, uses the
closest earlier existing calendar date when repeater units are month
or year.  Otherwise, it relies upon Emacs' rounding of non-existing
calendar dates being transferred to the next month's existing dates.
(org-timestamp-change): Use the new helper function.
(org-closest-date): Use the new helper function when computing
the expected closest repeater date.
* etc/ORG-NEWS (Repeater intervals in the units of month or year are
now computed as in many other calendar apps): Document the change.

Link: https://orgmode.org/list/87frvzodze.fsf@localhost
---
 etc/ORG-NEWS |  19 ++++++++
 lisp/org.el  | 127 ++++++++++++++++++++++++++++-----------------------
 2 files changed, 88 insertions(+), 58 deletions(-)

diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index 87b72ad12..8f4e51734 100644
--- a/etc/ORG-NEWS
+++ b/etc/ORG-NEWS
@@ -13,6 +13,25 @@ Please send Org bug reports to mailto:emacs-orgmode@gnu.org.
 
 * Version 9.7 (not released yet)
 ** Important announcements and breaking changes
+*** Repeater intervals in the units of month or year are now computed as in many other calendar apps
+
+Previously, timestamps like [2024-05-31 Fri +1m], when the next month
+does not have 31st day, were repeated to the first days of the
+following month: [2024-07-01 Mon +1m].  Same for years, when the same
+month next year does not have specified date.
+
+Now, the behavior is consistent with many common calendar apps - the
+closest /existing/ earlier date is selected: [2024-05-31 Fri +1m]
+repeats to [2024-06-30 Sun +1m].
+
+The previous behavior can be restored by customizing new option -
+~org-repeat-round-time~.
+
+Do note, however, that timestamps initially pointing to the last day
+of the month will not remain on the last day of the following months:
+[2024-05-31 Fri +1m] -> [2024-06-30 Sun +1m] -> [2024-07-30 Tue +1m]
+(not the last day anymore).
+
 *** ~org-create-file-search-functions~ can use ~org-list-store-props~ to suggest link description
 
 In Org <9.0, ~org-create-file-search-functions~ could set ~description~
diff --git a/lisp/org.el b/lisp/org.el
index 598b4ca23..81ac307cf 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -14951,7 +14951,7 @@ (defun org-diary-to-ical-string (frombuf)
     rtn))
 
 (defun org-closest-date (start current prefer)
-  "Return closest date to CURRENT starting from START.
+  "Return closest absolute date to CURRENT starting from START.
 
 CURRENT and START are both time stamps.
 
@@ -14961,12 +14961,19 @@ (defun org-closest-date (start current prefer)
 
 Only time stamps with a repeater are modified.  Any other time
 stamp stay unchanged.  In any case, return value is an absolute
-day number."
+day number.
+
+The return value is the number of days elapsed since the imaginary
+Gregorian date Sunday, December 31, 1 BC, as returned by
+`time-to-days'."
   (if (not (string-match "\\+\\([0-9]+\\)\\([hdwmy]\\)" start))
       ;; No repeater.  Do not shift time stamp.
       (time-to-days (org-time-string-to-time start))
-    (let ((value (string-to-number (match-string 1 start)))
-	  (type (match-string 2 start)))
+    (let* ((value (string-to-number (match-string 1 start)))
+	   (type (match-string 2 start))
+           (type-unit (pcase type
+                        ("h" 'hour) ("d" 'day) ("w" 'week)
+                        ("m" 'month) ("y" 'year))))
       (if (= 0 value)
 	  ;; Repeater with a 0-value is considered as void.
 	  (time-to-days (org-time-string-to-time start))
@@ -14993,50 +15000,17 @@ (defun org-closest-date (start current prefer)
 	       (let ((value (if (equal type "w") (* 7 value) value)))
 		 (setf n1 (+ sday (* value (/ (- cday sday) value))))
 		 (setf n2 (+ n1 value))))
-	      ("m"
-	       (let* ((add-months
-		       (lambda (d n)
-			 ;; Add N months to gregorian date D, i.e.,
-			 ;; a list (MONTH DAY YEAR).  Return a valid
-			 ;; gregorian date.
-			 (let ((m (+ (nth 0 d) n)))
-			   (list (mod m 12)
-				 (nth 1 d)
-				 (+ (/ m 12) (nth 2 d))))))
-		      (months		; Complete months to TARGET.
-		       (* (/ (+ (* 12 (- (nth 2 target) (nth 2 base)))
-				(- (nth 0 target) (nth 0 base))
-				;; If START's day is greater than
-				;; TARGET's, remove incomplete month.
-				(if (> (nth 1 target) (nth 1 base)) 0 -1))
-			     value)
-			  value))
-		      (before (funcall add-months base months)))
-		 (setf n1 (calendar-absolute-from-gregorian before))
-		 (setf n2
-		       (calendar-absolute-from-gregorian
-			(funcall add-months before value)))))
-	      (_
-	       (let* ((d (nth 1 base))
-		      (m (nth 0 base))
-		      (y (nth 2 base))
-		      (years		; Complete years to TARGET.
-		       (* (/ (- (nth 2 target)
-				y
-				;; If START's month and day are
-				;; greater than TARGET's, remove
-				;; incomplete year.
-				(if (or (> (nth 0 target) m)
-					(and (= (nth 0 target) m)
-					     (> (nth 1 target) d)))
-				    0
-				  1))
-			     value)
-			  value))
-		      (before (list m d (+ y years))))
-		 (setf n1 (calendar-absolute-from-gregorian before))
-		 (setf n2 (calendar-absolute-from-gregorian
-			   (list m d (+ (nth 2 before) value)))))))
+	      ((or "m" "y")
+	       (let* ((running-date (org-parse-time-string start))
+                      (next-date (org-time-inc type-unit value running-date))
+                      (current-date (org-parse-time-string current)))
+                 (while (not (time-less-p (org-encode-time current-date)
+                                        (org-encode-time next-date)))
+                   (setq running-date next-date
+                         next-date (org-time-inc type-unit value running-date)))
+                 (setf n1 (time-to-days (org-encode-time running-date))
+                       n2 (time-to-days (org-encode-time next-date)))))
+	      (_ (error "Unsupported repeater type: %S" type)))
 	    ;; Handle PREFER parameter, if any.
 	    (cond
 	     ((eq prefer 'past)   (if (= cday n2) n2 n1))
@@ -15193,6 +15167,52 @@ (defun org-at-clock-log-p ()
         (save-match-data (org-element-at-point))
         'clock)))
 
+(defcustom org-repeat-round-time t
+  "When non-nil, adjust repeated date down if it points to non-existing date.
+
+For example, when the repeater is monthly, this option, when non-nil,
+makes 31 May 2024 repeat to 30 June 2024 next month, adjusting the
+date down to avoid non-existent June 31st.  When nil, the same
+repeater would instead repeat the date at July 1st, retaining the
+extra day created by adding a monthly repeater."
+  :group 'org-time
+  :type 'boolean
+  :package-version '(Org . 9.7))
+
+(defun org-time-inc (unit value time)
+  "Increment TIME by VALUE UNITs and return new decoded time.
+TIME is decoded time, as returned by `decode-time'.
+VALUE is a number.  UNIT is one of symbols `second', `minute', `hour',
+`day', `month', `year'."
+  (unless (memq unit '(second minute hour day month year))
+    (error "org-time-inc: Unknown unit %S" unit))
+  (let ((new-time
+         (decode-time
+          (org-encode-time
+           (list
+            (+ (if (eq unit 'second) value 0) (decoded-time-second time))
+            (+ (if (eq unit 'minute) value 0) (decoded-time-minute time))
+            (+ (if (eq unit 'hour) value 0)   (decoded-time-hour time))
+            (+ (if (eq unit 'day) value 0)    (decoded-time-day time))
+            (+ (if (eq unit 'month) value 0)  (decoded-time-month time))
+            (+ (if (eq unit 'year) value 0)   (decoded-time-year time))
+            (decoded-time-weekday time)
+            (if (memq unit '(day month year))
+                nil ; Avoid auto-adjustments of time when jumping across DST.
+              (decoded-time-dst time))
+            (decoded-time-zone time))))))
+    (if (not org-repeat-round-time) new-time
+      (pcase unit
+        ((or `year `month)
+         (let ((target-year (when (eq unit 'year) (+ value (decoded-time-year time))))
+               (target-month (when (eq unit 'month) (+ value (decoded-time-month time)))))
+           (when (> target-month 12) (setq target-month (mod target-month 12)))
+           (while (or (and target-year (not (equal (decoded-time-year new-time) target-year)))
+                      (and target-month (not (equal (decoded-time-month new-time) target-month))))
+             (setq new-time (org-time-inc 'day -1 new-time)))
+           new-time))
+        (_ new-time)))))
+
 (defvar org-clock-history)                     ; defined in org-clock.el
 (defvar org-clock-adjust-closest nil)          ; defined in org-clock.el
 (defun org-timestamp-change (n &optional what updown suppress-tmp-delay)
@@ -15259,16 +15279,7 @@ (defun org-timestamp-change (n &optional what updown suppress-tmp-delay)
           ;; argument is supplied - just use whatever is provided by the
           ;; prefix argument.
           (setq dm 1))
-        (setq time
-	      (org-encode-time
-               (apply #'list
-                      (or (car time0) 0)
-                      (+ (if (eq timestamp? 'minute) increment 0) (nth 1 time0))
-                      (+ (if (eq timestamp? 'hour) increment 0)   (nth 2 time0))
-                      (+ (if (eq timestamp? 'day) increment 0)    (nth 3 time0))
-                      (+ (if (eq timestamp? 'month) increment 0)  (nth 4 time0))
-                      (+ (if (eq timestamp? 'year) increment 0)   (nth 5 time0))
-                      (nthcdr 6 time0)))))
+        (setq time (org-encode-time (org-time-inc timestamp? increment time0))))
       (when (and (memq timestamp? '(hour minute))
 		 extra
 		 (string-match "-\\([012][0-9]\\):\\([0-5][0-9]\\)" extra))
-- 
2.45.0


[-- Attachment #3: Type: text/plain, Size: 224 bytes --]


-- 
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>