From mboxrd@z Thu Jan 1 00:00:00 1970 From: Carsten Dominik Subject: Re: [PATCH 2/2] org-agenda: add org-agenda-day-face-function Date: Fri, 12 Nov 2010 09:43:03 -0600 Message-ID: References: <1289236987-21552-1-git-send-email-julien@danjou.info> <1289236987-21552-2-git-send-email-julien@danjou.info> Mime-Version: 1.0 (Apple Message framework v936) Content-Type: text/plain; charset=UTF-8; format=flowed; delsp=yes Content-Transfer-Encoding: quoted-printable Return-path: Received: from [140.186.70.92] (port=43790 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PGvmP-0003XB-5o for emacs-orgmode@gnu.org; Fri, 12 Nov 2010 10:43:11 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1PGvmM-00015P-Hx for emacs-orgmode@gnu.org; Fri, 12 Nov 2010 10:43:08 -0500 Received: from mail-gx0-f169.google.com ([209.85.161.169]:54295) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1PGvmM-00015I-EP for emacs-orgmode@gnu.org; Fri, 12 Nov 2010 10:43:06 -0500 Received: by gxk22 with SMTP id 22so609410gxk.0 for ; Fri, 12 Nov 2010 07:43:05 -0800 (PST) In-Reply-To: List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Sender: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org To: Julien Danjou Cc: emacs-orgmode@gnu.org Applied, thanks. I did not test it myself (have grown to trust Julien...), so if =20 someone can put this to a test, that would be nice. Cheers - Carsten On Nov 12, 2010, at 9:34 AM, Julien Danjou wrote: > On Fri, Nov 12 2010, Carsten Dominik wrote: > >> to make sure I don't make a mistake here, could you please send a =20 >> new patch >> which contains all the changes in a single patch. >> >> Sorry about this. > > No problem, here it is. > > =46rom 38567a7d7a58e523964be216f791e4c78a085c52 Mon Sep 17 00:00:00 = 2001 > From: Julien Danjou > Date: Mon, 8 Nov 2010 15:25:22 +0100 > Subject: [PATCH] org-agenda: introduce org-agenda-today, org-agenda-=20= > 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 > --- > lisp/org-agenda.el | 75 ++++++++++++++++++++++++++++=20 > +---------------------- > 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 =20 > 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 =20= > 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 =20 > 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 (=3D d today)) > (and (not start-pos) (=3D 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-=20= > 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 =20 > 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 =20= > 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 =20= > 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 =20 > 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" =20 > ""))))) > > +(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 =20 > date))) > - (setq today (calendar-absolute-from-gregorian (calendar-current-=20= > date))) > - (setq h (nth 2 (decode-time (current-time)))) > - (or (and (>=3D h org-extend-today-until) > - (=3D date today)) > - (and (< h org-extend-today-until) > - (=3D date (1- today)))))) > + (let ((today (org-agenda-today)) > + (date (if (and date (listp date)) (calendar-absolute-from-=20 > gregorian date) > + date))) > + (eq date today))) > > (provide 'org-agenda) > > --=20 > 1.7.2.3 > > > --=20 > Julien Danjou > // =E1=90=B0 http://julien.danjou.info