From f3a66082f986c33df1c72b0ab2b77195cdd8b435 Mon Sep 17 00:00:00 2001 From: Stephen Berman Date: Fri, 20 Dec 2013 18:21:12 +0100 Subject: [PATCH] New implementation of Todo item insertion commands and key bindings. * calendar/todo-mode.el: New implementation of item insertion commands and key bindings. (todo-key-prompt): New face. (todo-insert-item): New command. (todo-insert-item--parameters): New defconst, replacing defvar todo-insertion-commands-args-genlist. (todo-insert-item--param-key-alist): New defconst, replacing defvar todo-insertion-commands-arg-key-list. (todo-insert-item--keyof, todo-insert-item--this-key): New defsubsts. (todo-insert-item--argsleft, todo-insert-item--apply-args) (todo-insert-item--next-param): New functions. (todo-insert-item--args, todo-insert-item--argleft) (todo-insert-item--argsleft, todo-insert-item--newargsleft): New variables. (todo-key-bindings-t): Change binding of "i" from todo-insertion-map to todo-insert-item. (todo-powerset, todo-gen-arglists, todo-insertion-commands-args) (todo-insertion-command-name, todo-insertion-commands-names) (todo-define-insertion-command, todo-insertion-commands) (todo-insertion-key-bindings, todo-insertion-map): Remove. --- lisp/ChangeLog | 23 +++ lisp/calendar/todo-mode.el | 330 ++++++++++++++++++++++--------------- 2 files changed, 220 insertions(+), 133 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e367749fb39..3286c90caed 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,26 @@ +2013-12-20 Stephen Berman + + * calendar/todo-mode.el: New implementation of item insertion + commands and key bindings. + (todo-key-prompt): New face. + (todo-insert-item): New command. + (todo-insert-item--parameters): New defconst, replacing defvar + todo-insertion-commands-args-genlist. + (todo-insert-item--param-key-alist): New defconst, replacing + defvar todo-insertion-commands-arg-key-list. + (todo-insert-item--keyof, todo-insert-item--this-key): New defsubsts. + (todo-insert-item--argsleft, todo-insert-item--apply-args) + (todo-insert-item--next-param): New functions. + (todo-insert-item--args, todo-insert-item--argleft) + (todo-insert-item--argsleft, todo-insert-item--newargsleft): + New variables. + (todo-key-bindings-t): Change binding of "i" from + todo-insertion-map to todo-insert-item. + (todo-powerset, todo-gen-arglists, todo-insertion-commands-args) + (todo-insertion-command-name, todo-insertion-commands-names) + (todo-define-insertion-command, todo-insertion-commands) + (todo-insertion-key-bindings, todo-insertion-map): Remove. + 2013-12-20 Stephen Berman * calendar/todo-mode.el: Bug fixes and new features (bug#15225). diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index 3dcb305f05a..055c97972a8 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -330,6 +330,11 @@ shown in the Fancy Diary display." ;;; Faces ;; ----------------------------------------------------------------------------- +(defface todo-key-prompt + '((t (:weight bold))) + "Face for making keys in item insertion prompt stand out." + :group 'todo-faces) + (defface todo-mark ;; '((t :inherit font-lock-warning-face)) '((((class color) @@ -1743,6 +1748,30 @@ marking of the next N 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) + "Insert a new todo item into a category. + +With no prefix argument ARG, add the item to the current +category; with one prefix argument (`C-u'), prompt for a category +from the current todo file; with two prefix arguments (`C-u +C-u'), first prompt for a todo file, then a category in that +file. If a non-existing category is entered, ask whether to add +it to the todo file; if answered affirmatively, add the category +and insert the item there. + +There are a number of item insertion parameters which can be +combined by entering specific keys to produce different insertion +commands. After entering each key, a message shows which have +already been entered and which remain available. See +`todo-basic-insert-item' for details of the parameters 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)) + (defun todo-basic-insert-item (&optional arg diary nonmarking date-type time region-or-here) "Insert a new todo item into a category. @@ -5425,131 +5454,173 @@ of each other." ;;; Utilities for generating item insertion commands and key bindings ;; ----------------------------------------------------------------------------- -;; Wolfgang Jenkner posted this powerset definition to emacs-devel -;; (http://lists.gnu.org/archive/html/emacs-devel/2013-06/msg00423.html) -;; and kindly gave me permission to use it. - -(defun todo-powerset (list) - "Return the powerset of LIST." - (let ((powerset (list nil))) - (dolist (elt list (mapcar 'reverse powerset)) - (nconc powerset (mapcar (apply-partially 'cons elt) powerset))))) - -(defun todo-gen-arglists (arglist) - "Return list of lists of non-nil atoms produced from ARGLIST. -The elements of ARGLIST may be atoms or lists." - (let (arglists) - (while arglist - (let ((arg (pop arglist))) - (cond ((symbolp arg) - (setq arglists (if arglists - (mapcar (lambda (l) (push arg l)) arglists) - (list (push arg arglists))))) - ((listp arg) - (setq arglists - (mapcar (lambda (a) - (if (= 1 (length arglists)) - (apply (lambda (l) (push a l)) arglists) - (mapcar (lambda (l) (push a l)) arglists))) - arg)))))) - (setq arglists (mapcar 'reverse (apply 'append (mapc 'car arglists)))))) - -(defvar todo-insertion-commands-args-genlist - '(diary nonmarking (calendar date dayname) time (here region)) - "Generator list for argument lists of item insertion commands.") - -(defvar todo-insertion-commands-args - (let ((arglist (todo-gen-arglists todo-insertion-commands-args-genlist)) - res new) - (setq res (cl-remove-duplicates - (apply 'append (mapcar 'todo-powerset arglist)) :test 'equal)) - (dolist (l res) - (unless (= 5 (length l)) - (let ((v (make-vector 5 nil)) elt) - (while l - (setq elt (pop l)) - (cond ((eq elt 'diary) - (aset v 0 elt)) - ((eq elt 'nonmarking) - (aset v 1 elt)) - ((or (eq elt 'calendar) - (eq elt 'date) - (eq elt 'dayname)) - (aset v 2 elt)) - ((eq elt 'time) - (aset v 3 elt)) - ((or (eq elt 'here) - (eq elt 'region)) - (aset v 4 elt)))) - (setq l (append v nil)))) - (setq new (append new (list l)))) - new) - "List of all argument lists for Todo mode item insertion commands.") - -(defun todo-insertion-command-name (arglist) - "Generate Todo mode item insertion command name from ARGLIST." - (replace-regexp-in-string - "-\\_>" "" - (replace-regexp-in-string - "-+" "-" - (concat "todo-insert-item-" - (mapconcat (lambda (e) (if e (symbol-name e))) arglist "-"))))) - -(defvar todo-insertion-commands-names - (mapcar (lambda (l) - (todo-insertion-command-name l)) - todo-insertion-commands-args) - "List of names of Todo mode item insertion commands.") - -(defmacro todo-define-insertion-command (&rest args) - "Generate Todo mode item insertion command definitions from ARGS." - (let ((name (intern (todo-insertion-command-name args))) - (arg0 (nth 0 args)) - (arg1 (nth 1 args)) - (arg2 (nth 2 args)) - (arg3 (nth 3 args)) - (arg4 (nth 4 args))) - `(defun ,name (&optional arg &rest args) - "Todo mode item insertion command generated from ARGS. -For descriptions of the individual arguments, their values, and -their relation to key bindings, see `todo-basic-insert-item'." - (interactive (list current-prefix-arg)) - (todo-basic-insert-item arg ',arg0 ',arg1 ',arg2 ',arg3 ',arg4)))) - -(defvar todo-insertion-commands - (mapcar (lambda (c) - (eval `(todo-define-insertion-command ,@c))) - todo-insertion-commands-args) - "List of Todo mode item insertion commands.") - -(defvar todo-insertion-commands-arg-key-list - '(("diary" "y" "yy") - ("nonmarking" "k" "kk") - ("calendar" "c" "cc") - ("date" "d" "dd") - ("dayname" "n" "nn") - ("time" "t" "tt") - ("here" "h" "h") - ("region" "r" "r")) - "List of mappings of item insertion command arguments to key sequences.") - -(defun todo-insertion-key-bindings (map) - "Generate key binding definitions for item insertion keymap MAP." - (dolist (c todo-insertion-commands) - (let* ((key "") - (cname (symbol-name c))) - (mapc (lambda (l) - (let ((arg (nth 0 l)) - (key1 (nth 1 l)) - (key2 (nth 2 l))) - (if (string-match (concat (regexp-quote arg) "\\_>") cname) - (setq key (concat key key2))) - (if (string-match (concat (regexp-quote arg) ".+") cname) - (setq key (concat key key1))))) - todo-insertion-commands-arg-key-list) - (if (string-match (concat (regexp-quote "todo-insert-item") "\\_>") cname) - (setq key (concat key "i"))) - (define-key map key c)))) +;; 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. + +(defconst todo-insert-item--parameters + '((default copy) diary nonmarking (calendar date dayname) time (here region)) + "List of all item insertion parameters. +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 (unless (= 5 (length args)) + (let ((v (make-vector 5 nil)) elt) + (while args + (setq elt (pop args)) + (cond ((eq elt 'diary) + (aset v 0 elt)) + ((eq elt 'nonmarking) + (aset v 1 elt)) + ((or (eq elt 'calendar) + (eq elt 'date) + (eq elt 'dayname)) + (aset v 2 elt)) + ((eq elt 'time) + (aset v 3 elt)) + ((or (eq elt 'here) + (eq elt 'region)) + (aset v 4 elt)))) + (append v nil))))) + (apply #'todo-basic-insert-item (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) + (let* ((map (make-sparse-keymap)) + (prompt nil) + (addprompt (lambda (k name) + (setq prompt (concat prompt + (format (concat + (if (or (eq name 'default) + (eq name 'calendar) + (eq name 'here)) + " { " " ") + "%s=>%s" + (when (or (eq name 'copy) + (eq name 'dayname) + (eq name 'region)) + " }")) + (propertize k 'face + 'todo-key-prompt) + name)))))) + (setq todo-insert-item--args args) + (setq todo-insert-item--argsleft argsleft) + (when last + (cond ((eq last 'default) + (apply #'todo-basic-insert-item (car todo-insert-item--args)) + (setq todo-insert-item--argsleft nil)) + ((eq last 'copy) + (todo-copy-item) + (setq todo-insert-item--argsleft nil)) + (t (let ((k (todo-insert-item--keyof last))) + (funcall addprompt k 'GO!) + (define-key map (todo-insert-item--keyof 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) + (when (equal "k" (todo-insert-item--this-key)) + (unless (string-match "y" todo-insert-item--keys-so-far) + (when (y-or-n-p (concat "`k' only takes effect with `y';" + " add `y'? ")) + (setq todo-insert-item--keys-so-far + (concat todo-insert-item--keys-so-far " y")) + (setq todo-insert-item--args + (nconc todo-insert-item--args (list 'diary)))))) + (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 "Enter a key (so far `%s'): %s" + todo-insert-item--keys-so-far prompt)) + (set-temporary-overlay-map map) + (setq todo-insert-item--argsleft argsleft))) ;; ----------------------------------------------------------------------------- ;;; Todo minibuffer utilities @@ -6224,13 +6295,6 @@ Filtered Items mode following todo (not done) items." ;;; Key binding ;; ----------------------------------------------------------------------------- -(defvar todo-insertion-map - (let ((map (make-keymap))) - (todo-insertion-key-bindings map) - (define-key map "p" 'todo-copy-item) - map) - "Keymap for Todo mode item insertion commands.") - (defvar todo-key-bindings-t `( ("Af" todo-find-archive) @@ -6272,7 +6336,7 @@ Filtered Items mode following todo (not done) items." ("eyk" todo-edit-item-diary-nonmarking) ("ec" todo-edit-done-item-comment) ("d" todo-item-done) - ("i" ,todo-insertion-map) + ("i" todo-insert-item) ("k" todo-delete-item) ("m" todo-move-item) ("u" todo-item-undone) -- 2.39.2