Re: [Orgmode] [PATCH 2/2] org-agenda: add org-agenda-day-face-function

[Julien Danjou]

On Fri, Nov 12 2010, Carsten Dominik wrote:

> to make sure I don't make a mistake here, could you please send a new patch
> which contains all the changes in a single patch.
>
> Sorry about this.

No problem, here it is.

>From 38567a7d7a58e523964be216f791e4c78a085c52 Mon Sep 17 00:00:00 2001
From: Julien Danjou <address@hidden>
Date: Mon, 8 Nov 2010 15:25:22 +0100
Subject: [PATCH] org-agenda: introduce org-agenda-today, 
org-agenda-get-day-face and org-agenda-day-face-function

* lisp/org-agenda.el (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.
(org-agenda-day-face-function): New variable.
(org-agenda-get-day-face): Use org-agenda-day-face-function.

Signed-off-by: Julien Danjou <address@hidden>
---
 lisp/org-agenda.el |   75 +++++++++++++++++++++++++++++----------------------
 1 files changed, 43 insertions(+), 32 deletions(-)

diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 583e670..e2d20b5 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -1433,6 +1433,14 @@ determines if it is a foreground or a background color."
                                   (string :tag "Color")
                                   (sexp :tag "Face"))))))
 
+(defcustom org-agenda-day-face-function nil
+  "Function called to determine what face should be used to display a day.
+The only argument passed to that function is the day. It should
+returns a face, or nil if does not want to specify a face and let
+the normal rules apply."
+  :group 'org-agenda-line-format
+  :type 'function)
+
 (defcustom org-agenda-category-icon-alist nil
   "Alist of category icon to be displayed in agenda views.
 
@@ -3106,6 +3114,16 @@ 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."
+  (or (and (functionp org-agenda-day-face-function)
+          (funcall org-agenda-day-face-function date))
+      (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 +3151,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 +3188,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 +3202,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 +3228,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 +3339,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 +3352,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 +3410,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 +3453,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 +3782,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 +5911,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 +6719,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 +7868,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 +7911,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 (and date (listp date)) (calendar-absolute-from-gregorian 
date)
+               date)))
+    (eq date today)))
 
 (provide 'org-agenda)
 
-- 
1.7.2.3

-- 
Julien Danjou
// ᐰ <address@hidden>   http://julien.danjou.info