From 2b1cac26855b99644b00a839f7ea25446d997572 Mon Sep 17 00:00:00 2001 From: Stephen Berman Date: Sun, 12 Aug 2018 23:25:53 +0200 Subject: [PATCH] Update and improve todo-mode item insertion and editing code * lisp/calendar/todo-mode.el (todo-insert-item--param-key-alist) (todo-insert-item--keyof, todo-insert-item--this-key) (todo-insert-item--keys-so-far, todo-insert-item--args) (todo-insert-item--argleft. todo-insert-item--argsleft) (todo-insert-item--newargsleft, todo-insert-item--apply-args) (todo-edit-item--param-key-alist, todo-edit-item--prompt) (todo-edit-item--date-param-key-alist) (todo-edit-done-item--param-key-alist): Remove. (todo-insert-item--next-param): Reimplement to take advantage of lexical binding. (todo-insert-item): Adjust to new implementation of the above. (todo-edit-item--next-key): Incorporate now removed global variables, adjust signature accordingly, update use of pcase. (todo-edit-item): Adjust to changed signature of the above. --- lisp/calendar/todo-mode.el | 349 +++++++++++++++++-------------------- 1 file changed, 164 insertions(+), 185 deletions(-) diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index c1c292129e2..9c770f17fb1 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -1830,7 +1830,6 @@ consist of the last todo items and the first done items." (defvar todo-date-from-calendar nil "Helper variable for setting item date from the Emacs Calendar.") -(defvar todo-insert-item--keys-so-far) (defvar todo-insert-item--parameters) (defun todo-insert-item (&optional arg) @@ -1852,8 +1851,7 @@ already been entered and which remain available. See `(todo-mode) Inserting New Items' for details of the parameters, their associated keys and their effects." (interactive "P") - (setq todo-insert-item--keys-so-far "i") - (todo-insert-item--next-param nil (list arg) todo-insert-item--parameters)) + (todo-insert-item--next-param (list arg) todo-insert-item--parameters nil "i")) (defun todo-insert-item--basic (&optional arg diary-type date-type time where) "Function implementing the core of `todo-insert-item'." @@ -2101,17 +2099,14 @@ the item at point." (let (todo-show-with-done) (todo-category-select))))) (if ov (delete-overlay ov))))) -(defvar todo-edit-item--param-key-alist) -(defvar todo-edit-done-item--param-key-alist) - (defun todo-edit-item (&optional arg) "Choose an editing operation for the current item and carry it out." (interactive "P") (let ((marked (assoc (todo-current-category) todo-categories-with-marks))) (cond ((and (todo-done-item-p) (not marked)) - (todo-edit-item--next-key todo-edit-done-item--param-key-alist)) + (todo-edit-item--next-key 'done arg)) ((or marked (todo-item-string)) - (todo-edit-item--next-key todo-edit-item--param-key-alist arg))))) + (todo-edit-item--next-key 'todo arg))))) (defun todo-edit-item--text (&optional arg) "Function providing the text editing facilities of `todo-edit-item'." @@ -5523,12 +5518,14 @@ of each other." ;;; Generating and applying item insertion and editing key sequences ;; ----------------------------------------------------------------------------- -;; Thanks to Stefan Monnier for suggesting dynamically generating item -;; insertion commands and their key bindings, and offering an elegant -;; implementation, which, however, relies on lexical scoping and so -;; cannot be used here until the Calendar code used by todo-mode.el is -;; converted to lexical binding. Hence, the following implementation -;; uses dynamic binding. +;; Thanks to Stefan Monnier for (i) not only suggesting dynamically +;; generating item insertion commands and their key bindings but also +;; offering an elegant implementation which, however, since it used +;; lexical binding, was at the time incompatible with the Calendar and +;; Diary code in todo-mode.el; and (ii) later making that code +;; compatible with lexical binding, so that his implementation, of +;; which the following is a somewhat expanded version, could be +;; realized in todo-mode.el. (defconst todo-insert-item--parameters '((default copy) (diary nonmarking) (calendar date dayname) time (here region)) @@ -5536,91 +5533,33 @@ of each other." Passed by `todo-insert-item' to `todo-insert-item--next-param' to dynamically create item insertion commands.") -(defconst todo-insert-item--param-key-alist - '((default . "i") - (copy . "p") - (diary . "y") - (nonmarking . "k") - (calendar . "c") - (date . "d") - (dayname . "n") - (time . "t") - (here . "h") - (region . "r")) - "List pairing item insertion parameters with their completion keys.") - -(defsubst todo-insert-item--keyof (param) - "Return key paired with item insertion PARAM." - (cdr (assoc param todo-insert-item--param-key-alist))) - -(defun todo-insert-item--argsleft (key list) - "Return sublist of LIST whose first member corresponds to KEY." - (let (l sym) - (mapc (lambda (m) - (when (consp m) - (catch 'found1 - (dolist (s m) - (when (equal key (todo-insert-item--keyof s)) - (throw 'found1 (setq sym s)))))) - (if sym - (progn - (push sym l) - (setq sym nil)) - (push m l))) - list) - (setq list (reverse l))) - (memq (catch 'found2 - (dolist (e todo-insert-item--param-key-alist) - (when (equal key (cdr e)) - (throw 'found2 (car e))))) - list)) - -(defsubst todo-insert-item--this-key () (char-to-string last-command-event)) - -(defvar todo-insert-item--keys-so-far "" - "String of item insertion keys so far entered for this command.") - -(defvar todo-insert-item--args nil) -(defvar todo-insert-item--argleft nil) -(defvar todo-insert-item--argsleft nil) -(defvar todo-insert-item--newargsleft nil) - -(defun todo-insert-item--apply-args () - "Build list of arguments for item insertion and apply them. -The list consists of item insertion parameters that can be passed -as insertion command arguments in fixed positions. If a position -in the list is not occupied by the corresponding parameter, it is -occupied by nil." - (let* ((arg (list (car todo-insert-item--args))) - (args (nconc (cdr todo-insert-item--args) - (list (car (todo-insert-item--argsleft - (todo-insert-item--this-key) - todo-insert-item--argsleft))))) - (arglist (if (= 4 (length args)) - args - (let ((v (make-vector 4 nil)) elt) - (while args - (setq elt (pop args)) - (cond ((memq elt '(diary nonmarking)) - (aset v 0 elt)) - ((memq elt '(calendar date dayname)) - (aset v 1 elt)) - ((eq elt 'time) - (aset v 2 elt)) - ((memq elt '(copy here region)) - (aset v 3 elt)))) - (append v nil))))) - (apply #'todo-insert-item--basic (nconc arg arglist)))) - -(defun todo-insert-item--next-param (last args argsleft) - "Build item insertion command from LAST, ARGS and ARGSLEFT and call it. -Dynamically generate key bindings, prompting with the keys -already entered and those still available." - (cl-assert argsleft) +(defun todo-insert-item--next-param (args params last keys-so-far) + "Generate and invoke an item insertion command. +Dynamically generate the command, its arguments ARGS and its key +binding by recursing through the list of parameters PARAMS, +taking the LAST from a sublist and prompting with KEYS-SO-FAR +keys already entered and those still available." + (cl-assert params) (let* ((map (make-sparse-keymap)) + (param-key-alist '((default . "i") + (copy . "p") + (diary . "y") + (nonmarking . "k") + (calendar . "c") + (date . "d") + (dayname . "n") + (time . "t") + (here . "h") + (region . "r"))) + ;; Return key paired with given item insertion parameter. + (key-of (lambda (param) (cdr (assoc param param-key-alist)))) + ;; The key just typed. + (this-key (lambda () (char-to-string last-command-event))) (prompt nil) - (addprompt - (lambda (k name) + ;; Add successively entered keys to the prompt and show what + ;; possibilities remain. + (add-to-prompt + (lambda (key name) (setq prompt (concat prompt (format @@ -5630,80 +5569,119 @@ already entered and those still available." "%s=>%s" (when (memq name '(copy nonmarking dayname region)) " }")) - (propertize k 'face 'todo-key-prompt) - name)))))) - (setq todo-insert-item--args args) - (setq todo-insert-item--argsleft argsleft) + (propertize key 'face 'todo-key-prompt) + name))))) + ;; Return the sublist of the given list of parameters whose + ;; first member is paired with the given key. + (get-params + (lambda (key lst) + (setq lst (if (consp lst) lst (list lst))) + (let (l sym) + (mapc (lambda (m) + (when (consp m) + (catch 'found1 + (dolist (s m) + (when (equal key (funcall key-of s)) + (throw 'found1 (setq sym s)))))) + (if sym + (progn + (push sym l) + (setq sym nil)) + (push m l))) + lst) + (setq lst (reverse l))) + (memq (catch 'found2 + (dolist (e param-key-alist) + (when (equal key (cdr e)) + (throw 'found2 (car e))))) + lst))) + ;; Build list of arguments for item insertion and then + ;; execute the basic insertion function. The list consists of + ;; item insertion parameters that can be passed as insertion + ;; command arguments in fixed positions. If a position in + ;; the list is not occupied by the corresponding parameter, + ;; it is occupied by nil. + (gen-and-exec + (lambda () + (let* ((arg (list (car args))) ; Possible prefix argument. + (rest (nconc (cdr args) + (list (car (funcall get-params + (funcall this-key) + params))))) + (parlist (if (= 4 (length rest)) + rest + (let ((v (make-vector 4 nil)) elt) + (while rest + (setq elt (pop rest)) + (cond ((memq elt '(diary nonmarking)) + (aset v 0 elt)) + ((memq elt '(calendar date dayname)) + (aset v 1 elt)) + ((eq elt 'time) + (aset v 2 elt)) + ((memq elt '(copy here region)) + (aset v 3 elt)))) + (append v nil))))) + (apply #'todo-insert-item--basic (nconc arg parlist))))) + ;; Operate on a copy of the parameter list so the original is + ;; not consumed, thus available for the next key typed. + (params0 params)) (when last (if (memq last '(default copy)) (progn - (setq todo-insert-item--argsleft nil) - (todo-insert-item--apply-args)) - (let ((k (todo-insert-item--keyof last))) - (funcall addprompt k (make-symbol (concat (symbol-name last) ":GO!"))) - (define-key map (todo-insert-item--keyof last) + (setq params0 nil) + (funcall gen-and-exec)) + (let ((key (funcall key-of last))) + (funcall add-to-prompt key (make-symbol + (concat (symbol-name last) ":GO!"))) + (define-key map (funcall key-of last) (lambda () (interactive) - (todo-insert-item--apply-args)))))) - (while todo-insert-item--argsleft - (let ((x (car todo-insert-item--argsleft))) - (setq todo-insert-item--newargsleft (cdr todo-insert-item--argsleft)) - (dolist (argleft (if (consp x) x (list x))) - (let ((k (todo-insert-item--keyof argleft))) - (funcall addprompt k argleft) - (define-key map k - (if (null todo-insert-item--newargsleft) - (lambda () (interactive) - (todo-insert-item--apply-args)) - (lambda () (interactive) - (setq todo-insert-item--keys-so-far - (concat todo-insert-item--keys-so-far " " - (todo-insert-item--this-key))) - (todo-insert-item--next-param - (car (todo-insert-item--argsleft - (todo-insert-item--this-key) - todo-insert-item--argsleft)) - (nconc todo-insert-item--args - (list (car (todo-insert-item--argsleft - (todo-insert-item--this-key) - todo-insert-item--argsleft)))) - (cdr (todo-insert-item--argsleft - (todo-insert-item--this-key) - todo-insert-item--argsleft))))))))) - (setq todo-insert-item--argsleft todo-insert-item--newargsleft)) - (when prompt (message "Press a key (so far `%s'): %s" - todo-insert-item--keys-so-far prompt)) + (funcall gen-and-exec)))))) + (while params0 + (let* ((x (car params0)) + (restparams (cdr params0))) + (dolist (param (if (consp x) x (list x))) + (let ((key (funcall key-of param))) + (funcall add-to-prompt key param) + (define-key map key + (if (null restparams) + (lambda () (interactive) + (funcall gen-and-exec)) + (lambda () (interactive) + (setq keys-so-far (concat keys-so-far " " (funcall this-key))) + (todo-insert-item--next-param + (nconc args (list (car (funcall get-params + (funcall this-key) param)))) + (cdr (funcall get-params (funcall this-key) params)) + (car (funcall get-params (funcall this-key) param)) + keys-so-far)))))) + (setq params0 restparams))) (set-transient-map map) - (setq todo-insert-item--argsleft argsleft))) - -(defconst todo-edit-item--param-key-alist - '((edit . "e") - (header . "h") - (multiline . "m") - (diary . "y") - (nonmarking . "k") - (date . "d") - (time . "t")) - "Alist of item editing parameters and their keys.") - -(defconst todo-edit-item--date-param-key-alist - '((full . "f") - (calendar . "c") - (today . "a") - (dayname . "n") - (year . "y") - (month . "m") - (daynum . "d")) - "Alist of item date editing parameters and their keys.") - -(defconst todo-edit-done-item--param-key-alist - '((add/edit . "c") - (delete . "d")) - "Alist of done item comment editing parameters and their keys.") - -(defvar todo-edit-item--prompt "Press a key (so far `e'): ") - -(defun todo-edit-item--next-key (params &optional arg) - (let* ((p->k (mapconcat (lambda (elt) + (when prompt (message "Press a key (so far `%s'): %s" keys-so-far prompt)) + (setq params0 params))) + +(defun todo-edit-item--next-key (type &optional arg) + (let* ((todo-param-key-alist '((edit . "e") + (header . "h") + (multiline . "m") + (diary . "y") + (nonmarking . "k") + (date . "d") + (time . "t"))) + (done-param-key-alist '((add/edit . "c") + (delete . "d"))) + (date-param-key-alist '((full . "f") + (calendar . "c") + (today . "a") + (dayname . "n") + (year . "y") + (month . "m") + (daynum . "d"))) + (params (pcase type + ('todo todo-param-key-alist) + ('done done-param-key-alist) + ('date date-param-key-alist))) + (p->k (mapconcat (lambda (elt) (format "%s=>%s" (propertize (cdr elt) 'face 'todo-key-prompt) @@ -5712,31 +5690,32 @@ already entered and those still available." '(add/edit delete)) " comment")))) params " ")) - (key-prompt (substitute-command-keys todo-edit-item--prompt)) + (key-prompt (substitute-command-keys + (concat "Press a key (so far `e" + (if (eq type 'date) " d" "") + "'): "))) (this-key (let ((key (read-key (concat key-prompt p->k)))) (and (characterp key) (char-to-string key)))) (this-param (car (rassoc this-key params)))) (pcase this-param - (`edit (todo-edit-item--text)) - (`header (todo-edit-item--text 'include-header)) - (`multiline (todo-edit-item--text 'multiline)) - (`add/edit (todo-edit-item--text 'comment-edit)) - (`delete (todo-edit-item--text 'comment-delete)) - (`diary (todo-edit-item--diary-inclusion)) - (`nonmarking (todo-edit-item--diary-inclusion 'nonmarking)) - (`date (let ((todo-edit-item--prompt "Press a key (so far `e d'): ")) - (todo-edit-item--next-key - todo-edit-item--date-param-key-alist arg))) - (`full (progn (todo-edit-item--header 'date) + ('edit (todo-edit-item--text)) + ('header (todo-edit-item--text 'include-header)) + ('multiline (todo-edit-item--text 'multiline)) + ('add/edit (todo-edit-item--text 'comment-edit)) + ('delete (todo-edit-item--text 'comment-delete)) + ('diary (todo-edit-item--diary-inclusion)) + ('nonmarking (todo-edit-item--diary-inclusion 'nonmarking)) + ('date (todo-edit-item--next-key 'date arg)) + ('full (progn (todo-edit-item--header 'date) (when todo-always-add-time-string (todo-edit-item--header 'time)))) - (`calendar (todo-edit-item--header 'calendar)) - (`today (todo-edit-item--header 'today)) - (`dayname (todo-edit-item--header 'dayname)) - (`year (todo-edit-item--header 'year arg)) - (`month (todo-edit-item--header 'month arg)) - (`daynum (todo-edit-item--header 'day arg)) - (`time (todo-edit-item--header 'time))))) + ('calendar (todo-edit-item--header 'calendar)) + ('today (todo-edit-item--header 'today)) + ('dayname (todo-edit-item--header 'dayname)) + ('year (todo-edit-item--header 'year arg)) + ('month (todo-edit-item--header 'month arg)) + ('daynum (todo-edit-item--header 'day arg)) + ('time (todo-edit-item--header 'time))))) ;; ----------------------------------------------------------------------------- ;;; Todo minibuffer utilities -- 2.39.5