Re: Allowing multiple date trees in a single file

[Nicolas Goaziou <mail@nicolasgoaziou.fr>]

Hello,

Carsten Dominik <dominik@uva.nl> writes:

> Attached is a patch that does the following:
>
> It consolidates all four different org-capture target types that have to do
> with
> date/week trees into a single one, called `file+olp+datetree'.  This target
> allows for an optional outline path specification to tell capture to build
> the
> datetree under a specific headline.  To switch to a week tree, or to force
> a date prompt is now the matter of setting one of the properties in the
> org-capture-template variable.

It sounds good. Thank you.

> Everything works transparently, so users can update the way they
> write their datetree captures, but they don't have to - the old syntax
> remains
> supported and will automatically switched when one uses customize to change
> the variable.

I am a bit worried by this compatibility layer. I mean, it is good to
preserve compatibility with old templates, but it ought to be an
ephemeral solution. I.e., no more
`org-table--error-on-old-row-references' lingering around for ages.

We could, for example, generate a deprecation warning when old templates
are used. Then we will be able to remove this unnecessary piece of code
in next major release.

See for example the end of `org-open-file', although it is a bit more
drastic (it raises an error, not a warning).

> After a bit more testing, I'd like to apply this patch.  Please let me know
> if you agree. And additional testers would be useful.  Anyone?  Make sure
> to backup your capture templates if something goes wrong.

Some comments follow.

> -@item (file+weektree+prompt "path/to/file")
> -Will create a heading in a week tree, but will prompt for the date.
> +one matched.}.  If the optional outline path is given, the tree will be built
> +under the node it is pointing to. Check out the @code{:time-prompt} and

There's a missing space above.

> +(defun org-capture-upgrade-templates (templates)
> +  "Update the template list to the new format.
> +The new format unifies all the date/week tree targets into one that
> +also allows for an optional outline path to specify a target."
> +  (let (target props)
> +    (mapcar
> +     (lambda (ee)
> +       (setq target (car (nth 3 ee)))
> +       (when (memq target '(file+datetree file+datetree+prompt
> +					  file+weektree file+weektree+prompt))
> +	 (setq target (symbol-name target) props nil)
> +	 (if (string-match "prompt" target) (setq props '(:time-prompt t)))
> +	 (if (string-match "week" target)
> +	     (setq props (append '(:tree-type week) props)))
> +	 (setcar (nth 3 ee) 'file+olp+datetree)
> +	 (setcdr (nthcdr 4 ee) (append props (nthcdr 5 ee))))
> +       ee)
> +     templates)))

I suggest the following. Less `setq', `setcar', `setcdr' makes Org
a better place.

(defun org-capture-upgrade-templates (templates)
  "Update the template list to the new format.
TEMPLATES is a template list, as in `org-capture-templates'. The
new format unifies all the date/week tree targets into one that
also allows for an optional outline path to specify a target."
  (mapcar
   (lambda (template)
     (pcase template
       ;; Match templates with an obsolete "tree" target type. Replace
       ;; it with common `file+olp-datetree'.  Add new properties
       ;; (i.e., `:time-prompt' and `:tree-type') if needed.
       (`(,key ,desc ,type (file+datetree . ,path) ,template . ,props)
        `(,key ,desc ,type (file+olp+datetree ,@path) ,@props))
       (`(,key ,desc ,type (file+datetree+prompt . ,path) ,template . ,props)
        `(,key ,desc ,type (file+olp+datetree ,@path) :time-prompt t ,@props))
       (`(,key ,desc ,type (file+weektree . ,path) ,template . ,props)
        `(,key ,desc ,type (file+olp+datetree ,@path) :tree-type week ,@props))
       (`(,key ,desc ,type (file+weektree+prompt . ,path) ,template . ,props)
        `(,key ,desc ,type (file+olp+datetree ,@path) :tree-type week :time-prompt t ,@props))
       ;; Other templates are left unchanged.
       (_ template)))
   templates))

