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.

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,5 +1,28 @@
 2013-12-20  Stephen Berman  <stephen.berman@gmx.net>
 
+        * 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  <stephen.berman@gmx.net>
+
         * calendar/todo-mode.el: Bug fixes and new features (bug#15225).
         (todo-toggle-item-highlighting): Use eval-and-compile instead of
         eval-when-compile.
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)