From 76339d39d8ebda2289384189e255ab7cc0c27516 Mon Sep 17 00:00:00 2001 From: SAKURAI Masashi Date: Tue, 2 Feb 2021 14:09:05 +0900 Subject: [PATCH 1/4] Apply cl-libify and fix some lexical lets and dynamic variables --- calfw.el | 312 ++++++++++++++++++++++++++++--------------------------- 1 file changed, 158 insertions(+), 154 deletions(-) diff --git a/calfw.el b/calfw.el index a5c8bbf..940db5a 100644 --- a/calfw.el +++ b/calfw.el @@ -1,9 +1,9 @@ -;;; calfw.el --- Calendar view framework on Emacs +;;; calfw.el --- Calendar view framework on Emacs -*- lexical-binding: t -*- -;; Copyright (C) 2011,2012,2013,2014,2015 SAKURAI Masashi +;; Copyright (C) 2011-2021 SAKURAI Masashi ;; Author: SAKURAI Masashi -;; Version: 1.6 +;; Version: 1.7 ;; Keywords: calendar ;; URL: https://github.com/kiwanami/emacs-calfw @@ -53,7 +53,7 @@ ;;; Code: -(require 'cl) +(require 'cl-lib) (require 'calendar) (require 'holidays) (require 'format-spec) @@ -344,29 +344,29 @@ for example `cfw:read-date-command-simple' or `cfw:org-read-date-command'." (defun cfw:extract-text-props (text &rest excludes) "[internal] Return text properties." - (loop with ret = nil - with props = (text-properties-at 0 text) - for name = (car props) - for val = (cadr props) - while props - do - (when (and name (not (memq name excludes))) - (setq ret (cons name (cons val ret)))) - (setq props (cddr props)) - finally return ret)) + (cl-loop with ret = nil + with props = (text-properties-at 0 text) + for name = (car props) + for val = (cadr props) + while props + do + (when (and name (not (memq name excludes))) + (setq ret (cons name (cons val ret)))) + (setq props (cddr props)) + finally return ret)) (defun cfw:define-keymap (keymap-list) "[internal] Key map definition utility. KEYMAP-LIST is a source list like ((key . command) ... )." - (let ((map (make-sparse-keymap))) + (let ((new-key-map (make-sparse-keymap))) (mapc (lambda (i) - (define-key map + (define-key new-key-map (if (stringp (car i)) (read-kbd-macro (car i)) (car i)) (cdr i))) keymap-list) - map)) + new-key-map)) (defun cfw:trim (str) "[internal] Trim the space char-actors." @@ -375,12 +375,12 @@ KEYMAP-LIST is a source list like ((key . command) ... )." str)) (defun cfw:flatten (lst &optional revp) - (loop with ret = nil - for i in lst - do (setq ret (if (consp i) - (nconc (cfw:flatten i t) ret) - (cons i ret))) - finally return (if revp ret (nreverse ret)))) + (cl-loop with ret = nil + for i in lst + do (setq ret (if (consp i) + (nconc (cfw:flatten i t) ret) + (cons i ret))) + finally return (if revp ret (nreverse ret)))) @@ -392,7 +392,7 @@ KEYMAP-LIST is a source list like ((key . command) ... )." (list month day year))) (defun cfw:time (hours minutes) - "Construct a date object in the calendar format." + "Construct a time object (local time) in the calendar format." (and hours minutes (list hours minutes))) @@ -418,7 +418,8 @@ ones of DATE2. Otherwise is `nil'." (calendar-extract-year date2)))) (defun cfw:date-less-equal-p (d1 d2) - "Return `t' if date value D1 is less than or equals to date value D2." + "Return `t' if date value D1 is less than or equals to date value D2. + i.e. (D1 <= D2) ? t : nil. " (let ((ed1 (cfw:calendar-to-emacs d1)) (ed2 (cfw:calendar-to-emacs d2))) (or (equal ed1 ed2) @@ -527,8 +528,8 @@ ones of DATE2. Otherwise is `nil'." ;; selectoin-change-hooks : a list of hook functions for selection change event ;; click-hooks : a list of hook functions for click event -(defstruct cfw:component dest model selected view - update-hooks selection-change-hooks click-hooks) +(cl-defstruct cfw:component dest model selected view + update-hooks selection-change-hooks click-hooks) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Data Source @@ -548,7 +549,7 @@ ones of DATE2. Otherwise is `nil'." ;; If `period-bgcolor' is nil, the value of `color' is used. ;; If `period-fgcolor' is nil, the black or white (negative color of `period-bgcolor') is used. -(defstruct cfw:source name data update color period-bgcolor period-fgcolor opt-face opt-period-face) +(cl-defstruct cfw:source name data update color period-bgcolor period-fgcolor opt-face opt-period-face) (defun cfw:source-period-bgcolor-get (source) "[internal] Return a background color for period items. @@ -565,9 +566,9 @@ If `cfw:source-period-bgcolor' is nil, the value of If `cfw:source-period-fgcolor' is nil, the black or white (negative color of `cfw:source-period-bgcolor') is used." (or (cfw:source-period-fgcolor source) - (let ((c (destructuring-bind - (r g b) (color-values (or (cfw:source-period-bgcolor-get source) "black")) - (if (< 147500 (+ r g b)) "black" "white")))) ; (* 65536 3 0.75) + (let ((c (cl-destructuring-bind + (r g b) (color-values (or (cfw:source-period-bgcolor-get source) "black")) + (if (< 147500 (+ r g b)) "black" "white")))) ; (* 65536 3 0.75) (setf (cfw:source-period-fgcolor source) c) c))) @@ -575,7 +576,7 @@ white (negative color of `cfw:source-period-bgcolor') is used." ;;; Calendar event ;; This structure defines calendar events. -(defstruct cfw:event +(cl-defstruct cfw:event title ; event title [string] start-date ; start date of the event [cfw:date] start-time ; start time of the event (optional) @@ -677,7 +678,7 @@ The following values are possible: ;; select-ol : a list of overlays for selection ;; today-ol : a list of overlays for today -(defstruct cfw:dest +(cl-defstruct cfw:dest type buffer min-func max-func width height clear-func before-update-func after-update-func select-ol today-ol) @@ -715,8 +716,8 @@ The following values are possible: (defun cfw:dest-ol-selection-clear (dest) "[internal] Clear the selection overlays on the current calendar view." - (loop for i in (cfw:dest-select-ol dest) - do (delete-overlay i)) + (cl-loop for i in (cfw:dest-select-ol dest) + do (delete-overlay i)) (setf (cfw:dest-select-ol dest) nil)) (defun cfw:dest-ol-selection-set (dest date) @@ -724,39 +725,39 @@ The following values are possible: put on some days, calling this function many times. If DATE is not included on the current calendar view, do nothing. This function does not manage the selections, just put the overlay." - (lexical-let (ols) - (cfw:dest-with-region dest - (cfw:find-all-by-date - dest date - (lambda (begin end) - (let ((overlay (make-overlay begin end))) - (overlay-put overlay 'face - (if (eq 'cfw:face-day-title - (get-text-property begin 'face)) - 'cfw:face-select)) - (push overlay ols))))) - (setf (cfw:dest-select-ol dest) ols))) + (let (ols) + (cfw:dest-with-region dest + (cfw:find-all-by-date + dest date + (lambda (begin end) + (let ((overlay (make-overlay begin end))) + (overlay-put overlay 'face + (if (eq 'cfw:face-day-title + (get-text-property begin 'face)) + 'cfw:face-select)) + (push overlay ols))))) + (setf (cfw:dest-select-ol dest) ols))) (defun cfw:dest-ol-today-clear (dest) "[internal] Clear decoration overlays." - (loop for i in (cfw:dest-today-ol dest) - do (delete-overlay i)) + (cl-loop for i in (cfw:dest-today-ol dest) + do (delete-overlay i)) (setf (cfw:dest-today-ol dest) nil)) (defun cfw:dest-ol-today-set (dest) "[internal] Put a highlight face on today." - (lexical-let (ols) - (cfw:dest-with-region dest - (cfw:find-all-by-date - dest (calendar-current-date) - (lambda (begin end) - (let ((overlay (make-overlay begin end))) - (overlay-put overlay 'face - (if (eq 'cfw:face-day-title - (get-text-property begin 'face)) - 'cfw:face-today-title 'cfw:face-today)) - (push overlay ols))))) - (setf (cfw:dest-today-ol dest) ols))) + (let (ols) + (cfw:dest-with-region dest + (cfw:find-all-by-date + dest (calendar-current-date) + (lambda (begin end) + (let ((overlay (make-overlay begin end))) + (overlay-put overlay 'face + (if (eq 'cfw:face-day-title + (get-text-property begin 'face)) + 'cfw:face-today-title 'cfw:face-today)) + (push overlay ols))))) + (setf (cfw:dest-today-ol dest) ols))) @@ -779,7 +780,7 @@ shows BUF or the selected window. The component object is stored at the buffer local variable `cfw:component'. CUSTOM-MAP is the additional keymap that is added to default keymap `cfw:calendar-mode-map'." - (lexical-let + (let ((buffer (or buf (get-buffer-create cfw:calendar-buffer-name))) (window (or (and buf (get-buffer-window buf)) (selected-window))) dest) @@ -809,7 +810,7 @@ space. This destination is employed to be embedded in the some application buffer. Because this destination does not set up any modes and key maps for the buffer, the application that uses the calfw is responsible to manage the buffer and key maps." - (lexical-let + (let ((mark-begin mark-begin) (mark-end mark-end) (window (or (get-buffer-window buf) (selected-window)))) (make-cfw:dest @@ -837,7 +838,7 @@ the calfw is responsible to manage the buffer and key maps." (defun cfw:dest-init-inline (width height) "Create a text destination." - (lexical-let + (let ((buffer (get-buffer-create cfw:dest-background-buffer)) (window (selected-window)) dest) @@ -1036,21 +1037,21 @@ VIEW is a symbol of the view type." (defun cfw:cp-fire-click-hooks (component) "[internal] Call click hook functions of the component with no arguments." - (loop for f in (cfw:component-click-hooks component) + (cl-loop for f in (cfw:component-click-hooks component) do (condition-case err (funcall f) (nil (message "Calfw: Click / Hook error %S [%s]" f err))))) (defun cfw:cp-fire-selection-change-hooks (component) "[internal] Call selection change hook functions of the component with no arguments." - (loop for f in (cfw:component-selection-change-hooks component) + (cl-loop for f in (cfw:component-selection-change-hooks component) do (condition-case err (funcall f) (nil (message "Calfw: Selection change / Hook error %S [%s]" f err))))) (defun cfw:cp-fire-update-hooks (component) "[internal] Call update hook functions of the component with no arguments." - (loop for f in (cfw:component-update-hooks component) + (cl-loop for f in (cfw:component-update-hooks component) do (condition-case err (funcall f) (nil (message "Calfw: Update / Hook error %S [%s]" f err))))) @@ -1105,7 +1106,7 @@ ORG-MODEL is a model object to inherit." (defun cfw:model-get-periods-by-date (date model) "Return a list of periods on the DATE." - (loop for (begin end event) in (cfw:k 'periods model) + (cl-loop for (begin end event) in (cfw:k 'periods model) for content = (if (cfw:event-p event) (cfw:event-detail event) event) @@ -1160,7 +1161,7 @@ display period of the calendar." One can modify the returned cons cell destructively." (cond ((or (null date) (null contents)) nil) - (t (loop for i in contents + (t (cl-loop for i in contents if (equal date (car i)) return i finally return nil)))) @@ -1183,19 +1184,19 @@ calling functions `:data' function." (cond ((null sources) nil) (t - (loop for s in sources + (cl-loop for s in sources for f = (cfw:source-data s) for cnts = (cfw:contents-put-source (funcall f begin end) s) with contents = nil do - (loop for c in cnts + (cl-loop for c in cnts for (d . line) = c do (setq contents (cfw:contents-add d line contents))) finally return contents)))) (defun cfw:periods-put-source (periods source) - (loop for period in periods + (cl-loop for period in periods collect (cond ((cfw:event-p period) @@ -1204,7 +1205,7 @@ calling functions `:data' function." ,(cfw:event-end-date period) ,period)) (t - (destructuring-bind (begin end . summaries) period + (cl-destructuring-bind (begin end . summaries) period (list begin end (cfw:tp (if (listp summaries) (mapconcat 'identity (cfw:flatten summaries) " ") @@ -1218,7 +1219,7 @@ object is used to put some face property." (cond ((null source) contents) (t - (loop for content in contents + (cl-loop for content in contents collect (cond ((cfw:event-p content) @@ -1229,7 +1230,7 @@ object is used to put some face property." (cfw:periods-put-source (cdr content) source))) (t (cons (car content) - (loop for i in (cdr content) + (cl-loop for i in (cdr content) collect (cfw:tp i 'cfw:source source))))))))) (defun cfw:annotations-merge (begin end sources) @@ -1240,12 +1241,12 @@ calling functions `cfw:annotations-functions'." ((= 1 (length sources)) (funcall (cfw:source-data (car sources)) begin end)) (t - (loop for s in sources + (cl-loop for s in sources for f = (cfw:source-data s) for cnts = (funcall f begin end) with annotations = nil do - (loop for c in cnts + (cl-loop for c in cnts for (d . line) = c for prv = (cfw:contents-get-internal d annotations) if prv @@ -1326,7 +1327,7 @@ sides with the character PADDING." ((symbolp last-face) (let ((attrs (face-all-attributes last-face (selected-frame)))) (setq attrs ; transform alist to plist - (loop with nattrs = nil + (cl-loop with nattrs = nil for (n . v) in (append attrs `((:underline . ,cfw:face-item-separator-color))) do (setq nattrs (cons n (cons v nattrs))) finally return nattrs)) @@ -1386,7 +1387,7 @@ sides with the character PADDING." (defun cfw:render-default-content-face (str &optional default-face) "[internal] Put the default content face. If STR has some faces, the faces are remained." - (loop for i from 0 below (length str) + (cl-loop for i from 0 below (length str) with ret = (substring str 0) with face = (or default-face (cfw:render-get-face-content @@ -1486,7 +1487,7 @@ PREV-CMD and NEXT-CMD are the moving view command, such as `cfw:navi-previous(ne (let* ((whole-text (mapconcat 'identity - (loop for s in sources + (cl-loop for s in sources for title = (cfw:tp (substring (cfw:source-name s) 0) 'cfw:source s) for dot = (cfw:tp (substring "(==)" 0) 'cfw:source s) @@ -1502,7 +1503,7 @@ PREV-CMD and NEXT-CMD are the moving view command, such as `cfw:navi-previous(ne (defun cfw:render-periods (date week-day periods-stack cell-width) "[internal] This function translates PERIOD-STACK to display content on the DATE." - (loop with prev-row = -1 + (cl-loop with prev-row = -1 for (row (begin end content props)) in (sort periods-stack (lambda (a b) (< (car a) (car b)))) @@ -1511,20 +1512,20 @@ PREV-CMD and NEXT-CMD are the moving view command, such as `cfw:navi-previous(ne for beginp = (equal date begin) for endp = (equal date end) - for width = (- cell-width (if beginp 1 0) (if endp 1 0)) + for inwidth = (- cell-width (if beginp 1 0) (if endp 1 0)) for title = (cfw:render-periods-title - date week-day begin end content cell-width) + date week-day begin end content cell-width inwidth) collect (apply 'propertize (concat (when beginp cfw:fstring-period-start) - (cfw:render-left width title ?-) + (cfw:render-left inwidth title ?-) (when endp cfw:fstring-period-end)) 'face (cfw:render-get-face-period content 'cfw:face-periods) 'font-lock-face (cfw:render-get-face-period content 'cfw:face-periods) 'cfw:period t props))) -(defun cfw:render-periods-title (date week-day begin end content cell-width) +(defun cfw:render-periods-title (date week-day begin end content cell-width inwidth) "[internal] Return a title string." (let* ((week-begin (cfw:date-after date (- week-day))) (month-begin (cfw:date @@ -1537,7 +1538,7 @@ PREV-CMD and NEXT-CMD are the moving view command, such as `cfw:navi-previous(ne (title-begin (calendar-gregorian-from-absolute title-begin-abs)) (num (- (calendar-absolute-from-gregorian date) title-begin-abs))) (when content - (loop with title = (substring content 0) + (cl-loop with title = (substring content 0) for i from 0 below num for pdate = (calendar-gregorian-from-absolute (+ title-begin-abs i)) for chopn = (+ (if (equal begin pdate) 1 0) (if (equal end pdate) 1 0)) @@ -1545,15 +1546,15 @@ PREV-CMD and NEXT-CMD are the moving view command, such as `cfw:navi-previous(ne do (setq title (substring title (length del))) finally return - (cfw:render-truncate title width (equal end date)))))) + (cfw:render-truncate title inwidth (equal end date)))))) ;; event periods shifts pos - not one line (defun cfw:render-periods-get-min (periods-each-days begin end) "[internal] Find the minimum empty row number of the days between BEGIN and END from the PERIODS-EACH-DAYS." - (loop for row-num from 0 below 30 ; assuming the number of stacked periods is less than 30 + (cl-loop for row-num from 0 below 30 ; assuming the number of stacked periods is less than 30 unless - (loop for d in (cfw:enumerate-days begin end) + (cl-loop for d in (cfw:enumerate-days begin end) for periods-stack = (cfw:contents-get d periods-each-days) if (and periods-stack (assq row-num periods-stack)) return t) @@ -1562,7 +1563,7 @@ BEGIN and END from the PERIODS-EACH-DAYS." (defun cfw:render-periods-place (periods-each-days row period) "[internal] Assign PERIOD content to the ROW-th row on the days of the period, and append the result to periods-each-days." - (loop for d in (cfw:enumerate-days (car period) (cadr period)) + (cl-loop for d in (cfw:enumerate-days (car period) (cadr period)) for periods-stack = (cfw:contents-get-internal d periods-each-days) if periods-stack do (setcdr periods-stack (append (cdr periods-stack) @@ -1576,7 +1577,7 @@ and append the result to periods-each-days." create period-stacks on the each days. period-stack -> ((row-num . period) ... )" (let* (periods-each-days) - (loop for (begin end event) in (cfw:k 'periods model) + (cl-loop for (begin end event) in (cfw:k 'periods model) for content = (if (cfw:event-p event) (cfw:event-period-overview event) event) @@ -1596,7 +1597,7 @@ DAY-COLUMNS is a list of columns. A column is a list of following form: (DATE (D (EOL (cfw:k 'eol param)) (VL (cfw:k 'vl param)) (hline (cfw:k 'hline param)) (cline (cfw:k 'cline param))) ;; day title - (loop for day-rows in day-columns + (cl-loop for day-rows in day-columns for date = (car day-rows) for (tday . ant) = (cadr day-rows) do @@ -1610,14 +1611,14 @@ DAY-COLUMNS is a list of columns. A column is a list of following form: (DATE (D (cfw:render-left cell-width "")))) (insert VL EOL) ;; day contents - (loop with breaked-day-columns = - (loop for day-rows in day-columns + (cl-loop with breaked-day-columns = + (cl-loop for day-rows in day-columns for (date ants . lines) = day-rows collect (cons date (cfw:render-break-lines lines cell-width (1- cell-height)))) for i from 1 below cell-height do - (loop for day-rows in breaked-day-columns + (cl-loop for day-rows in breaked-day-columns for date = (car day-rows) for row = (nth i day-rows) do @@ -1646,7 +1647,7 @@ algorithm defined at `cfw:render-line-breaker'." (cond ((> 2 num) lines) (t - (loop with total-rows = nil + (cl-loop with total-rows = nil for line in lines for rows = (funcall cfw:render-line-breaker line cell-width num) do @@ -1669,7 +1670,7 @@ algorithm defined at `cfw:render-line-breaker'." (defun cfw:render-line-breaker-simple (string line-width max-line-num) "Line breaking algorithm: Just splitting a line with the rigid width." - (loop with ret = nil with linenum = 1 + (cl-loop with ret = nil with linenum = 1 with curcol = 0 with lastpos = 0 with endpos = (1- (length string)) for i from 0 upto endpos @@ -1687,16 +1688,16 @@ algorithm defined at `cfw:render-line-breaker'." ((or (= c 13) (= c 10)) (push (substring string lastpos i) ret) (setq lastpos (1+ i) curcol 0) - (incf linenum)) + (cl-incf linenum)) ((= line-width wsum) (push (substring string lastpos (1+ i)) ret) (setq lastpos (1+ i) curcol 0) - (incf linenum)) + (cl-incf linenum)) ((< line-width wsum) (push (substring string lastpos i) ret) (setq lastpos i curcol w) - (incf linenum)) - (t (incf curcol w))) + (cl-incf linenum)) + (t (cl-incf curcol w))) finally return (or (and ret (nreverse ret)) '("")))) (defun cfw:render-line-breaker-wordwrap (string line-width max-line-num) @@ -1735,7 +1736,7 @@ algorithm defined at `cfw:render-line-breaker'." `((eol . ,EOL) (vl . ,(cfw:rt (make-string 1 cfw:fchar-vertical-line) 'cfw:face-grid)) (hline . ,(cfw:rt (concat - (loop for i from 0 below columns concat + (cl-loop for i from 0 below columns concat (concat (make-string 1 (if (= i 0) cfw:fchar-top-left-corner cfw:fchar-top-junction)) (make-string num-cell-char cfw:fchar-horizontal-line))) @@ -1743,7 +1744,7 @@ algorithm defined at `cfw:render-line-breaker'." 'cfw:face-grid)) (cline . ,(cfw:rt (concat - (loop for i from 0 below columns concat + (cl-loop for i from 0 below columns concat (concat (make-string 1 (if (= i 0) cfw:fchar-left-junction cfw:fchar-junction)) (make-string num-cell-char cfw:fchar-horizontal-line))) @@ -1751,7 +1752,7 @@ algorithm defined at `cfw:render-line-breaker'." (defun cfw:render-day-of-week-names (model param) "[internal] Insert week names." - (loop for i in (cfw:k 'headers model) + (cl-loop for i in (cfw:k 'headers model) with VL = (cfw:k 'vl param) with cell-width = (cfw:k 'cell-width param) for name = (aref calendar-day-name-array i) do (insert VL (cfw:rt (cfw:render-center cell-width name) @@ -1759,19 +1760,19 @@ algorithm defined at `cfw:render-line-breaker'." (defun cfw:render-calendar-cells-weeks (model param title-func) "[internal] Insert calendar cells for week based views." - (loop for week in (cfw:k 'weeks model) do + (cl-loop for week in (cfw:k 'weeks model) do (cfw:render-calendar-cells-days model param title-func week 'cfw:render-event-overview-content t))) (defun cfw:render-rows-prop (rows) "[internal] Put a marker as a text property for TAB navigation." - (loop with i = 0 + (cl-loop with i = 0 for line in rows collect (prog1 (cfw:tp line 'cfw:row-count i) - (if (< 0 (length line)) (incf i))))) + (if (< 0 (length line)) (cl-incf i))))) (defun cfw:render-map-event-content (lst event-fun) "[internal] `lst' is a list of contents and `cfw:event's. Map over `lst', @@ -1804,7 +1805,7 @@ where `event-fun' is applied if the element is a `cfw:event'." (defun cfw:view-model-make-weeks (begin-date end-date) "[internal] Return a list of weeks those have 7 days." (let* ((first-day-day (calendar-day-of-week begin-date)) weeks) - (loop with i = begin-date + (cl-loop with i = begin-date with day = calendar-week-start-day with week = nil do @@ -1812,7 +1813,7 @@ where `event-fun' is applied if the element is a `cfw:event'." (when (and (= day calendar-week-start-day) week) (push (nreverse week) weeks) (setq week nil) - (when (cfw:date-less-equal-p end-date i) (return))) + (when (cfw:date-less-equal-p end-date i) (cl-return))) ;; add a day (push i week) ;; increment @@ -1822,31 +1823,34 @@ where `event-fun' is applied if the element is a `cfw:event'." (defun cfw:view-model-make-days (begin-date end-date) "[internal] Return a list of days for linear views." - (loop with days = nil + (cl-loop with days = nil with i = begin-date do (push i days) (when (cfw:date-less-equal-p end-date i) - (return (reverse days))) + (cl-return (reverse days))) (setq i (cfw:date-after i 1)))) (defun cfw:view-model-make-day-names-for-week () "[internal] Return a list of index of day of the week." - (loop for i from 0 below cfw:week-days + (cl-loop for i from 0 below cfw:week-days collect (% (+ calendar-week-start-day i) cfw:week-days))) (defun cfw:view-model-make-day-names-for-days (begin-date end-date) "[internal] Return a list of index of day of the week for linear views." - (loop with day = (calendar-day-of-week begin-date) + (cl-loop with day = (calendar-day-of-week begin-date) with day-names = nil with i = begin-date do (push day day-names) (when (cfw:date-less-equal-p end-date i) - (return (reverse day-names))) + (cl-return (reverse day-names))) (setq day (% (1+ day) cfw:week-days)) (setq i (cfw:date-after i 1)))) +(defvar displayed-month) ; because these variables are binded dynamically. +(defvar displayed-year) + (defun cfw:view-model-make-holidays (date) "[internal] Return an alist of holidays around DATE." (if cfw:display-calendar-holidays @@ -1866,7 +1870,7 @@ where `event-fun' is applied if the element is a `cfw:event'." (annotations . ,(cfw:annotations-merge ; an alist of annotations, (DATE ANNOTATION) begin-date end-date (cfw:model-get-annotation-sources model))) - (contents . ,(loop for i in contents-all + (contents . ,(cl-loop for i in contents-all unless (eq 'periods (car i)) collect i)) ; an alist of contents, (DATE LIST-OF-CONTENTS) (periods . ,(cfw:k 'periods contents-all))) ; a list of periods, (BEGIN-DATE END-DATE SUMMARY) @@ -2190,7 +2194,7 @@ return an alist of rendering parameters." days content-fun do-weeks) "[internal] Insert calendar cells for the linear views." (cfw:render-columns - (loop with cell-width = (cfw:k 'cell-width param) + (cl-loop with cell-width = (cfw:k 'cell-width param) with days = (or days (cfw:k 'days model)) with content-fun = (or content-fun 'cfw:render-event-days-overview-content) @@ -2238,7 +2242,7 @@ return an alist of rendering parameters." (when periods-stack (let ((stack (sort (copy-sequence periods-stack) (lambda (a b) (< (car a) (car b)))))) - (loop for (row (begin end content)) in stack + (cl-loop for (row (begin end content)) in stack for beginp = (equal date begin) for endp = (equal date end) for width = (- cell-width 2) @@ -2286,7 +2290,7 @@ function may return nil." (if (null cmds) (cfw:cursor-to-date) (ignore-errors (funcall (car cmds)) (funcall get (cdr cmds))))))) - (or (loop for i in `((,d) (,r) (,u) (,l) + (or (cl-loop for i in `((,d) (,r) (,u) (,l) (,d ,r) (,d ,l) (,u ,r) (,u ,l) (,d ,d) (,r ,r) (,u ,u) (,l ,l)) for date = (funcall get i) @@ -2312,13 +2316,13 @@ function may return nil." "[internal] Return a point where the text property `cfw:date' is equal to DATE in the current calender view. If DATE is not found in the current view, return nil." - (loop with pos = (cfw:dest-point-min dest) + (cl-loop with pos = (cfw:dest-point-min dest) with end = (cfw:dest-point-max dest) for next = (next-single-property-change pos 'cfw:date nil end) for text-date = (and next (cfw:cursor-to-date next)) while (and next (< next end)) do (if (and text-date (equal date text-date)) - (return next)) + (cl-return next)) (setq pos next))) (defun cfw:find-all-by-date (dest date func) @@ -2326,7 +2330,7 @@ found in the current view, return nil." text-property `cfw:date' is equal to DATE. The argument function FUNC receives two arguments, begin position and end one. This function is mainly used at functions for putting overlays." - (loop with pos = (cfw:dest-point-min dest) + (cl-loop with pos = (cfw:dest-point-min dest) with end = (cfw:dest-point-max dest) for next = (next-single-property-change pos 'cfw:date nil end) for text-date = (and next (cfw:cursor-to-date next)) @@ -2341,7 +2345,7 @@ mainly used at functions for putting overlays." "[internal] Find the schedule item which has the text properties as `cfw:date' = DATE and `cfw:row-count' = ROW-COUNT. If no item is found, this function returns nil." - (loop with pos = (cfw:dest-point-min dest) + (cl-loop with pos = (cfw:dest-point-min dest) with end = (cfw:dest-point-max dest) with last-found = nil for next = (next-single-property-change pos 'cfw:date nil end) @@ -2351,14 +2355,14 @@ this function returns nil." (when (and text-date (equal date text-date) (eql row-count text-row-count)) ;; this is needed item - (return next)) + (cl-return next)) (when (and text-date (equal date text-date) text-row-count) ;; keep it to search bottom item (setq last-found next)) (setq pos next) finally (if (and last-found (< row-count 0)) - (return last-found)))) + (cl-return last-found)))) (defun cfw:navi-goto-date (date) "Move the cursor to DATE and put selection. If DATE is not @@ -2489,9 +2493,9 @@ calendar view." (interactive) (let ((cp (cfw:cp-get-component)) (date (cfw:cursor-to-date)) - (count (or (get-text-property (point) 'cfw:row-count) -1))) + (rcount (or (get-text-property (point) 'cfw:row-count) -1))) (when (and cp date) - (let ((next (cfw:find-item (cfw:component-dest cp) date (1+ count)))) + (let ((next (cfw:find-item (cfw:component-dest cp) date (1+ rcount)))) (if next (goto-char next) (cfw:navi-goto-date date)))))) @@ -2500,9 +2504,9 @@ calendar view." (interactive) (let ((cp (cfw:cp-get-component)) (date (cfw:cursor-to-date)) - (count (or (get-text-property (point) 'cfw:row-count) -1))) + (rcount (or (get-text-property (point) 'cfw:row-count) -1))) (when (and cp date) - (let ((next (cfw:find-item (cfw:component-dest cp) date (1- count)))) + (let ((next (cfw:find-item (cfw:component-dest cp) date (1- rcount)))) (if next (goto-char next) (cfw:navi-goto-date date)))))) @@ -2523,10 +2527,10 @@ With prefix arg NO-RESIZE, don't fit calendar to window size." (when cp (unless no-resize (cfw:cp-resize cp (window-width) (window-height))) - (loop for s in (cfw:cp-get-contents-sources cp) + (cl-loop for s in (cfw:cp-get-contents-sources cp) for f = (cfw:source-update s) if f do (funcall f)) - (loop for s in (cfw:cp-get-annotation-sources cp) + (cl-loop for s in (cfw:cp-get-annotation-sources cp) for f = (cfw:source-update s) if f do (funcall f)) (cfw:cp-update cp)))) @@ -2682,21 +2686,21 @@ DATE is a date to show. MODEL is model object." (and annotation (cfw:rt annotation 'cfw:face-annotation)) EOL)) HLINE - (loop for (begin end summary) in periods + (cl-loop for (begin end summary) in periods for prefix = (propertize (concat (cfw:strtime begin) " - " (cfw:strtime end) " : ") 'face (cfw:render-get-face-period summary 'cfw:face-periods) 'font-lock-face (cfw:render-get-face-period summary 'cfw:face-periods) - 'cfw:row-count (incf row-count)) + 'cfw:row-count (cl-incf row-count)) concat (concat prefix " " summary EOL)) - (loop for i in contents + (cl-loop for i in contents for f = (cfw:render-get-face-content i 'cfw:face-default-content) concat (concat "- " (propertize i 'face f 'font-lock-face f - 'cfw:row-count (incf row-count)) + 'cfw:row-count (cl-incf row-count)) EOL))))) (defvar cfw:details-mode-map @@ -2758,34 +2762,34 @@ DATE is a date to show. MODEL is model object." (defun cfw:details-navi-next-item-command () (interactive) - (let* ((count (or (get-text-property (point) 'cfw:row-count) -1)) - (next (cfw:details-find-item (1+ count)))) - (goto-char (or next (point-min))))) + (let* ((rcount (or (get-text-property (point) 'cfw:row-count) -1)) + (next-pos (cfw:details-find-item (1+ rcount)))) + (goto-char (or next-pos (point-min))))) (defun cfw:details-navi-prev-item-command () (interactive) - (let* ((count (or (get-text-property (point) 'cfw:row-count) -1)) - (next (cfw:details-find-item (1- count)))) - (goto-char (or next (point-min))))) + (let* ((rcount (or (get-text-property (point) 'cfw:row-count) -1)) + (next-pos (cfw:details-find-item (1- rcount)))) + (goto-char (or next-pos (point-min))))) (defun cfw:details-find-item (row-count) "[internal] Find the schedule item which has the text properties as `cfw:row-count' = ROW-COUNT. If no item is found, this function returns nil." - (loop with pos = (point-min) - for next = (next-single-property-change pos 'cfw:row-count) - for text-row-count = (and next (get-text-property next 'cfw:row-count)) - while next do + (cl-loop with pos = (point-min) + for next-pos = (next-single-property-change pos 'cfw:row-count) + for text-row-count = (and next-pos (get-text-property next-pos 'cfw:row-count)) + while next-pos do (when (eql row-count text-row-count) - (return next)) - (setq pos next))) + (cl-return next-pos)) + (setq pos next-pos))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; High level API ;; buffer -(defun* cfw:open-calendar-buffer +(cl-defun cfw:open-calendar-buffer (&key date buffer custom-map contents-sources annotation-sources view sorter) "Open a calendar buffer simply. DATE is initial focus date. If it is nil, today is selected @@ -2799,7 +2803,7 @@ initially. This function uses the function :annotation-sources annotation-sources :view view :sorter sorter))) (switch-to-buffer (cfw:cp-get-buffer cp))))) -(defun* cfw:create-calendar-component-buffer +(cl-defun cfw:create-calendar-component-buffer (&key date buffer custom-map contents-sources annotation-sources view sorter) "Return a calendar buffer with some customize parameters. @@ -2820,7 +2824,7 @@ CUSTOM-MAP is the additional keymap that is added to default keymap `cfw:calenda ;; region -(defun* cfw:create-calendar-component-region +(cl-defun cfw:create-calendar-component-region (&key date width height keymap contents-sources annotation-sources view sorter) "Insert markers of the rendering destination at current point and display the calendar view. @@ -2838,7 +2842,7 @@ KEYMAP is the keymap that is put to the text property `keymap'. If KEYMAP is nil (model (cfw:model-abstract-new date contents-sources annotation-sources sorter)) (cp (cfw:cp-new dest model view date)) (after-update-func - (lexical-let ((keymap keymap) (cp cp)) + (let ((keymap keymap) (cp cp)) (lambda () (cfw:dest-with-region (cfw:component-dest cp) (let (buffer-read-only) @@ -2856,7 +2860,7 @@ KEYMAP is the keymap that is put to the text property `keymap'. If KEYMAP is nil If the text already has some keymap property, the text is skipped." (save-excursion (goto-char begin) - (loop with pos = begin with nxt = nil + (cl-loop with pos = begin with nxt = nil until (or (null pos) (<= end pos)) when (get-text-property pos 'keymap) do (setq pos (next-single-property-change pos 'keymap)) @@ -2867,7 +2871,7 @@ If the text already has some keymap property, the text is skipped." ;; inline -(defun* cfw:get-calendar-text +(cl-defun cfw:get-calendar-text (width height &key date keymap contents-sources annotation-sources view sorter) "Return a text that is drew the calendar view. @@ -2999,5 +3003,5 @@ And here.") (provide 'calfw) ;;; calfw.el ends here -;; (progn (eval-current-buffer) (cfw:open-debug-calendar)) -;; (progn (eval-current-buffer) (cfw:open-calendar-buffer)) +;; (progn (eval-buffer) (cfw:open-debug-calendar)) +;; (progn (eval-buffer) (cfw:open-calendar-buffer)) From cadd04bfc514ecdcad0d48d6e69a45924aa5a20c Mon Sep 17 00:00:00 2001 From: danielfleischer Date: Sat, 1 May 2021 10:34:47 +0300 Subject: [PATCH 2/4] Inactive timestamp in calfw-org Customized option to show inactive timestamps events. --- calfw-org.el | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/calfw-org.el b/calfw-org.el index 4590f1c..5a16a77 100644 --- a/calfw-org.el +++ b/calfw-org.el @@ -54,6 +54,11 @@ :type '(list string string symbol (list symbol (choice file (const nil))) string)) +(defcustom cfw:org-agenda-inactive-timestamps nil + "Non-nil means show inactive timestamps events." + :group 'cfw-org + :type 'boolean) + (defsubst cfw:org-tp (text prop) "[internal] Return text property at position 0." (get-text-property 0 prop text)) @@ -90,6 +95,8 @@ For example, (defun cfw:org-collect-schedules-period (begin end) "[internal] Return org schedule items between BEGIN and END." (let ((org-agenda-prefix-format " ") + (org-agenda-include-inactive-timestamps + cfw:org-agenda-inactive-timestamps) (span 'day)) (setq org-agenda-buffer (when (buffer-live-p org-agenda-buffer) From a00473f1afd8e9104123b99ebfcda0ac91205e99 Mon Sep 17 00:00:00 2001 From: Daniel Fleischer Date: Sun, 8 Jan 2023 19:50:11 +0200 Subject: [PATCH 3/4] Bug fix: repeating events appeared multiple times The bug was that a repeating event appeared multiple times at the first day it was scheduled/deadline; the reason is this package scrapes the agenda for data and in day-mode an individual repeating events appears in all the future dates so need to dedup it. --- calfw-org.el | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/calfw-org.el b/calfw-org.el index 5a16a77..24ae664 100644 --- a/calfw-org.el +++ b/calfw-org.el @@ -96,20 +96,23 @@ For example, "[internal] Return org schedule items between BEGIN and END." (let ((org-agenda-prefix-format " ") (org-agenda-include-inactive-timestamps - cfw:org-agenda-inactive-timestamps) + cfw:org-agenda-inactive-timestamps) (span 'day)) (setq org-agenda-buffer - (when (buffer-live-p org-agenda-buffer) - org-agenda-buffer)) + (when (buffer-live-p org-agenda-buffer) + org-agenda-buffer)) (org-compile-prefix-format nil) - (loop for date in (cfw:enumerate-days begin end) append - (loop for file in (or cfw:org-icalendars (org-agenda-files nil 'ifmode)) - append - (progn - (org-check-agenda-file file) - (apply 'org-agenda-get-day-entries - file date - cfw:org-agenda-schedule-args)))))) + (delete-duplicates + (loop for date in (cfw:enumerate-days begin end) append + (loop for file in (or cfw:org-icalendars (org-agenda-files nil 'ifmode)) + append + (progn + (org-check-agenda-file file) + (apply 'org-agenda-get-day-entries + file date + cfw:org-agenda-schedule-args)))) + :from-end t + :test (lambda (x y) (equal (cfw:org-tp x 'date) (cfw:org-tp y 'date)))))) (defun cfw:org-onclick () "Jump to the clicked org item." From d63994acb7bcf30bb0b06668d9bed5d26056810e Mon Sep 17 00:00:00 2001 From: Daniel Fleischer Date: Sun, 15 Jan 2023 17:11:29 +0200 Subject: [PATCH 4/4] Update calfw-org.el --- calfw-org.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/calfw-org.el b/calfw-org.el index 24ae664..e613811 100644 --- a/calfw-org.el +++ b/calfw-org.el @@ -112,7 +112,7 @@ For example, file date cfw:org-agenda-schedule-args)))) :from-end t - :test (lambda (x y) (equal (cfw:org-tp x 'date) (cfw:org-tp y 'date)))))) + :test (lambda (x y) (equal (cfw:org-tp x 'txt) (cfw:org-tp y 'txt)))))) (defun cfw:org-onclick () "Jump to the clicked org item."