> -             (file+weektree+prompt \"path/to/file\")
> -                 Will create a heading in a week tree, prompts for date
> +             (file+olp+datetree \"path/to/file\" \"Level 1 heading\" ...)
> +                 Will create a heading in a date tree for today's date.
> +                 If no headings are given, the tree will be on top level.

Nitpick: It may be just me, but "If no heading is given" sounds better.

>  ELisp programs can set KEYS to a string associated with a template
>  in `org-capture-templates'.  In this case, interactive selection
>  will be bypassed.
> @@ -902,6 +920,7 @@ Store them in the capture property list."
>  	   (insert "* " headline "\n")
>  	   (beginning-of-line 0)))
>  	(`(file+olp ,path . ,outline-path)
> +	 (setq outline-path (org-capture-sanitize-olp outline-path))

See below about `org-capture-sanitize-olp'.

Also, it is better to make the `setq' a let-binding when possible.

>  	 (let ((m (org-find-olp (cons (org-capture-expand-file path)
>  				      outline-path))))
>  	   (set-buffer (marker-buffer m))
> @@ -922,59 +941,65 @@ Store them in the capture property list."
>  	   (org-capture-put :exact-position (point))
>  	   (setq target-entry-p
>  		 (and (derived-mode-p 'org-mode) (org-at-heading-p)))))

[...]

> +	(`(file+olp+datetree ,path . ,outline-path)
> +	 (setq outline-path (org-capture-sanitize-olp outline-path))

Ditto.

> +	 (let ((m (if outline-path
> +		      (org-find-olp (cons (org-capture-expand-file path)
> +					  outline-path))
> +		    (set-buffer (org-capture-target-buffer path))
> +		    (move-marker (make-marker) (point)))))		    
> +	   (set-buffer (marker-buffer m))
> +	   (org-capture-put-target-region-and-position)
> +	   (widen)
> +	   (goto-char m)
> +	   (set-marker m nil)
> +	   (require 'org-datetree)
> +	   (org-capture-put-target-region-and-position)
> +	   (widen)
> +	   ;; Make a date/week tree entry, with the current date (or
> +	   ;; yesterday, if we are extending dates for a couple of hours)
> +	   (funcall
> +	    (if (eq (org-capture-get :tree-type) 'week)
> +		#'org-datetree-find-iso-week-create
> +	      #'org-datetree-find-date-create)
> +	    (calendar-gregorian-from-absolute
> +	     (cond
> +	      (org-overriding-default-time
> +	       ;; Use the overriding default time.
> +	       (time-to-days org-overriding-default-time))
> +	      ((org-capture-get :time-prompt)
> +	       ;; Prompt for date.
> +	       (let ((prompt-time (org-read-date
> +				   nil t nil "Date for tree entry:"
> +				   (current-time))))
> +		 (org-capture-put
> +		  :default-time
> +		  (cond ((and (or (not (boundp 'org-time-was-given))
> +				  (not org-time-was-given))
> +			      (not (= (time-to-days prompt-time) (org-today))))
> +			 ;; Use 00:00 when no time is given for another
> +			 ;; date than today?
> +			 (apply #'encode-time
> +				(append '(0 0 0)
> +					(cl-cdddr (decode-time prompt-time)))))
> +			((string-match "\\([^ ]+\\)--?[^ ]+[ ]+\\(.*\\)"
> +				       org-read-date-final-answer)
> +			 ;; Replace any time range by its start.
> +			 (apply #'encode-time
> +				(org-read-date-analyze
> +				 (replace-match "\\1 \\2" nil nil
> +						org-read-date-final-answer)
> +				 prompt-time (decode-time prompt-time))))
> +			(t prompt-time)))
> +		 (time-to-days prompt-time)))
> +	      (t
> +	       ;; Current date, possibly corrected for late night
> +	       ;; workers.
> +	       (org-today))))
> +	    ;; the following is the keep-restriction argument for
> +	    ;; org-datetree-find-date-create

  ;; The following...
  ;; ... `org-datetree-find-date-create'.

> +	    (if outline-path 'subtree-at-point)

  (and outline-path 'subtree-at-point)

> +	    )))

These trailing parens need to be moved above.

>  	(`(file+function ,path ,function)
>  	 (set-buffer (org-capture-target-buffer path))
>  	 (org-capture-put-target-region-and-position)
> @@ -1432,6 +1457,13 @@ Use PREFIX as a prefix for the name of the indirect buffer."
>    (unless (org-kill-is-subtree-p tree)
>      (error "Template is not a valid Org entry or tree")))
>  
> +(defun org-capture-sanitize-olp (olp)
> +  "Keep only non-white strings in the list OPL."
> +  (let (res e)
> +    (while (setq e (pop olp))
> +      (and (stringp e) (string-match "\\S-" e) (push e res)))
> +    (nreverse res)))

This function is really a one-liner:

  (cl-remove-if-not #'org-string-nw-p olp)

Therefore, I don't think it deserves a dedicated function.

BTW is there any reason to prune non-white strings from the list? Is an
empty string even invalid, since document can contain blank headlines?

The outline path is provided by the user. We can assume he knows what he
is doing.

Another option would be to barf if the outline path contains any invalid
value instead of silently "fixing" it on user's behalf. E.g.,

  (when (cl-some #'invalid-value-check olp)
    (user-error "Invalid outline path in template %S" template))

for some value of #'invalid-value-check.

WDYT?

>  When it is nil, the buffer will be widened to make sure an existing date
> -tree can be found."
> +tree can be found.  If it is the sympol `subtree-at-point', then the tree
> +will be built under the headline at point."
>    (setq-local org-datetree-base-level 1)
> -  (or keep-restriction (widen))
>    (save-restriction
> -    (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)))
> +    (if (eq keep-restriction 'subtree-at-point)
> +	(progn
> +	  (or (org-at-heading-p) (error "Not at heading"))

Nitpick:

  (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)))
> +      (or keep-restriction (widen))

  (unless keep-restriction (widen))

> +      ;; support the old way of tree placement, using a property

  ;; Support ... 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))
> @@ -84,18 +93,26 @@ tree can be found."
>    "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.
> -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."
> +When it is nil, the buffer will be widened to make sure an existing date
> +tree can be found.  If it is the sympol `subtree-at-point', then the tree
> +will be built under the headline at point."
>    (setq-local org-datetree-base-level 1)
> -  (or keep-restriction (widen))
>    (save-restriction
> -    (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)))
> +    (if (eq keep-restriction 'subtree-at-point)
> +	(progn
> +	  (or (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)))
> +      (or 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))))

See above, since the same suggestions apply. Also, it looks like there
is some code duplication involved here. Would it make sense to factor
the common part out of them?

>      (goto-char (point-min))
>      (require 'cal-iso)
>      (let* ((year (calendar-extract-year d))
> 	Modified lisp/org.el
> diff --git a/lisp/org.el b/lisp/org.el
> index 38fce70..ac56d71 100644
> --- a/lisp/org.el
> +++ b/lisp/org.el
> @@ -16615,6 +16615,8 @@ only headings."
>  	 end found flevel)
>      (unless buffer (error "File not found :%s" file))
>      (with-current-buffer buffer
> +      (unless (derived-mode-p 'org-mode)
> +	(error "Buffer %s needs to be in org-mode" buffer))

Nitpick: "Buffer %s needs to be in Org mode"

Ideally, a bunch of tests in test-org-capture.el would be nice.


Regards,

-- 
Nicolas Goaziou