Mercurial > emacs
changeset 70728:27c11738a0c4
(diary-bahai-date)
(list-bahai-diary-entries, mark-bahai-diary-entries)
(mark-bahai-calendar-date-pattern): Not interactive.
(add-to-diary-list): New optional arg LITERAL. Doc fix.
(diary-entries-list): Change format of 4th element in each entry.
(diary-list-entries): Use add-to-diary-list.
(diary-goto-entry): Handle the case where the buffer visiting the
diary has been killed.
(fancy-diary-display): Add 'locator to button rather than 'marker.
Only generate temp-face when there are marks to apply.
(list-sexp-diary-entries): Pass literal to add-to-diary-list.
(diary-fancy-date-pattern): New variable.
(diary-time-regexp): Doc fix.
(diary-anniversary, diary-time): New faces.
(fancy-diary-font-lock-keywords): Use diary-fancy-date-pattern and
diary-time-regexp. Add font-lock-multiline property where needed.
Use new faces diary-anniversary and diary-time.
(diary-fancy-font-lock-fontify-region-function): New function, to
handle multiline font-lock pattern in fancy diary.
(fancy-diary-display-mode): Set font-lock-fontify-region-function.
(diary-font-lock-keywords): Tweak time regexp. Use new face
diary-time.
| author | Glenn Morris <rgm@gnu.org> |
|---|---|
| date | Fri, 19 May 2006 08:24:51 +0000 |
| parents | 7b9306389285 |
| children | 9a90863c52b1 |
| files | lisp/calendar/diary-lib.el |
| diffstat | 1 files changed, 193 insertions(+), 116 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/calendar/diary-lib.el Fri May 19 08:24:21 2006 +0000 +++ b/lisp/calendar/diary-lib.el Fri May 19 08:24:51 2006 +0000 @@ -121,20 +121,16 @@ "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.") (autoload 'diary-bahai-date "cal-bahai" - "Baha'i calendar equivalent of date diary entry." - t) + "Baha'i calendar equivalent of date diary entry.") (autoload 'list-bahai-diary-entries "cal-bahai" - "Add any Baha'i date entries from the diary file to `diary-entries-list'." - t) + "Add any Baha'i date entries from the diary file to `diary-entries-list'.") (autoload 'mark-bahai-diary-entries "cal-bahai" - "Mark days in the calendar window that have Baha'i date diary entries." - t) + "Mark days in the calendar window that have Baha'i date diary entries.") (autoload 'mark-bahai-calendar-date-pattern "cal-bahai" - "Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR." - t) + "Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR.") (autoload 'diary-hebrew-date "cal-hebrew" "Hebrew calendar equivalent of date diary entry.") @@ -323,6 +319,42 @@ (integer :tag "Saturday"))) :group 'diary) + +(defvar diary-modify-entry-list-string-function nil + "Function applied to entry string before putting it into the entries list. +Can be used by programs integrating a diary list into other buffers (e.g. +org.el and planner.el) to modify the string or add properties to it. +The function takes a string argument and must return a string.") + +(defun add-to-diary-list (date string specifier &optional marker + globcolor literal) + "Add an entry to `diary-entries-list'. +Do nothing if DATE or STRING is nil. DATE is the (MONTH DAY +YEAR) for which the entry applies; STRING is the text of the +entry as it will appear in the diary (i.e. with any format +strings such as \%d\" expanded); SPECIFIER is the date part of +the entry as it appears in the diary-file; LITERAL is the entry +as it appears in the diary-file (i.e. before expansion). If +LITERAL is nil, it is taken to be the same as STRING. + +The entry is added to the list as (DATE STRING SPECIFIER LOCATOR +GLOBCOLOR), where LOCATOR has the form (MARKER FILENAME LITERAL), +FILENAME being the file containing the diary entry." + (when (and date string) + (if diary-file-name-prefix + (let ((prefix (funcall diary-file-name-prefix-function + (buffer-file-name)))) + (or (string= prefix "") + (setq string (format "[%s] %s" prefix string))))) + (and diary-modify-entry-list-string-function + (setq string (funcall diary-modify-entry-list-string-function + string))) + (setq diary-entries-list + (append diary-entries-list + (list (list date string specifier + (list marker (buffer-file-name) literal) + globcolor)))))) + (define-obsolete-function-alias 'list-diary-entries 'diary-list-entries) (defun diary-list-entries (date number &optional list-only) "Create and display a buffer containing the relevant lines in `diary-file'. @@ -468,9 +500,7 @@ (copy-marker entry-start) (nth 1 temp))))))) (or entry-found (not diary-list-include-blanks) - (setq diary-entries-list - (append diary-entries-list - (list (list date "" "" "" ""))))) + (add-to-diary-list date "" "" "" "")) (setq date (calendar-gregorian-from-absolute (1+ (calendar-absolute-from-gregorian date)))) @@ -577,10 +607,27 @@ 'face 'diary-button) (defun diary-goto-entry (button) - (let ((marker (button-get button 'marker))) - (when marker - (pop-to-buffer (marker-buffer marker)) - (goto-char (marker-position marker))))) + (let* ((locator (button-get button 'locator)) + (marker (car locator)) + markbuf file) + ;; If marker pointing to diary location is valid, use that. + (if (and marker (setq markbuf (marker-buffer marker))) + (progn + (pop-to-buffer markbuf) + (goto-char (marker-position marker))) + ;; Marker is invalid (eg buffer has been killed). + (or (and (setq file (cadr locator)) + (file-exists-p file) + (find-file-other-window file) + (progn + (when (eq major-mode default-major-mode) (diary-mode)) + (goto-char (point-min)) + (if (re-search-forward (format "%s.*\\(%s\\)" + (regexp-quote (nth 2 locator)) + (regexp-quote (nth 3 locator))) + nil t) + (goto-char (match-beginning 1))))) + (message "Unable to locate this diary entry"))))) (defun fancy-diary-display () "Prepare a diary buffer with relevant entries in a fancy, noneditable form. @@ -666,37 +713,45 @@ (setq entry (car (cdr (car entry-list)))) (if (< 0 (length entry)) - (progn - (if (nth 3 (car entry-list)) + (let ((this-entry (car entry-list)) + this-loc) + (if (setq this-loc (nth 3 this-entry)) (insert-button (concat entry "\n") - 'marker (nth 3 (car entry-list)) + ;; (MARKER FILENAME SPECIFIER LITERAL) + 'locator (list (car this-loc) + (cadr this-loc) + (nth 2 this-entry) + (or (nth 2 this-loc) + (nth 1 this-entry))) :type 'diary-entry) (insert entry ?\n)) (save-excursion - (let* ((marks (nth 4 (car entry-list))) - (temp-face (make-symbol - (apply - 'concat "temp-face-" - (mapcar (lambda (sym) - (if (stringp sym) - sym - (symbol-name sym))) - marks)))) - (faceinfo marks)) - (make-face temp-face) - ;; Remove :face info from the marks, - ;; copy the face info into temp-face - (while (setq faceinfo (memq :face faceinfo)) - (copy-face (read (nth 1 faceinfo)) temp-face) - (setcar faceinfo nil) - (setcar (cdr faceinfo) nil)) - (setq marks (delq nil marks)) - ;; Apply the font aspects. - (apply 'set-face-attribute temp-face nil marks) - (search-backward entry) - (overlay-put - (make-overlay (match-beginning 0) (match-end 0)) - 'face temp-face))))) + (let* ((marks (nth 4 this-entry)) + (faceinfo marks) + temp-face) + (when marks + (setq temp-face (make-symbol + (apply + 'concat "temp-face-" + (mapcar (lambda (sym) + (if (stringp sym) + sym + (symbol-name sym))) + marks)))) + (make-face temp-face) + ;; Remove :face info from the marks, + ;; copy the face info into temp-face + (while (setq faceinfo (memq :face faceinfo)) + (copy-face (read (nth 1 faceinfo)) temp-face) + (setcar faceinfo nil) + (setcar (cdr faceinfo) nil)) + (setq marks (delq nil marks)) + ;; Apply the font aspects. + (apply 'set-face-attribute temp-face nil marks) + (search-backward entry) + (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)) @@ -1350,7 +1405,7 @@ (setq line-start (point))) (setq specifier (buffer-substring-no-properties (1+ line-start) (point)) - entry-start (1+ line-start)) + entry-start (1+ line-start)) (forward-char 1) (if (and (or (char-equal (preceding-char) ?\^M) (char-equal (preceding-char) ?\n)) @@ -1367,24 +1422,26 @@ (while (string-match "[\^M]" entry) (aset entry (match-beginning 0) ?\n ))) (let ((diary-entry (diary-sexp-entry sexp entry date)) - temp) - (setq entry (if (consp diary-entry) - (cdr diary-entry) - diary-entry)) + temp literal) + (setq literal entry ; before evaluation + entry (if (consp diary-entry) + (cdr diary-entry) + diary-entry)) (if diary-entry - (progn + (progn (remove-overlays line-start (point) 'invisible 'diary) - (if (< 0 (length entry)) - (setq temp (diary-pull-attrs entry file-glob-attrs) - entry (nth 0 temp) - marks (nth 1 temp))))) - (add-to-diary-list date - entry - specifier - (if entry-start (copy-marker entry-start) - nil) - marks) - (setq entry-found (or entry-found diary-entry))))) + (if (< 0 (length entry)) + (setq temp (diary-pull-attrs entry file-glob-attrs) + entry (nth 0 temp) + marks (nth 1 temp))))) + (add-to-diary-list date + entry + specifier + (if entry-start (copy-marker entry-start) + nil) + marks + literal) + (setq entry-found (or entry-found diary-entry))))) entry-found)) (defun diary-sexp-entry (sexp entry date) @@ -1636,28 +1693,6 @@ (or (diary-remind sexp (car days) marking) (diary-remind sexp (cdr days) marking)))))) -(defvar diary-modify-entry-list-string-function nil - "Function applied to entry string before putting it into the entries list. -Can be used by programs integrating a diary list into other buffers (e.g. -org.el and planner.el) to modify the string or add properties to it. -The function takes a string argument and must return a string.") - -(defun add-to-diary-list (date string specifier &optional marker globcolor) - "Add the entry (DATE STRING SPECIFIER MARKER GLOBCOLOR) to `diary-entries-list'. -Do nothing if DATE or STRING is nil." - (when (and date string) - (if diary-file-name-prefix - (let ((prefix (funcall diary-file-name-prefix-function - (buffer-file-name)))) - (or (string= prefix "") - (setq string (format "[%s] %s" prefix string))))) - (and diary-modify-entry-list-string-function - (setq string (funcall diary-modify-entry-list-string-function - string))) - (setq diary-entries-list - (append diary-entries-list - (list (list date string specifier marker globcolor)))))) - (defun diary-redraw-calendar () "If `calendar-buffer' is live and diary entries are marked, redraw it." (and mark-diary-entries-in-calendar @@ -1796,37 +1831,87 @@ (if diary-header-line-flag (setq header-line-format diary-header-line-format))) + +(defvar diary-fancy-date-pattern + (concat + (let ((dayname (diary-name-pattern calendar-day-name-array nil t)) + (monthname (diary-name-pattern calendar-month-name-array nil t)) + (day "[0-9]+") + (month "[0-9]+") + (year "-?[0-9]+")) + (mapconcat 'eval calendar-date-display-form "")) + ;; Optional ": holiday name" after the date. + "\\(: .*\\)?") + "Regular expression matching a date header in Fancy Diary.") + +(defconst diary-time-regexp + ;; Accepted formats: 10:00 10.00 10h00 10h 10am 10:00am 10.00am + ;; Use of "." as a separator annoyingly matches numbers, eg "123.45". + ;; Hence often prefix this with "\\(^\\|\\s-\\)." + (concat "[0-9]?[0-9]\\([AaPp][mM]\\|\\(" + "[Hh]\\([0-9][0-9]\\)?\\|[:.][0-9][0-9]" + "\\)\\([AaPp][Mm]\\)?\\)") + "Regular expression matching a time of day.") + +(defface diary-anniversary '((t :inherit font-lock-keyword-face)) + "Face used for anniversaries in the diary." + :version "22.1" + :group 'diary) + +(defface diary-time '((t :inherit font-lock-variable-name-face)) + "Face used for times of day in the diary." + :version "22.1" + :group 'diary) + +(defvar fancy-diary-font-lock-keywords + (list + (list + ;; Any number of " other holiday name" lines, followed by "==" line. + (concat diary-fancy-date-pattern "\\(\n +.*\\)*\n=+$") + '(0 (progn (put-text-property (match-beginning 0) (match-end 0) + 'font-lock-multiline t) + diary-face))) + '("^.*\\([aA]nniversary\\|[bB]irthday\\).*$" . 'diary-anniversary) + '("^.*Yahrzeit.*$" . font-lock-reference-face) + '("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face) + '("^Day.*omer.*$" . font-lock-builtin-face) + '("^Parashat.*$" . font-lock-comment-face) + `(,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp + diary-time-regexp) . 'diary-time)) + "Keywords to highlight in fancy diary display") + +;; If region looks like it might start or end in the middle of a +;; multiline pattern, extend the region to encompass the whole pattern. +(defun diary-fancy-font-lock-fontify-region-function (beg end &optional verbose) + "Function to use for `font-lock-fontify-region-function' in Fancy Diary. +Needed to handle multiline keyword in `fancy-diary-font-lock-keywords'." + (goto-char beg) + (forward-line 0) + (if (looking-at "=+$") (forward-line -1)) + (while (and (looking-at " +[^ ]") + (zerop (forward-line -1)))) + ;; This check not essential. + (if (looking-at diary-fancy-date-pattern) + (setq beg (line-beginning-position))) + (goto-char end) + (forward-line 0) + (while (and (looking-at " +[^ ]") + (zerop (forward-line 1)))) + (if (looking-at "=+$") + (setq end (line-beginning-position 2))) + (font-lock-default-fontify-region beg end verbose)) + (define-derived-mode fancy-diary-display-mode fundamental-mode "Diary" "Major mode used while displaying diary entries using Fancy Display." (set (make-local-variable 'font-lock-defaults) - '(fancy-diary-font-lock-keywords t)) + '(fancy-diary-font-lock-keywords + t nil nil nil + (font-lock-fontify-region-function + . diary-fancy-font-lock-fontify-region-function))) (local-set-key "q" 'quit-window)) -(defvar fancy-diary-font-lock-keywords - (list - (cons - (concat - (let ((dayname (diary-name-pattern calendar-day-name-array nil t)) - (monthname (diary-name-pattern calendar-month-name-array nil t)) - (day "[0-9]+") - (month "[0-9]+") - (year "-?[0-9]+")) - (mapconcat 'eval calendar-date-display-form "")) - "\\(\\(: .*\\)\\|\\(\n +.*\\)\\)*\n=+$") - 'diary-face) - '("^.*anniversary.*$" . font-lock-keyword-face) - '("^.*birthday.*$" . font-lock-keyword-face) - '("^.*Yahrzeit.*$" . font-lock-reference-face) - '("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face) - '("^Day.*omer.*$" . font-lock-builtin-face) - '("^Parashat.*$" . font-lock-comment-face) - '("^[ \t]*[0-9]?[0-9]\\([:.]?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)?\\(-[0-9]?[0-9]\\([:.]?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)?\\)?" - . font-lock-variable-name-face)) - "Keywords to highlight in fancy diary display") - - (defun diary-font-lock-sexps (limit) "Recognize sexp diary entry for font-locking." (if (re-search-forward @@ -1877,13 +1962,6 @@ (eval-when-compile (require 'cal-hebrew) (require 'cal-islam)) -(defconst diary-time-regexp - ;; Formats that should be accepted: - ;; 10:00 10.00 10h00 10h 10am 10:00am 10.00am - (concat "[0-9]?[0-9]\\([AaPp][mM]\\|\\(" - "[Hh]\\([0-9][0-9]\\)?\\|[:.][0-9][0-9]" - "\\)\\([AaPp][Mm]\\)?\\)")) - (defvar diary-font-lock-keywords (append (diary-font-lock-date-forms calendar-month-name-array @@ -1924,10 +2002,9 @@ "?\\(" (regexp-quote islamic-diary-entry-symbol) "\\)") '(1 font-lock-reference-face)) '(diary-font-lock-sexps . font-lock-keyword-face) - (cons - (concat ;; "^[ \t]+" - diary-time-regexp "\\(-" diary-time-regexp "\\)?") - 'font-lock-function-name-face))) + `(,(concat "\\(^\\|\\s-\\)" + diary-time-regexp "\\(-" diary-time-regexp "\\)?") + . 'diary-time))) "Forms to highlight in `diary-mode'.")