From 56692965b707fc2d544e432311a81e2bda46f930 Mon Sep 17 00:00:00 2001 From: Carsten Dominik Date: Sun, 8 Feb 2009 13:57:37 +0100 Subject: [PATCH] Add Tom Breton's org-choose.el as a contributed package --- contrib/README | 1 + contrib/lisp/org-choose.el | 487 +++++++++++++++++++++++++++++++++++++ lisp/org.el | 114 ++++++--- 3 files changed, 569 insertions(+), 33 deletions(-) create mode 100644 contrib/lisp/org-choose.el diff --git a/contrib/README b/contrib/README index 27d0f2ca7..2715a1e67 100644 --- a/contrib/README +++ b/contrib/README @@ -14,6 +14,7 @@ org-annotate-file.el --- Annotate a file with org syntax org-annotation-helper.el --- Call remember directly from Firefox/Opera org-bookmark.el --- Links to bookmarks org-browser-url.el --- Store links to webpages directly from Firefox/Opera +org-choose.el --- Use TODO keywords to mark decision states org-depend.el --- TODO dependencies for Org-mode org-elisp-symbol.el --- Org links to emacs-lisp symbols org-eval.el --- The tag, adapted from Muse diff --git a/contrib/lisp/org-choose.el b/contrib/lisp/org-choose.el new file mode 100644 index 000000000..62af35222 --- /dev/null +++ b/contrib/lisp/org-choose.el @@ -0,0 +1,487 @@ +;;;_ org-choose.el --- decision management for org-mode + +;;;_. Headers +;;;_ , License +;; Copyright (C) 2009 Tom Breton (Tehom) + +;; Author: Tom Breton (Tehom) +;; Keywords: + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;;_ , Commentary: + +;; + + +;;;_ , Requires + +(require 'org) +(eval-when-compile + (require 'cl)) + +;;;_. Body +;;;_ , The variables + +(defstruct (org-choose-mark-data. (:type list)) + "The format of an entry in org-choose-mark-data. +Indexes are 0-based or `nil'. +" + keyword + bot-lower-range + top-upper-range + range-length + static-default + all-keywords) + +(defvar org-choose-mark-data + () + "Alist of information for choose marks. + +Each entry is an `org-choose-mark-data.'" ) +(make-variable-buffer-local 'org-choose-mark-data) +;;;_ , For setup +;;;_ . org-choose-filter-one + +(defun org-choose-filter-one (i) + "Return a list of + * a canonized version of the string + * optionally one symbol" + + (if + (not + (string-match "(.*)" i)) + (list i i) + (let* + ( + (end-text (match-beginning 0)) + (vanilla-text (substring i 0 end-text)) + ;;Get the parenthesized part. + (match (match-string 0 i)) + ;;Remove the parentheses. + (args (substring match 1 -1)) + ;;Split it + (arglist + (let + ((arglist-x (split-string args ","))) + ;;When string starts with "," `split-string' doesn't + ;;make a first arg, so in that case make one + ;;manually. + (if + (string-match "^," args) + (cons nil arglist-x) + arglist-x))) + (decision-arg (second arglist)) + (type + (cond + ((string= decision-arg "0") + 'default-mark) + ((string= decision-arg "+") + 'top-upper-range) + ((string= decision-arg "-") + 'bot-lower-range) + (t nil))) + (vanilla-arg (first arglist)) + (vanilla-mark + (if vanilla-arg + (concat vanilla-text "("vanilla-arg")") + vanilla-text))) + (if type + (list vanilla-text vanilla-mark type) + (list vanilla-text vanilla-mark))))) + +;;;_ . org-choose-setup-vars +(defun org-choose-setup-vars (bot-lower-range top-upper-range + static-default num-items all-mark-texts) + "Add to org-choose-mark-data according to arguments" + + (let* + ( + (tail + ;;If there's no bot-lower-range or no default, we don't + ;;have ranges. + (cdr + (if (and static-default bot-lower-range) + (let* + ( + ;;If there's no top-upper-range, use the last + ;;item. + (top-upper-range + (or top-upper-range (1- num-items))) + (lower-range-length + (1+ (- static-default bot-lower-range))) + (upper-range-length + (- top-upper-range static-default)) + (range-length + (min upper-range-length lower-range-length))) + + + (make-org-choose-mark-data. + :keyword nil + :bot-lower-range bot-lower-range + :top-upper-range top-upper-range + :range-length range-length + :static-default static-default + :all-keywords all-mark-texts)) + + (make-org-choose-mark-data. + :keyword nil + :bot-lower-range nil + :top-upper-range nil + :range-length nil + :static-default (or static-default 0) + :all-keywords all-mark-texts))))) + + (dolist (text all-mark-texts) + (pushnew (cons text tail) + org-choose-mark-data + :test + #'(lambda (a b) + (equal (car a) (car b))))))) + + + + +;;;_ . org-choose-filter-tail +(defun org-choose-filter-tail (raw) + "Return a translation of RAW to vanilla and set appropriate +buffer-local variables. + +RAW is a list of strings representing the input text of a choose +interpretation." + (let + ((vanilla-list nil) + (all-mark-texts nil) + (index 0) + bot-lower-range top-upper-range range-length static-default) + (dolist (i raw) + (destructuring-bind + (vanilla-text vanilla-mark &optional type) + (org-choose-filter-one i) + (cond + ((eq type 'bot-lower-range) + (setq bot-lower-range index)) + ((eq type 'top-upper-range) + (setq top-upper-range index)) + ((eq type 'default-mark) + (setq static-default index))) + (incf index) + (push vanilla-text all-mark-texts) + (push vanilla-mark vanilla-list))) + + (org-choose-setup-vars bot-lower-range top-upper-range + static-default index (reverse all-mark-texts)) + (nreverse vanilla-list))) + +;;;_ . org-choose-setup-filter + +(defun org-choose-setup-filter (raw) + "A setup filter for choose interpretations." + (when (eq (car raw) 'choose) + (cons + 'choose + (org-choose-filter-tail (cdr raw))))) + +;;;_ . org-choose-conform-after-promotion +(defun org-choose-conform-after-promotion (entry-pos keywords highest-ok-ix) + "" + + (unless + ;;Skip the entry that triggered this by skipping any entry with + ;;the same starting position. Both map and plist use the start + ;;of the header line as the position, so we can just compare + ;;them with `=' + (= (point) entry-pos) + (let + ((ix + (org-choose-get-entry-index keywords))) + ;;If the index of the entry exceeds the highest allowable + ;;index, change it to that. + (when (and ix + (> ix highest-ok-ix)) + (org-todo + (nth highest-ok-ix keywords)))))) +;;;_ . org-choose-conform-after-demotion +(defun org-choose-conform-after-demotion (entry-pos keywords + raise-to-ix + old-highest-ok-ix) + "" + (unless + ;;Skip the entry that triggered this. + (= (point) entry-pos) + (let + ((ix + (org-choose-get-entry-index keywords))) + ;;If the index of the entry was at or above the old allowable + ;;position, change it to the new mirror position if there is + ;;one. + (when (and + ix + raise-to-ix + (>= ix old-highest-ok-ix)) + (org-todo + (nth raise-to-ix keywords)))))) + +;;;_ , org-choose-keep-sensible (the trigger-hook function) +(defun org-choose-keep-sensible (change-plist) + "" + + (let* + ( (from (plist-get change-plist :from)) + (to (plist-get change-plist :to)) + (entry-pos + (set-marker + (make-marker) + (plist-get change-plist :position))) + (kwd-data + (assoc to org-todo-kwd-alist))) + (when + (eq (nth 1 kwd-data) 'choose) + (let* + ( + (data + (assoc to org-choose-mark-data)) + (keywords + (org-choose-mark-data.-all-keywords data)) + (old-index + (org-choose-get-index-in-keywords + from + keywords)) + (new-index + (org-choose-get-index-in-keywords + to + keywords)) + (highest-ok-ix + (org-choose-highest-other-ok + new-index + data)) + (funcdata + (cond + ;;The entry doesn't participate in conformance, + ;;so give `nil' which does nothing. + ((not highest-ok-ix) nil) + ;;The entry was created or promoted + ((or + (not old-index) + (> new-index old-index)) + (list + #'org-choose-conform-after-promotion + entry-pos keywords + highest-ok-ix)) + (t ;;Otherwise the entry was demoted. + (let + ( + (raise-to-ix + (min + highest-ok-ix + (org-choose-mark-data.-static-default + data))) + (old-highest-ok-ix + (org-choose-highest-other-ok + old-index + data))) + + (list + #'org-choose-conform-after-demotion + entry-pos + keywords + raise-to-ix + old-highest-ok-ix)))))) + + (if funcdata + ;;The funny-looking names are to make variable capture + ;;unlikely. (Poor-man's lexical bindings). + (destructuring-bind (func-d473 . args-46k) funcdata + (let + ((map-over-entries + (org-choose-get-fn-map-group)) + ;;We may call `org-todo', so let various hooks + ;;`nil' so we don't cause loops. + org-after-todo-state-change-hook + org-trigger-hook + org-blocker-hook + org-todo-get-default-hook + ;;Also let this alist `nil' so we don't log + ;;secondary transitions. + org-todo-log-states) + ;;Map over group + (funcall map-over-entries + #'(lambda () + (apply func-d473 args-46k)))))))) + + ;;Remove the marker + (set-marker entry-pos nil))) + + + +;;;_ , Getting the default mark +;;;_ . org-choose-get-index-in-keywords +(defun org-choose-get-index-in-keywords (ix all-keywords) + "Return index of current entry." + (if ix + (position ix all-keywords + :test #'equal))) + +;;;_ . org-choose-get-entry-index +(defun org-choose-get-entry-index (all-keywords) + "Return index of current entry." + + (let* + ((state (org-entry-get (point) "TODO"))) + (org-choose-get-index-in-keywords state all-keywords))) + +;;;_ . org-choose-get-fn-map-group + +(defun org-choose-get-fn-map-group () + "Return a function to map over the group" + + #'(lambda (fn) + (save-excursion + (outline-up-heading-all 1) + (save-restriction + (org-map-entries fn nil 'tree))))) + +;;;_ . org-choose-get-highest-mark-index + +(defun org-choose-get-highest-mark-index (keywords) + "Get the index of the highest current mark in the group. +If there is none, return 0" + + (let* + ( + ;;Func maps over applicable entries. + (map-over-entries + (org-choose-get-fn-map-group)) + + (indexes-list + (remove nil + (funcall map-over-entries + #'(lambda () + (org-choose-get-entry-index keywords)))))) + (if + indexes-list + (apply #'max indexes-list) + 0))) + + +;;;_ . org-choose-highest-ok + +(defun org-choose-highest-other-ok (ix data) + "" + + (let + ( + (bot-lower-range + (org-choose-mark-data.-bot-lower-range data)) + (top-upper-range + (org-choose-mark-data.-top-upper-range data)) + (range-length + (org-choose-mark-data.-range-length data))) + (when (and ix bot-lower-range) + (let* + ((delta + (- top-upper-range ix))) + (unless + (< range-length delta) + (+ bot-lower-range delta)))))) + +;;;_ . org-choose-get-default-mark-index + +(defun org-choose-get-default-mark-index (data) + "Get the index of the default mark in a choose interpretation. + +Args are in the same order as the fields of +`org-choose-mark-data.' and have the same meaning." + + (or + (let + ((highest-mark-index + (org-choose-get-highest-mark-index + (org-choose-mark-data.-all-keywords data)))) + (org-choose-highest-other-ok + highest-mark-index data)) + (org-choose-mark-data.-static-default data))) + + + +;;;_ . org-choose-get-mark-N +(defun org-choose-get-mark-N (n data) + "Get the text of the nth mark in a choose interpretation." + + (let* + ((l (org-choose-mark-data.-all-keywords data))) + (nth n l))) + +;;;_ . org-choose-get-default-mark + +(defun org-choose-get-default-mark (new-mark old-mark) + "Get the default mark IFF in a choose interpretation. +NEW-MARK and OLD-MARK are the text of the new and old marks." + + (let* + ( + (old-kwd-data + (assoc old-mark org-todo-kwd-alist)) + (new-kwd-data + (assoc new-mark org-todo-kwd-alist)) + (becomes-choose + (and + (or + (not old-kwd-data) + (not + (eq (nth 1 old-kwd-data) 'choose))) + (eq (nth 1 new-kwd-data) 'choose)))) + (when + becomes-choose + (let + ((new-mark-data + (assoc new-mark org-choose-mark-data))) + (if + new-mark + (org-choose-get-mark-N + (org-choose-get-default-mark-index + new-mark-data) + new-mark-data) + (error "Somehow got an unrecognizable mark")))))) + +;;;_ , Setting it all up + +(eval-after-load 'org + '(progn + (add-to-list 'org-todo-setup-filter-hook + #'org-choose-setup-filter) + (add-to-list 'org-todo-get-default-hook + #'org-choose-get-default-mark) + (add-to-list 'org-trigger-hook + #'org-choose-keep-sensible) + (add-to-list 'org-todo-interpretation-widgets + '(:tag "Choose (to record decisions)" choose)) +; CD (add-to-list 'org-todo-normal-interpretations 'choose)) + )) + + + +;;;_. Footers +;;;_ , Provides + +(provide 'org-choose) + +;;;_ * Local emacs vars. +;;;_ + Local variables: +;;;_ + End: + +;;;_ , End +;;; org-choose.el ends here diff --git a/lisp/org.el b/lisp/org.el index 82db6fcbf..21aa09a8e 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -181,6 +181,7 @@ to add the symbol `xyz', and the package must have a call to (const :tag "C annotation-helper: Call Remember directly from Browser" org-annotation-helper) (const :tag "C bookmark: Org links to bookmarks" org-bookmark) (const :tag "C browser-url: Store link, directly from Browser" org-browser-url) + (const :tag "C choose: Use TODO keywords to mark decisions states" org-choose) (const :tag "C depend: TODO dependencies for Org-mode" org-depend) (const :tag "C elisp-symbol: Org links to emacs-lisp symbols" org-elisp-symbol) (const :tag "C eval: Include command output as text" org-eval) @@ -1483,6 +1484,14 @@ fast, while still showing the whole path to the entry." :tag "Org Progress" :group 'org-time) +(defvar org-todo-interpretation-widgets + '( + (:tag "Sequence (cycling hits every state)" sequence) + (:tag "Type (cycling directly to DONE)" type)) + "The available interpretation symbols for customizing + `org-todo-keywords'. + Interested libraries should add to this list.") + (defcustom org-todo-keywords '((sequence "TODO" "DONE")) "List of TODO entry keyword sequences and their interpretation. \\This is a list of sequences. @@ -1532,8 +1541,18 @@ taken from the (otherwise obsolete) variable `org-todo-interpretation'." (cons (choice :tag "Interpretation" - (const :tag "Sequence (cycling hits every state)" sequence) - (const :tag "Type (cycling directly to DONE)" type)) + ;;Quick and dirty way to see + ;;`org-todo-interpretations'. This takes the + ;;place of item arguments + :convert-widget + (lambda (widget) + (widget-put widget + :args (mapcar + #'(lambda (x) + (widget-convert + (cons 'const x))) + org-todo-interpretation-widgets)) + widget)) (repeat (string :tag "Keyword")))))) @@ -3174,7 +3193,7 @@ means to push this value onto the list in the variable.") (org-set-local 'org-file-properties nil) (org-set-local 'org-file-tags nil) (let ((re (org-make-options-regexp - '("CATEGORY" "SEQ_TODO" "TYP_TODO" "TODO" "COLUMNS" + '("CATEGORY" "SEQ_TODO" "TYP_TODO" "TODO" "CHOOSE_TODO" "COLUMNS" "STARTUP" "ARCHIVE" "FILETAGS" "TAGS" "LINK" "PRIORITIES" "CONSTANTS" "PROPERTY" "DRAWERS" "SETUPFILE"))) (splitre "[ \t]+") @@ -3201,6 +3220,8 @@ means to push this value onto the list in the variable.") (push (cons 'sequence (org-split-string value splitre)) kwds)) ((equal key "TYP_TODO") (push (cons 'type (org-split-string value splitre)) kwds)) + ((equal key "CHOOSE_TODO") + (push (cons 'choose (org-split-string value splitre)) kwds)) ((equal key "TAGS") (setq tags (append tags (org-split-string value splitre)))) ((equal key "COLUMNS") @@ -3282,28 +3303,32 @@ means to push this value onto the list in the variable.") (setq kwds (nreverse kwds)) (let (inter kws kw) (while (setq kws (pop kwds)) - (setq inter (pop kws) sep (member "|" kws) - kws0 (delete "|" (copy-sequence kws)) - kwsa nil - kws1 (mapcar - (lambda (x) - ;; 1 2 - (if (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?.*?)\\)?$" x) - (progn - (setq kw (match-string 1 x) - key (and (match-end 2) (match-string 2 x)) - log (org-extract-log-state-settings x)) - (push (cons kw (and key (string-to-char key))) kwsa) - (and log (push log org-todo-log-states)) - kw) - (error "Invalid TODO keyword %s" x))) - kws0) - kwsa (if kwsa (append '((:startgroup)) - (nreverse kwsa) - '((:endgroup)))) - hw (car kws1) - dws (if sep (org-remove-keyword-keys (cdr sep)) (last kws1)) - tail (list inter hw (car dws) (org-last dws))) + (let ((kws (or + (run-hook-with-args-until-success + 'org-todo-setup-filter-hook kws) + kws))) + (setq inter (pop kws) sep (member "|" kws) + kws0 (delete "|" (copy-sequence kws)) + kwsa nil + kws1 (mapcar + (lambda (x) + ;; 1 2 + (if (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?.*?)\\)?$" x) + (progn + (setq kw (match-string 1 x) + key (and (match-end 2) (match-string 2 x)) + log (org-extract-log-state-settings x)) + (push (cons kw (and key (string-to-char key))) kwsa) + (and log (push log org-todo-log-states)) + kw) + (error "Invalid TODO keyword %s" x))) + kws0) + kwsa (if kwsa (append '((:startgroup)) + (nreverse kwsa) + '((:endgroup)))) + hw (car kws1) + dws (if sep (org-remove-keyword-keys (cdr sep)) (last kws1)) + tail (list inter hw (car dws) (org-last dws)))) (add-to-list 'org-todo-heads hw 'append) (push kws1 org-todo-sets) (setq org-done-keywords (append org-done-keywords dws nil)) @@ -5126,11 +5151,19 @@ state (TODO by default). Also with prefix arg, force first state." (org-back-to-heading) (outline-previous-heading) (looking-at org-todo-line-regexp)) - (if (or arg - (not (match-beginning 2)) - (member (match-string 2) org-done-keywords)) - (insert (car org-todo-keywords-1) " ") - (insert (match-string 2) " ")) + (let* + ((new-mark-x + (if (or arg + (not (match-beginning 2)) + (member (match-string 2) org-done-keywords)) + (car org-todo-keywords-1) + (match-string 2))) + (new-mark + (or + (run-hook-with-args-until-success + 'org-todo-get-default-hook new-mark-x nil) + new-mark-x))) + (insert new-mark " ")) (when org-provide-todo-statistics (org-update-parent-todo-statistics)))) @@ -8357,6 +8390,18 @@ this is nil.") (push (nth 2 e) rtn))) rtn))))) +(defvar org-todo-setup-filter-hook nil + "Hook for functions that pre-filter todo specs. + +Each function takes a todo spec and returns either `nil' or the spec +transformed into canonical form." ) + +(defvar org-todo-get-default-hook nil + "Hook for functions that get a default item for todo. + +Each function takes arguments (NEW-MARK OLD-MARK) and returns either +`nil' or a string to be used for the todo mark." ) + (defvar org-agenda-headline-snapshot-before-repeat) (defun org-todo (&optional arg) "Change the TODO state of an item. @@ -8462,15 +8507,18 @@ For calling through lisp, arg is also interpreted in the following way: ((null member) (or head (car org-todo-keywords-1))) ((equal this final-done-word) nil) ;; -> make empty ((null tail) nil) ;; -> first entry - ((eq interpret 'sequence) - (car tail)) ((memq interpret '(type priority)) (if (eq this-command last-command) (car tail) (if (> (length tail) 0) (or done-word (car org-done-keywords)) nil))) - (t nil))) + (t + (car tail)))) + (state (or + (run-hook-with-args-until-success + 'org-todo-get-default-hook state last-state) + state)) (next (if state (concat " " state " ") " ")) (change-plist (list :type 'todo-state-change :from this :to state :position startpos))