Re: [PATCH 1/2] org-agenda: introduce org-agenda-today and org-agenda-get-day-face

[Carsten Dominik <carsten.dominik@gmail.com>]

Hi Julien,

can you please rename org-agenda-today to org-agenda-today-p?
I think it would make its use clearer.

Also, couly you please specify in the docstring of org-agenda-day-face- 
function how the day is coming in into the user-defined function?  As  
a day number or a calendar date list?

As far as I can see, we can merge this change after these fixes.

Thanks.

- Carsten

On Nov 8, 2010, at 11:23 AM, Julien Danjou wrote:

> * org-agenda (org-agenda-today): New function.
> (org-agenda-get-day-face): New function.
> (org-timeline): Use org-agenda-today and org-agenda-get-day-face.
> (org-agenda-list): Use org-agenda-today and org-agenda-get-day-face.
> (org-todo-list): Use org-agenda-today.
> (org-get-all-dates): Use org-agenda-today.
>
> Signed-off-by: Julien Danjou <julien@danjou.info>
> ---
> lisp/org-agenda.el |   65 +++++++++++++++++++++++++ 
> +-------------------------
> 1 files changed, 33 insertions(+), 32 deletions(-)
>
> diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
> index 583e670..98371e6 100644
> --- a/lisp/org-agenda.el
> +++ b/lisp/org-agenda.el
> @@ -3106,6 +3106,14 @@ no longer in use."
> 		      (progn (delete-overlay o) t)))
> 		(overlays-in (point-min) (point-max)))))
>
> +(defun org-agenda-get-day-face (date)
> +  "Return the face DATE should be displayed with."
> +  (cond ((org-agenda-todayp date)
> +	 'org-agenda-date-today)
> +	((member (calendar-day-of-week date) org-agenda-weekend-days)
> +	 'org-agenda-date-weekend)
> +	(t 'org-agenda-date)))
> +
> ;;; Agenda timeline
>
> (defvar org-agenda-only-exact-dates nil) ; dynamically scoped
> @@ -3133,10 +3141,10 @@ dates."
> 					 org-timeline-show-empty-dates))
> 	 (org-deadline-warning-days 0)
> 	 (org-agenda-only-exact-dates t)
> -	 (today (time-to-days (current-time)))
> +	 (today (org-agenda-today))
> 	 (past t)
> 	 args
> -	 s e rtn d emptyp wd)
> +	 s e rtn d emptyp)
>     (setq org-agenda-redo-command
> 	  (list 'progn
> 		(list 'org-switch-to-buffer-other-window (current-buffer))
> @@ -3170,8 +3178,7 @@ dates."
> 	    (progn
> 	      (setq past nil)
> 	      (insert (make-string 79 ?-) "\n")))
> -	(setq date (calendar-gregorian-from-absolute d)
> -	      wd (calendar-day-of-week date))
> +	(setq date (calendar-gregorian-from-absolute d))
> 	(setq s (point))
> 	(setq rtn (and (not emptyp)
> 		       (apply 'org-agenda-get-day-entries entry
> @@ -3185,9 +3192,7 @@ dates."
> 		 (funcall org-agenda-format-date date))
> 	       "\n")
> 	      (put-text-property s (1- (point)) 'face
> -				 (if (member wd org-agenda-weekend-days)
> -				     'org-agenda-date-weekend
> -				   'org-agenda-date))
> +				 (org-agenda-get-day-face date))
> 	      (put-text-property s (1- (point)) 'org-date-line t)
> 	      (put-text-property s (1- (point)) 'org-agenda-date-header t)
> 	      (if (equal d today)
> @@ -3213,7 +3218,7 @@ When EMPTY is non-nil, also include days  
> without any entries."
> 	     (if inactive org-ts-regexp-both org-ts-regexp)))
> 	 dates dates1 date day day1 day2 ts1 ts2)
>     (if force-today
> -	(setq dates (list (time-to-days (current-time)))))
> +	(setq dates (list (org-agenda-today))))
>     (save-excursion
>       (goto-char beg)
>       (while (re-search-forward re end t)
> @@ -3324,9 +3329,7 @@ given in `org-agenda-start-on-weekday'."
> 	      org-agenda-start-on-weekday nil))
> 	 (thefiles (org-agenda-files nil 'ifmode))
> 	 (files thefiles)
> -	 (today (time-to-days
> -		 (time-subtract (current-time)
> -				(list 0 (* 3600 org-extend-today-until) 0))))
> +	 (today (org-agenda-today))
> 	 (sd (or start-day today))
> 	 (start (if (or (null org-agenda-start-on-weekday)
> 			(< org-agenda-ndays 7))
> @@ -3339,7 +3342,7 @@ given in `org-agenda-start-on-weekday'."
> 	 (day-numbers (list start))
> 	 (day-cnt 0)
> 	 (inhibit-redisplay (not debug-on-error))
> -	 s e rtn rtnall file date d start-pos end-pos todayp nd wd
> +	 s e rtn rtnall file date d start-pos end-pos todayp nd
> 	 clocktable-start clocktable-end filter)
>     (setq org-agenda-redo-command
> 	  (list 'org-agenda-list (list 'quote include-all) start-day ndays))
> @@ -3397,7 +3400,6 @@ given in `org-agenda-start-on-weekday'."
>       (org-agenda-mark-header-line s))
>     (while (setq d (pop day-numbers))
>       (setq date (calendar-gregorian-from-absolute d)
> -	    wd (calendar-day-of-week date)
> 	    s (point))
>       (if (or (setq todayp (= d today))
> 	      (and (not start-pos) (= d sd)))
> @@ -3441,15 +3443,12 @@ given in `org-agenda-start-on-weekday'."
> 	       (funcall org-agenda-format-date date))
> 	     "\n")
> 	    (put-text-property s (1- (point)) 'face
> -			       (if (member wd org-agenda-weekend-days)
> -				   'org-agenda-date-weekend
> -				 'org-agenda-date))
> +			       (org-agenda-get-day-face date))
> 	    (put-text-property s (1- (point)) 'org-date-line t)
> 	    (put-text-property s (1- (point)) 'org-agenda-date-header t)
> 	    (put-text-property s (1- (point)) 'org-day-cnt day-cnt)
> 	    (when todayp
> -	      (put-text-property s (1- (point)) 'org-today t)
> -	      (put-text-property s (1- (point)) 'face 'org-agenda-date- 
> today))
> +	      (put-text-property s (1- (point)) 'org-today t))
> 	    (if rtnall (insert
> 			(org-finalize-agenda-entries
> 			 (org-agenda-add-time-grid-maybe
> @@ -3773,7 +3772,7 @@ for a keyword.  A numeric prefix directly  
> selects the Nth keyword in
>   (org-set-sorting-strategy 'todo)
>   (org-prepare-agenda "TODO")
>   (if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg  
> nil))
> -  (let* ((today (time-to-days (current-time)))
> +  (let* ((today (org-agenda-today))
> 	 (date (calendar-gregorian-from-absolute today))
> 	 (kwds org-todo-keywords-for-agenda)
> 	 (completion-ignore-case t)
> @@ -5902,9 +5901,7 @@ Negative selection means regexp must not match  
> for selection of an entry."
>     (cond
>      (tdpos (goto-char tdpos))
>      ((eq org-agenda-type 'agenda)
> -      (let* ((sd (time-to-days
> -		  (time-subtract (current-time)
> -				 (list 0 (* 3600 org-extend-today-until) 0))))
> +      (let* ((sd (org-agenda-today))
> 	     (comp (org-agenda-compute-time-span sd org-agenda-span))
> 	     (org-agenda-overriding-arguments org-agenda-last-arguments))
> 	(setf (nth 1 org-agenda-overriding-arguments) (car comp))
> @@ -6712,8 +6709,7 @@ the same tree node, and the headline of the  
> tree node in the Org-mode file."
> 	 (buffer (marker-buffer marker))
> 	 (pos (marker-position marker))
> 	 (hdmarker (org-get-at-bol 'org-hd-marker))
> -	 (todayp (equal (org-get-at-bol 'day)
> -			(time-to-days (current-time))))
> +	 (todayp (org-agenda-todayp (org-get-at-bol 'day)))
> 	 (inhibit-read-only t)
> 	 org-agenda-headline-snapshot-before-repeat newhead just-one)
>     (org-with-remote-undo buffer
> @@ -7862,6 +7858,9 @@ belonging to the \"Work\" category."
>   (let* ((cnt 0) ; count added events
> 	 (org-agenda-new-buffers nil)
> 	 (org-deadline-warning-days 0)
> +	 ;; Do not use `org-agenda-today' here because appt only takes
> +	 ;; time and without date as argument, so it may pass wrong
> +	 ;; information otherwise
> 	 (today (org-date-to-gregorian
> 		 (time-to-days (current-time))))
> 	 (org-agenda-restrict nil)
> @@ -7902,16 +7901,18 @@ belonging to the \"Work\" category."
> 	(message "No event to add")
>       (message "Added %d event%s for today" cnt (if (> cnt 1) "s"  
> "")))))
>
> +(defun org-agenda-today ()
> +  "Return today date, considering `org-extend-today-until'."
> +  (time-to-days
> +   (time-subtract (current-time)
> +		  (list 0 (* 3600 org-extend-today-until) 0))))
> +
> (defun org-agenda-todayp (date)
>   "Does DATE mean today, when considering `org-extend-today-until'?"
> -  (let (today h)
> -    (if (listp date) (setq date (calendar-absolute-from-gregorian  
> date)))
> -    (setq today (calendar-absolute-from-gregorian (calendar-current- 
> date)))
> -    (setq h (nth 2 (decode-time (current-time))))
> -    (or (and (>= h org-extend-today-until)
> -	     (= date today))
> -	(and (< h org-extend-today-until)
> -	     (= date (1- today))))))
> +  (let ((today (org-agenda-today))
> +	(date (if (listp date) (calendar-absolute-from-gregorian date)
> +		date)))
> +    (eq date today)))
>
> (provide 'org-agenda)
>
> -- 
> 1.7.2.3
>
>
> _______________________________________________
> Emacs-orgmode mailing list
> Please use `Reply All' to send replies to the list.
> Emacs-orgmode@gnu.org
> http://lists.gnu.org/mailman/listinfo/emacs-orgmode