Commit f3a66082 authored by Stephen Berman's avatar Stephen Berman
Browse files

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.
parent 2f99433b
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).
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment