From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Ami Fischman Newsgroups: gmane.emacs.devel Subject: specific coloring of diary calendar entries Date: Wed, 11 Dec 2002 15:58:37 -0800 Sender: emacs-devel-bounces+emacs-devel=quimby.gnus.org@gnu.org Message-ID: NNTP-Posting-Host: main.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: main.gmane.org 1039651213 21140 80.91.224.249 (12 Dec 2002 00:00:13 GMT) X-Complaints-To: usenet@main.gmane.org NNTP-Posting-Date: Thu, 12 Dec 2002 00:00:13 +0000 (UTC) Return-path: Original-Received: from quimby.gnus.org ([80.91.224.244]) by main.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 18MGlp-0005Ub-00 for ; Thu, 12 Dec 2002 01:00:05 +0100 Original-Received: from monty-python.gnu.org ([199.232.76.173]) by quimby.gnus.org with esmtp (Exim 3.12 #1 (Debian)) id 18MGx0-00026D-00 for ; Thu, 12 Dec 2002 01:11:44 +0100 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.10.13) id 18MGlZ-0007NV-02 for emacs-devel@quimby.gnus.org; Wed, 11 Dec 2002 18:59:49 -0500 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.10.13) id 18MGl5-0006lO-00 for emacs-devel@gnu.org; Wed, 11 Dec 2002 18:59:19 -0500 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.10.13) id 18MGke-0005Pn-00 for emacs-devel@gnu.org; Wed, 11 Dec 2002 18:59:08 -0500 Original-Received: from 12-228-169-213.client.attbi.com ([12.228.169.213] helo=fischman.org) by monty-python.gnu.org with smtp (Exim 4.10.13) id 18MGkW-0004fx-00 for emacs-devel@gnu.org; Wed, 11 Dec 2002 18:58:45 -0500 Original-Received: (qmail 28201 invoked by uid 500); 11 Dec 2002 23:58:37 -0000 Original-To: emacs-devel@gnu.org User-Agent: Gnus/5.090008 (Oort Gnus v0.08) Emacs/21.2.50 (i686-pc-linux-gnu) X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1b5 Precedence: list List-Id: Emacs development discussions. List-Help: List-Post: List-Subscribe: , List-Archive: List-Unsubscribe: , Errors-To: emacs-devel-bounces+emacs-devel=quimby.gnus.org@gnu.org Xref: main.gmane.org gmane.emacs.devel:10075 X-Report-Spam: http://spam.gmane.org/gmane.emacs.devel:10075 --=-=-= [apologies if this appears twice; attempted posting two days ago, but the post never appeared on the list] Attached are two patches that make it possible to specify a color for a diary entry in the entry itself. This is done via "color tags" -- a string that looks like "[color:blue]" (without the quotes, and blue can be any standard X color). This color comes out both in the calendar display (dates are colored according to the events in them) and in the fancy diary display (entries are colored according to their specifications). The first entry matching a date is the one that determines the color for that date (so order DOES matter in ~/.diary files now). The color tag MUST appear at the end of a line (nothing other than a newline may follow it), and if one has a multi-line non-sexp entry, the color tag may appear on the first line of the entry. On multi-line sexp entries, the color tag may appear on any line in the sexp, at the end of the line. To tag all entries that don't have their own color tags, one may have a "global file color" specified: the first line in a file consisting of the string "# [color:lightgrey]" (without the double quotes) determines the color, and the entries in that file will default to that color. If a date matches more than one entry, the FIRST matching entry's color is used for the date. Regular entries get marked before sexp ones, so their colors always show up instead of sexp ones (which jives with the notion that sexp events are "generic" whereas regular entries are "specific" and so more attention-deserving). This solves a long-time wish of mine to be able to give "subtler" colors to less important events and glaring colors to events that demand my attention. It also solves a request of Kai Grossjohann for #include'd entry coloring, and hopefully makes diary/calendar modes a more attractive alternative for group-wide #include'd diary files. If there are no objections to the code (there may be; my lisp is very rusty), I'd like to see it committed to CVS. Any comments happily accepted. Cheers, -- Ami Fischman usenet@fischman.org --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=col-cal.patch *** calendar.el 2002-12-09 16:14:14.000000000 -0800 --- /usr/local/emacs/share/emacs/21.2.50/lisp/calendar/calendar.el 2002-04-16 15:10:10.000000000 -0700 *************** *** 2507,2536 **** (= (extract-calendar-year date1) (extract-calendar-year date2)))) (defun mark-visible-calendar-date (date &optional mark) "Mark DATE in the calendar window with MARK. ! MARK is either a single-character string, a color-name string (such as \"green\"), or a face. MARK defaults to diary-entry-marker." (if (calendar-date-is-legal-p date) (save-excursion (set-buffer calendar-buffer) (calendar-cursor-to-visible-date date) ! (let ((mark (or (and (stringp mark) (> (length mark) 0) mark) ! (and (not (stringp mark)) mark) ! diary-entry-marker))) (if (stringp mark) ! (if (= (length mark) 1) ! (let ((buffer-read-only nil)) ! (forward-char 1) ! (delete-char 1) ! (insert mark) ! (forward-char -2)) ! (progn ! (setq temp-face (make-symbol (concat "cal-col-face-" mark))) ! (make-face temp-face) ! (set-face-foreground temp-face mark) ! (overlay-put ! (make-overlay (1- (point)) (1+ (point))) 'face temp-face))) (overlay-put (make-overlay (1- (point)) (1+ (point))) 'face mark)))))) (defun calendar-star-date () --- 2507,2527 ---- (= (extract-calendar-year date1) (extract-calendar-year date2)))) (defun mark-visible-calendar-date (date &optional mark) "Mark DATE in the calendar window with MARK. ! MARK is either a single-character string or a face. MARK defaults to diary-entry-marker." (if (calendar-date-is-legal-p date) (save-excursion (set-buffer calendar-buffer) (calendar-cursor-to-visible-date date) ! (let ((mark (or mark diary-entry-marker))) (if (stringp mark) ! (let ((buffer-read-only nil)) ! (forward-char 1) ! (delete-char 1) ! (insert mark) ! (forward-char -2)) (overlay-put (make-overlay (1- (point)) (1+ (point))) 'face mark)))))) (defun calendar-star-date () --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=col-dia.patch *** diary-lib.el 2002-12-10 09:16:11.000000000 -0800 --- /usr/local/emacs/share/emacs/21.2.50/lisp/calendar/diary-lib.el 2002-08-28 08:16:15.000000000 -0700 *************** *** 246,261 **** (set-buffer (find-file-noselect d-file t)) (set-buffer diary-buffer) (or (verify-visited-file-modtime diary-buffer) (revert-buffer t t)))) - ;; AMI -- Figure out the file-glob-color - (setq file-glob-color "") - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "^#[ \t]*\\[color:\\([a-z]+\\)\\]$" (point-max) t) - (setq file-glob-color (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))) (setq selective-display t) (setq selective-display-ellipses nil) (setq old-diary-syntax-table (syntax-table)) (set-syntax-table diary-syntax-table) --- 246,253 ---- *************** *** 334,349 **** date (buffer-substring entry-start (point)) (buffer-substring ! (1+ date-start) (1- entry-start)) file-glob-color))))) (setq d (cdr d))) (or entry-found (not diary-list-include-blanks) (setq diary-entries-list (append diary-entries-list ! ;; AMI -- added a fourth element to a diary-entries-list element ! (list (list date "" "" ""))))) (setq date (calendar-gregorian-from-absolute (1+ (calendar-absolute-from-gregorian date)))) (setq entry-found nil))) --- 326,340 ---- date (buffer-substring entry-start (point)) (buffer-substring ! (1+ date-start) (1- entry-start))))))) (setq d (cdr d))) (or entry-found (not diary-list-include-blanks) (setq diary-entries-list (append diary-entries-list ! (list (list date "" ""))))) (setq date (calendar-gregorian-from-absolute (1+ (calendar-absolute-from-gregorian date)))) (setq entry-found nil))) *************** *** 518,548 **** x) date-holiday-list (concat "\n" (make-string l ? )))) (insert ?\n (make-string (+ l longest) ?=) ?\n))))) ! (setq entry (car (cdr (car entry-list)))) ! (if (< 0 (length entry)) ! (progn ! (insert entry ?\n) ! ;; AMI -- pick off the color that was the global file color for this entry when it was read in ! (setq file-glob-color (fourth (car entry-list))) ! ;; AMI - find color for this diary entry if one is present ! (setq color file-glob-color) ! (save-excursion ! (if (string-match "\\[color:\\([a-z]+\\)\\]$" entry) ! (setq color (substring-no-properties entry ! (match-beginning 1) ! (match-end 1)))) ! (if (not (string= color "")) ! (progn ! (search-backward entry) ! (setq temp-face (make-symbol (concat "cal-col-face-" color))) ! (make-face temp-face) ! (set-face-foreground temp-face color) ! (overlay-put ! (make-overlay (match-beginning 0) (match-end 0)) 'face temp-face))) ! ))) ! (setq entry-list (cdr entry-list)))) (set-buffer-modified-p nil) (goto-char (point-min)) (setq buffer-read-only t) (display-buffer fancy-diary-buffer) --- 509,519 ---- x) date-holiday-list (concat "\n" (make-string l ? )))) (insert ?\n (make-string (+ l longest) ?=) ?\n))))) ! (if (< 0 (length (car (cdr (car entry-list))))) ! (insert (car (cdr (car entry-list))) ?\n)) ! (setq entry-list (cdr entry-list)))) (set-buffer-modified-p nil) (goto-char (point-min)) (setq buffer-read-only t) (display-buffer fancy-diary-buffer) *************** *** 664,674 **** 0 1 * * * diary-rem.sh to run it every morning at 1am." (interactive "P") (let* ((diary-display-hook 'fancy-diary-display) ! ; AMI ! ; Do this so that I have a chance to NOT include blanks in the email ! ; (diary-list-include-blanks t) (text (progn (list-diary-entries (calendar-current-date) (if ndays ndays diary-mail-days)) (set-buffer fancy-diary-buffer) (buffer-substring (point-min) (point-max))))) --- 635,643 ---- 0 1 * * * diary-rem.sh to run it every morning at 1am." (interactive "P") (let* ((diary-display-hook 'fancy-diary-display) ! (diary-list-include-blanks t) (text (progn (list-diary-entries (calendar-current-date) (if ndays ndays diary-mail-days)) (set-buffer fancy-diary-buffer) (buffer-substring (point-min) (point-max))))) *************** *** 719,734 **** (if (file-readable-p d-file) (save-excursion (message "Marking diary entries...") (set-buffer (find-file-noselect d-file t)) - ;; AMI - find global color for this file - (setq file-glob-color "") - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "^#[ \t]*\\[color:\\([a-z]+\\)\\]$" (point-max) t) - (setq file-glob-color (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))) (let ((d diary-date-forms) (old-diary-syntax-table)) (setq old-diary-syntax-table (syntax-table)) (set-syntax-table diary-syntax-table) --- 688,695 ---- *************** *** 805,827 **** (if (> (- current-y y) 50) (+ y 100) y))) (string-to-int y-str))))) - ;; AMI - find color for this diary entry - (setq color file-glob-color) - (save-excursion - (if (re-search-forward "\\[color:\\([a-z]+\\)\\]$" (line-end-position) t) - (setq color (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))) (if dd-name (mark-calendar-days-named (cdr (assoc-ignore-case (substring dd-name 0 3) (calendar-make-alist calendar-day-name-array 0 ! (lambda (x) (substring x 0 3))))) color) (if mm-name (if (string-equal mm-name "*") (setq mm 0) (setq mm --- 766,781 ---- (if (> (- current-y y) 50) (+ y 100) y))) (string-to-int y-str))))) (if dd-name (mark-calendar-days-named (cdr (assoc-ignore-case (substring dd-name 0 3) (calendar-make-alist calendar-day-name-array 0 ! (lambda (x) (substring x 0 3)))))) (if mm-name (if (string-equal mm-name "*") (setq mm 0) (setq mm *************** *** 831,839 **** calendar-month-name-array 1 (lambda (x) (substring x 0 3))) ))))) ! (mark-calendar-date-pattern mm dd yy color)))) (setq d (cdr d)))) (mark-sexp-diary-entries) (run-hooks 'nongregorian-diary-marking-hook 'mark-diary-entries-hook) --- 785,793 ---- calendar-month-name-array 1 (lambda (x) (substring x 0 3))) ))))) ! (mark-calendar-date-pattern mm dd yy)))) (setq d (cdr d)))) (mark-sexp-diary-entries) (run-hooks 'nongregorian-diary-marking-hook 'mark-diary-entries-hook) *************** *** 887,895 **** (char-equal (preceding-char) ?\n)) (not (looking-at " \\|\^I"))) (progn;; Diary entry consists only of the sexp (backward-char 1) ! (setq entry "" color nil)) (setq entry-start (point)) ;; Find end of entry (re-search-forward "\^M\\|\n" nil t) (while (looking-at " \\|\^I") --- 841,849 ---- (char-equal (preceding-char) ?\n)) (not (looking-at " \\|\^I"))) (progn;; Diary entry consists only of the sexp (backward-char 1) ! (setq entry "")) (setq entry-start (point)) ;; Find end of entry (re-search-forward "\^M\\|\n" nil t) (while (looking-at " \\|\^I") *************** *** 903,920 **** (aset entry (match-beginning 0) ?\n ))) (calendar-for-loop date from first-date to last-date do (if (diary-sexp-entry sexp entry (calendar-gregorian-from-absolute date)) ! ;; AMI - find color for this diary entry ! (progn ! (setq color "") ! (save-excursion ! (if (string-match "\\[color:\\([a-z]+\\)\\]$" entry) ! (setq color (substring-no-properties entry ! (match-beginning 1) ! (match-end 1))))) ! (mark-visible-calendar-date ! (calendar-gregorian-from-absolute date) color)))))))) (defun mark-included-diary-files () "Mark the diary entries from other diary files with those of the diary file. This function is suitable for use as the `mark-diary-entries-hook'; it enables --- 857,866 ---- (aset entry (match-beginning 0) ?\n ))) (calendar-for-loop date from first-date to last-date do (if (diary-sexp-entry sexp entry (calendar-gregorian-from-absolute date)) ! (mark-visible-calendar-date ! (calendar-gregorian-from-absolute date)))))))) (defun mark-included-diary-files () "Mark the diary entries from other diary files with those of the diary file. This function is suitable for use as the `mark-diary-entries-hook'; it enables *************** *** 947,955 **** (message "Can't find included diary file %s" diary-file) (sleep-for 2)))) (goto-char (point-min))) ! (defun mark-calendar-days-named (dayname color) "Mark all dates in the calendar window that are day DAYNAME of the week. 0 means all Sundays, 1 means all Mondays, and so on." (save-excursion (set-buffer calendar-buffer) --- 893,901 ---- (message "Can't find included diary file %s" diary-file) (sleep-for 2)))) (goto-char (point-min))) ! (defun mark-calendar-days-named (dayname) "Mark all dates in the calendar window that are day DAYNAME of the week. 0 means all Sundays, 1 means all Mondays, and so on." (save-excursion (set-buffer calendar-buffer) *************** *** 965,989 **** (calendar-nth-named-day 1 dayname prev-month prev-year))) (setq last-day (calendar-absolute-from-gregorian (calendar-nth-named-day -1 dayname succ-month succ-year))) (while (<= day last-day) ! (mark-visible-calendar-date (calendar-gregorian-from-absolute day) color) (setq day (+ day 7)))))) ! (defun mark-calendar-date-pattern (month day year color) "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR. A value of 0 in any position is a wildcard." (save-excursion (set-buffer calendar-buffer) (let ((m displayed-month) (y displayed-year)) (increment-calendar-month m y -1) (calendar-for-loop i from 0 to 2 do ! (mark-calendar-month m y month day year color) (increment-calendar-month m y 1))))) ! ! (defun mark-calendar-month (month year p-month p-day p-year color) "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR. A value of 0 in any position of the pattern is a wildcard." (if (or (and (= month p-month) (or (= p-year 0) (= year p-year))) --- 911,934 ---- (calendar-nth-named-day 1 dayname prev-month prev-year))) (setq last-day (calendar-absolute-from-gregorian (calendar-nth-named-day -1 dayname succ-month succ-year))) (while (<= day last-day) ! (mark-visible-calendar-date (calendar-gregorian-from-absolute day)) (setq day (+ day 7)))))) ! (defun mark-calendar-date-pattern (month day year) "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR. A value of 0 in any position is a wildcard." (save-excursion (set-buffer calendar-buffer) (let ((m displayed-month) (y displayed-year)) (increment-calendar-month m y -1) (calendar-for-loop i from 0 to 2 do ! (mark-calendar-month m y month day year) (increment-calendar-month m y 1))))) ! (defun mark-calendar-month (month year p-month p-day p-year) "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR. A value of 0 in any position of the pattern is a wildcard." (if (or (and (= month p-month) (or (= p-year 0) (= year p-year))) *************** *** 991,1000 **** (or (= p-year 0) (= year p-year)))) (if (= p-day 0) (calendar-for-loop i from 1 to (calendar-last-day-of-month month year) do ! (mark-visible-calendar-date (list month i year) color)) ! (mark-visible-calendar-date (list month p-day year) color)))) (defun sort-diary-entries () "Sort the list of diary entries by time of day." (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) --- 936,945 ---- (or (= p-year 0) (= year p-year)))) (if (= p-day 0) (calendar-for-loop i from 1 to (calendar-last-day-of-month month year) do ! (mark-visible-calendar-date (list month i year))) ! (mark-visible-calendar-date (list month p-day year))))) (defun sort-diary-entries () "Sort the list of diary entries by time of day." (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) *************** *** 1205,1217 **** (sexp-mark (regexp-quote sexp-diary-entry-symbol)) (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "(")) (entry-found)) (goto-char (point-min)) - (save-excursion - (if (re-search-forward "^#[ \t]*\\[color:\\([a-z]+\\)\\]$" (point-max) t) - (setq file-glob-color (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))) (while (re-search-forward s-entry nil t) (backward-char 1) (let ((sexp-start (point)) (sexp) --- 1150,1157 ---- *************** *** 1243,1251 **** (aset entry (match-beginning 0) ?\n ))) (let ((diary-entry (diary-sexp-entry sexp entry date))) (if diary-entry (subst-char-in-region line-start (point) ?\^M ?\n t)) ! (add-to-diary-list date diary-entry specifier file-glob-color) (setq entry-found (or entry-found diary-entry))))) entry-found)) (defun diary-sexp-entry (sexp entry date) --- 1183,1191 ---- (aset entry (match-beginning 0) ?\n ))) (let ((diary-entry (diary-sexp-entry sexp entry date))) (if diary-entry (subst-char-in-region line-start (point) ?\^M ?\n t)) ! (add-to-diary-list date diary-entry specifier) (setq entry-found (or entry-found diary-entry))))) entry-found)) (defun diary-sexp-entry (sexp entry date) *************** *** 1486,1499 **** ((and (listp days) days) (or (diary-remind sexp (car days) marking) (diary-remind sexp (cdr days) marking)))))) ! (defun add-to-diary-list (date string specifier globcolor) ! "Add the entry (DATE STRING SPECIFIER GLOBCOLOR) to `diary-entries-list'. Do nothing if DATE or STRING is nil." (and date string (setq diary-entries-list ! (append diary-entries-list (list (list date string specifier globcolor)))))) (defun make-diary-entry (string &optional nonmarking file) "Insert a diary entry STRING which may be NONMARKING in FILE. If omitted, NONMARKING defaults to nil and FILE defaults to diary-file." --- 1426,1439 ---- ((and (listp days) days) (or (diary-remind sexp (car days) marking) (diary-remind sexp (cdr days) marking)))))) ! (defun add-to-diary-list (date string specifier) ! "Add the entry (DATE STRING SPECIFIER) to `diary-entries-list'. Do nothing if DATE or STRING is nil." (and date string (setq diary-entries-list ! (append diary-entries-list (list (list date string specifier)))))) (defun make-diary-entry (string &optional nonmarking file) "Insert a diary entry STRING which may be NONMARKING in FILE. If omitted, NONMARKING defaults to nil and FILE defaults to diary-file." --=-=-= Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit _______________________________________________ Emacs-devel mailing list Emacs-devel@gnu.org http://mail.gnu.org/mailman/listinfo/emacs-devel --=-=-=--