File: calfw-cal.el

package info (click to toggle)
emacs-calfw 1.6%2Bgit20180118-1.1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, bullseye
  • size: 328 kB
  • sloc: lisp: 3,375; sh: 86; makefile: 2
file content (184 lines) | stat: -rw-r--r-- 7,132 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
;;; calfw-cal.el --- calendar view for emacs diary

;; Copyright (C) 2011  SAKURAI Masashi

;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
;; Keywords: calendar

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Display diary items in the calfw buffer.

;; (require 'calfw-cal)
;;
;; M-x cfw:open-diary-calendar

;; Key binding
;; i : insert an entry on the date
;; RET or Click : jump to the entry
;; q : kill-buffer


;; Thanks for furieux's initial code.

;;; Code:

(require 'calfw)
(require 'calendar)

(defvar cfw:cal-diary-regex
  (let ((time   "[[:digit:]]\\{2\\}:[[:digit:]]\\{2\\}")
        (blanks "[[:blank:]]*"))
    (concat "\\(" time "\\)?"
            "\\(?:" blanks "-" blanks "\\(" time "\\)\\)?"
            blanks "\\(.*\\)"))
  "Regex extracting start/end time and title from a diary string")

(defun cfw:cal-entry-to-event (date string)
  "[internal] Add text properties to string, allowing calfw to act on it."
  (let* ((lines      (split-string 
                      (replace-regexp-in-string
                       "[\t ]+" " " (cfw:trim string))
                      "\n"))
         (first      (car lines))
         (desc       (mapconcat 'identity (cdr lines) "\n"))
         (title      (progn
                       (string-match cfw:cal-diary-regex first)
                       (match-string 3 first)))
         (start      (match-string 1 first))
         (end        (match-string 2 first))
         (properties (list 'mouse-face 'highlight
                           'help-echo string
                           'cfw-marker (copy-marker (point-at-bol)))))
    (make-cfw:event :title       (apply 'propertize title properties)
                    :start-date  date
                    :start-time  (when start
                                   (cfw:parse-str-time start))
                    :end-time    (when end
                                   (cfw:parse-str-time end))
                    :description (apply 'propertize desc properties))))

(defun cfw:cal-onclick ()
  "Jump to the clicked diary item."
  (interactive)
  (let ((marker (get-text-property (point) 'cfw-marker)))
    (when (and marker (marker-buffer marker))
      (switch-to-buffer (marker-buffer marker))
      (goto-char (marker-position marker)))))

(defvar cfw:cal-text-keymap
  (let ((map (make-sparse-keymap)))
    (define-key map [mouse-1] 'cfw:cal-onclick)
    (define-key map (kbd "<return>") 'cfw:cal-onclick)
    map)
  "key map on the calendar item text.")

(defun cfw:cal-schedule-period-to-calendar (begin end)
  "[internal] Return calfw calendar items between BEGIN and END
from the diary schedule data."
  (let ((all (diary-list-entries
              begin
              (1+ (cfw:days-diff begin end)) t))
        non-periods
        periods)
    (loop for i in all
          for date = (car i)
          for title = (nth 1 i)
          for date-spec = (nth 2 i)
          for dmarker = (nth 3 i)
          for pspec = (cons date-spec title)
          do
          (if (string-match "%%(diary-block" date-spec)
              (unless (member pspec periods)
                (push pspec periods))
            (push i non-periods)))
    (append
     (loop
      for (date string . rest) in non-periods
      collect (cfw:cal-entry-to-event date string))
     (list (cons 'periods
                 (map 'list (function (lambda (period)
                                        (let ((spec (read (substring (car period) 2))))
                                          (cond
                                           ((eq calendar-date-style 'american)
                                            (list
                                             (list (nth 1 spec)
                                                   (nth 2 spec)
                                                   (nth 3 spec))
                                             (list (nth 4 spec)
                                                   (nth 5 spec)
                                                   (nth 6 spec))
                                             (cdr period)))
                                           ((eq calendar-date-style 'european)
                                            (list
                                             (list (nth 2 spec)
                                                   (nth 1 spec)
                                                   (nth 3 spec))
                                             (list (nth 5 spec)
                                                   (nth 4 spec)
                                                   (nth 6 spec))
                                             (cdr period)))
                                           ((eq calendar-date-style 'iso)
                                            (list
                                             (list (nth 2 spec)
                                                   (nth 3 spec)
                                                   (nth 1 spec))
                                             (list (nth 5 spec)
                                                   (nth 6 spec)
                                                   (nth 4 spec))
                                             (cdr period)))))))
                      periods))))))

(defvar cfw:cal-schedule-map
  (cfw:define-keymap
   '(
     ("q" . kill-buffer)
     ("i" . cfw:cal-from-calendar)
     ))
  "Key map for the calendar buffer.")

(defun cfw:cal-create-source (&optional color)
  "Create diary calendar source."
  (make-cfw:source
   :name "calendar diary"
   :color (or color "SaddleBrown")
   :data 'cfw:cal-schedule-period-to-calendar))

(defun cfw:open-diary-calendar ()
  "Open the diary schedule calendar in the new buffer."
  (interactive)
  (save-excursion
    (let* ((source1 (cfw:cal-create-source))
           (cp (cfw:create-calendar-component-buffer
                :view 'month
                :custom-map cfw:cal-schedule-map
                :contents-sources (list source1))))
      (switch-to-buffer (cfw:cp-get-buffer cp)))))

(defun cfw:cal-from-calendar ()
  "Insert a new item. This command should be executed on the calfw calendar."
  (interactive)
  (let* ((mdy (cfw:cursor-to-nearest-date))
         (m (calendar-extract-month mdy))
         (d (calendar-extract-day   mdy))
         (y (calendar-extract-year  mdy)))
    (diary-make-entry (calendar-date-string (cfw:date m d y) t t))
    ))

;; (progn (eval-current-buffer) (cfw:open-diary-calendar))

(provide 'calfw-cal)
;;; calfw-cal.el ends here