[Emacs-diffs] trunk r115648: New implementation of Todo item insertion commands and key bindings.

[Stephen Berman]

------------------------------------------------------------
revno: 115648
revision-id: address@hidden
parent: address@hidden
author: Stephen Berman  <address@hidden>
committer: Stephen Berman <address@hidden>
branch nick: trunk
timestamp: Fri 2013-12-20 18:21:12 +0100
message:
  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.
modified:
  lisp/ChangeLog                 changelog-20091113204419-o5vbwnq5f7feedwu-1432
  lisp/calendar/todo-mode.el     todos.el-20120911155047-0ytqo2nidwqquefa-1

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2013-12-20 17:16:47 +0000
+++ b/lisp/ChangeLog    2013-12-20 17:21:12 +0000
@@ -1,5 +1,28 @@
 2013-12-20  Stephen Berman  <address@hidden>
 
+       * 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  <address@hidden>
+
        * calendar/todo-mode.el: Bug fixes and new features (bug#15225).
        (todo-toggle-item-highlighting): Use eval-and-compile instead of
        eval-when-compile.

=== modified file 'lisp/calendar/todo-mode.el'
--- a/lisp/calendar/todo-mode.el        2013-12-20 17:16:47 +0000
+++ b/lisp/calendar/todo-mode.el        2013-12-20 17:21:12 +0000
@@ -330,6 +330,11 @@
 ;;; 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 @@
 (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 @@
 ;;; 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 @@
 ;;; 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 @@
     ("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)