* Re: Advice sought on managing decision alternatives.
2009-02-07 0:18 ` Carsten Dominik
@ 2009-02-07 20:46 ` Tom Breton (Tehom)
2009-02-08 13:06 ` Carsten Dominik
0 siblings, 1 reply; 2+ messages in thread
From: Tom Breton (Tehom) @ 2009-02-07 20:46 UTC (permalink / raw)
Cc: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 1678 bytes --]
Hi, Carsten. Here is the new patch to org.el and the new
org-choose.el
A couple of notes:
* As we talked about, "decisions" and "chosenness" are now called
"choose" everywhere.
* I was able to add the library-aware customization we talked about.
* I also added new variable `org-todo-normal-interpretations' - see
explanation below.
* New test file. Essentially the same, with name replacement.
* Didn't append the example files; they are all unchanged from before.
******* About `org-todo-normal-interpretations'
You said your idea was to make a generally useful system. I noticed
that one thing was still hard-coded. It's the part of org-todo that
finds the next entry:
(memq interpret '(sequence choose))
...
(memq interpret '(type priority))
If I understand your intentions correctly, new TODO modules should
always behave like `sequence' in this respect. So the first line now
looks at a variable list.
I saw two possible approaches to get this list:
* Extract the symbol from `org-todo-interpretations'. It's in there,
but:
* Con: Of the two obvious ways to extract it, neither is good
1. Parse the widget form the way that wid-edit does, which is
hairy
2. Have a policy that every module that adds to it has to put the
symbol first, which changes the appearance of widgets and
invites mistakes.
* Add yet another variable to contain all the "normal" interpretation
symbols.
I have tentatively chosen the second and coded it. I named the
variable `org-todo-normal-interpretations' (as always, feel free to
suggest a better name).
Tom Breton (Tehom)
[-- Attachment #2: org.el.diff --]
[-- Type: application/octet-stream, Size: 6650 bytes --]
*** old-org.el 2009-01-04 03:01:50.000000000 -0500
--- org.el 2009-02-07 15:13:57.000000000 -0500
***************
*** 1409,1414 ****
--- 1409,1426 ----
: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." )
+ (defvar org-todo-normal-interpretations
+ '(sequence)
+ "" )
+
(defcustom org-todo-keywords '((sequence "TODO" "DONE"))
"List of TODO entry keyword sequences and their interpretation.
\\<org-mode-map>This is a list of sequences.
***************
*** 1458,1465 ****
(cons
(choice
:tag "Interpretation"
! (const :tag "Sequence (cycling hits every state)" sequence)
! (const :tag "Type (cycling directly to DONE)" type))
(repeat
(string :tag "Keyword"))))))
--- 1470,1487 ----
(cons
(choice
:tag "Interpretation"
! ;;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"))))))
***************
*** 3025,3031 ****
(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"
"STARTUP" "ARCHIVE" "FILETAGS" "TAGS" "LINK" "PRIORITIES"
"CONSTANTS" "PROPERTY" "DRAWERS" "SETUPFILE")))
(splitre "[ \t]+")
--- 3047,3053 ----
(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" "CHOOSE_TODO" "COLUMNS"
"STARTUP" "ARCHIVE" "FILETAGS" "TAGS" "LINK" "PRIORITIES"
"CONSTANTS" "PROPERTY" "DRAWERS" "SETUPFILE")))
(splitre "[ \t]+")
***************
*** 3052,3057 ****
--- 3074,3081 ----
(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")
***************
*** 3133,3138 ****
--- 3157,3168 ----
(setq kwds (nreverse kwds))
(let (inter kws kw)
(while (setq kws (pop kwds))
+ (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
***************
*** 3154,3160 ****
'((: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))
--- 3184,3190 ----
'((: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))
***************
*** 4934,4944 ****
(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) " "))
(when org-provide-todo-statistics
(org-update-parent-todo-statistics))))
--- 4964,4983 ----
(org-back-to-heading)
(outline-previous-heading)
(looking-at org-todo-line-regexp))
+ (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))))
***************
*** 8190,8195 ****
--- 8229,8246 ----
:from previous state (keyword as a string), or nil
:to new state (keyword as a string), or nil")
+ (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.
***************
*** 8285,8291 ****
((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)
--- 8336,8342 ----
((null member) (or head (car org-todo-keywords-1)))
((equal this final-done-word) nil) ;; -> make empty
((null tail) nil) ;; -> first entry
! ((memq interpret org-todo-normal-interpretations)
(car tail))
((memq interpret '(type priority))
(if (eq this-command last-command)
***************
*** 8294,8299 ****
--- 8345,8354 ----
(or done-word (car org-done-keywords))
nil)))
(t nil)))
+ (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))
[-- Attachment #3: org-choose.el --]
[-- Type: application/octet-stream, Size: 12531 bytes --]
;;;_ 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))
(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
[-- Attachment #4: test-org-choose.el --]
[-- Type: application/octet-stream, Size: 45687 bytes --]
;;;_ test-org-choose.el --- Test code for org-choose
;;;_. Headers
;;;_ , License
;; Copyright (C) 2009 Tom Breton (Tehom)
;; Author: Tom Breton (Tehom) <tehom@localhost.localdomain>
;; Keywords: lisp
;; 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 'rtest-define)
(require 'mockbuf)
(require 'el-mock)
(require 'org)
(require 'org-id)
(require 'org-choose)
;;;_. Body
;;;_ , Example files
(defconst test-org-choose:th:examples-dir
(rtest:expand-filename-by-load-file "examples")
"Directory where examples are" )
(rtest:defexample test-org-choose:thd:file-simple
(expand-file-name "simple.org"
test-org-choose:th:examples-dir))
(rtest:defexample test-org-choose:thd:file-w-1-chosen
(expand-file-name "w-1-chosen.org"
test-org-choose:th:examples-dir))
(rtest:defexample test-org-choose:thd:file-nonautomatic
(expand-file-name "nonautomatic.org"
test-org-choose:th:examples-dir))
(rtest:defexample test-org-choose:thd:file-w-2-types
(expand-file-name "w-2-types.org"
test-org-choose:th:examples-dir))
(rtest:defexample test-org-choose:thd:file-w-some-nils
(expand-file-name "w-some-nils.org"
test-org-choose:th:examples-dir))
(rtest:defexample test-org-choose:thd:file-nosibs
(expand-file-name "no-sibs.org"
test-org-choose:th:examples-dir))
(rtest:defexample test-org-choose:thd:nofile-1-list-o-marks
'("REJECTED" "NOT_CHOSEN" "MAYBE" "LEANING_TOWARDS" "CHOSEN"))
(rtest:defexample test-org-choose:thd:nofile-1-raw-marks
'(choose "REJECTED" "NOT_CHOSEN" "MAYBE" "LEANING_TOWARDS" "CHOSEN")
"Raw marks")
(rtest:defexample test-org-choose:thd:nofile-1-output-marks
'(choose "REJECTED" "NOT_CHOSEN" "MAYBE" "LEANING_TOWARDS" "CHOSEN")
"Output marks")
(rtest:defexample test-org-choose:thd:nofile-1-setup-args
(list nil nil nil 5 test-org-choose:thd:nofile-1-list-o-marks)
"Arguments given to org-choose-setup-vars"
)
(rtest:defexample test-org-choose:thd:nofile-1-mark-data
(mapcar
#'(lambda (x)
(make-org-choose-mark-data.
:keyword x
:bot-lower-range nil
:top-upper-range nil
:range-length nil
:static-default 0
:all-keywords test-org-choose:thd:nofile-1-list-o-marks))
test-org-choose:thd:nofile-1-list-o-marks)
"The mark data corresponding to nofile-1")
(rtest:defexample test-org-choose:thd:nofile-2-list-o-marks
'("ZERO" "ONE" "TWO" "THREE" "FOUR" "FIVE" "SIX"))
(rtest:defexample test-org-choose:thd:nofile-2-raw-marks
'(choose "ZERO" "ONE" "TWO(b)" "THREE(c,-)" "FOUR(d,0)"
"FIVE(e,+)" "SIX(,)")
"Raw marks")
(rtest:defexample test-org-choose:thd:nofile-2-output-marks
'(choose "ZERO" "ONE" "TWO(b)" "THREE(c)" "FOUR(d)"
"FIVE(e)" "SIX")
"Output marks")
(rtest:defexample test-org-choose:thd:nofile-2-setup-args
(list 3 5 4 7 test-org-choose:thd:nofile-2-list-o-marks)
"Arguments given to org-choose-setup-vars"
)
(rtest:defexample test-org-choose:thd:nofile-2-mark-data
(mapcar
#'(lambda (x)
(make-org-choose-mark-data.
:keyword x
:bot-lower-range 3
:top-upper-range 5
:range-length 1
:static-default 4
:all-keywords
test-org-choose:thd:nofile-2-list-o-marks))
test-org-choose:thd:nofile-2-list-o-marks)
"The mark data corresponding to nofile example 2")
;;An example of one that's not automatically managed
(rtest:defexample test-org-choose:thd:nofile-3-raw-marks
'(sequence "ZERO" "ONE" "TWO(b)" "THREE(c)" "FOUR(d)"
"FIVE(e)" "SIX")
"Input marks")
(rtest:defexample test-org-choose:thd:nofile-3-output-marks
nil
"Output marks")
;;An example where the top of the range is implicit
(rtest:defexample test-org-choose:thd:nofile-4-list-o-marks
'("ZERO" "ONE" "TWO" "THREE" "FOUR" "FIVE" "SIX"))
(rtest:defexample test-org-choose:thd:nofile-4-raw-marks
'(choose "ZERO" "ONE" "TWO(b)" "THREE(c,-)" "FOUR(d,0)"
"FIVE(e)" "SIX")
"Input marks")
(rtest:defexample test-org-choose:thd:nofile-4-setup-args
(list 3 nil 4 7 test-org-choose:thd:nofile-4-list-o-marks)
"Arguments given to org-choose-setup-vars")
(rtest:defexample test-org-choose:thd:nofile-4-mark-data
(mapcar
#'(lambda (x)
(make-org-choose-mark-data.
:keyword x
:bot-lower-range 3
:top-upper-range 6
:range-length 2
:static-default 4
:all-keywords
test-org-choose:thd:nofile-4-list-o-marks))
test-org-choose:thd:nofile-4-list-o-marks)
"The mark data corresponding to nofile example 2")
(rtest:defexample test-org-choose:thd:nofile-4-kwd-alist
(mapcar
#'(lambda (x)
;;(KEY interpretation head done-word final-done-word)
(list x 'choose "ZERO" "SIX" "SIX"))
test-org-choose:thd:nofile-4-list-o-marks))
(rtest:defexample test-org-choose:thd:file-simple-list-o-marks
'("REJECTED" "NOT_CHOSEN" "MAYBE" "LEANING_TOWARDS" "CHOSEN"))
(rtest:defexample test-org-choose:thd:file-simple-setup-args
(list 1 4 2 5 test-org-choose:thd:file-simple-list-o-marks)
"Arguments given to org-choose-setup-vars"
)
(rtest:defexample test-org-choose:thd:file-simple-mark-data
(mapcar
#'(lambda (x)
(make-org-choose-mark-data.
:keyword x
:bot-lower-range 1
:top-upper-range 4
:range-length 2
:static-default 2
:all-keywords
test-org-choose:thd:file-simple-list-o-marks))
test-org-choose:thd:file-simple-list-o-marks)
"The mark data corresponding to file1")
(rtest:defexample test-org-choose:thd:file-simple-high-ix
3)
(rtest:defexample test-org-choose:thd:file-simple-sib-maybe-id
"67a7cbba-c78b-47fe-886a-08a80f67e4ab"
"ID of a sibling")
(rtest:defexample test-org-choose:thd:file-simple-sib-maybe-ix
2
"Mark index of that sibling")
(rtest:defexample test-org-choose:thd:file-simple-sib-rejected-id
"953d4524-f15e-4198-ab33-5769732f51ad"
"ID of another sibling")
(rtest:defexample test-org-choose:thd:file-simple-sib-leaning-id
"be01f611-6175-4e40-a3b5-525a9c1e3b4d"
"ID of another sibling")
(rtest:defexample test-org-choose:thd:file-simple-sib-not-chosen-id
"b7760ac9-e0bf-41a0-9661-720d42670432"
"ID of another sibling")
(rtest:defexample test-org-choose:thd:file-simple-parent-id
"a13a4b6f-02d6-445c-a38e-7e51b9ba29d4"
"ID of the parent of those nodes")
(rtest:defexample test-org-choose:thd:file-simple-original-marks
'("MAYBE""REJECTED""LEANING_TOWARDS""NOT_CHOSEN"))
(rtest:defexample test-org-choose:thd:file-w-1-chosen-mark-data
test-org-choose:thd:file-simple-mark-data)
(rtest:defexample test-org-choose:thd:file-w-1-chosen-high-ix
4)
(rtest:defexample test-org-choose:thd:file-w-1-chosen-sib-not-chosen-a-id
"b390f9b1-57d0-4a17-9811-47b49fee196f"
"ID of a not-chosen sibling")
(rtest:defexample test-org-choose:thd:file-w-1-chosen-sib-maybe-id
"5a449704-494c-412f-b21d-8ffe07b8092c"
"ID of another not-chosen sibling")
(rtest:defexample test-org-choose:thd:file-w-1-chosen-sib-chosen-id
"c0958364-1f99-4dfc-a671-f21bb5f708bb"
"ID of the chosen sibling")
(rtest:defexample test-org-choose:thd:file-w-1-chosen-parent-id
"b2a6f78c-6199-461b-9850-18980b85b1ab")
(rtest:defexample test-org-choose:thd:file-w-1-chosen-list-o-marks
test-org-choose:thd:file-simple-list-o-marks)
(rtest:defexample test-org-choose:thd:file-w-1-chosen-original-marks
'("NOT_CHOSEN" "REJECTED" "CHOSEN " "MAYBE"))
(rtest:defexample test-org-choose:thd:file-nonautomatic-list-o-marks
'("NO" "MAYBE_YN" "YES"))
(rtest:defexample test-org-choose:thd:file-nonautomatic-raw-marks
'(choose "NO" "MAYBE_YN(,0)" "YES"))
(rtest:defexample test-org-choose:thd:file-nonautomatic-setup-args
(list nil nil 1 3 test-org-choose:thd:file-nonautomatic-list-o-marks)
"Arguments given to org-choose-setup-vars")
(rtest:defexample test-org-choose:thd:file-nonautomatic-high-ix
2)
(rtest:defexample test-org-choose:thd:file-nonautomatic-sib-yes-id
"6a27cc97-6e65-4c4e-9014-7fbcf27f52fa")
(rtest:defexample test-org-choose:thd:file-nonautomatic-mark-data
(mapcar
#'(lambda (x)
(make-org-choose-mark-data.
:keyword x
:bot-lower-range nil
:top-upper-range nil
:range-length nil
:static-default 1
:all-keywords
test-org-choose:thd:file-nonautomatic-list-o-marks)
)
test-org-choose:thd:file-nonautomatic-list-o-marks)
"The mark data corresponding to file3")
(rtest:defexample test-org-choose:thd:context:kwd-alist-normal-todo
(mapcar
#'(lambda (x)
;;(KEY interpretation head done-word final-done-word)
(list x 'sequence "TODO" "DONE" "DONE"))
'("TODO" "DONE"))
"A kwd-alist that includes only the 2 normal TODO marks.
NB, this is context. It is not *produced* by any test code, it is
used to control what marks are understood."
)
(rtest:defexample test-org-choose:thd:context:kwd-alist
(append
test-org-choose:thd:context:kwd-alist-normal-todo
(mapcar
#'(lambda (x)
;;(KEY interpretation head done-word final-done-word)
(list x 'choose "NO" "YES" "YES"))
test-org-choose:thd:file-nonautomatic-list-o-marks))
"A kwd-alist to combines 2 normal TODO marks and the
file-nonautomatic marks.
NB, this is not *produced* by any test code, it is used to control
what marks are understood."
)
(rtest:defexample test-org-choose:thd:context:kwd-alist-simple
(append
test-org-choose:thd:context:kwd-alist-normal-todo
(mapcar
#'(lambda (x)
;;(KEY interpretation head done-word final-done-word)
(list x 'choose "REJECTED" "CHOSEN" "CHOSEN"))
test-org-choose:thd:file-simple-list-o-marks))
"A kwd-alist that includes the marks in simple.org plus 2 normal TODO marks.
NB, this is context. It is not *produced* by any test code, it is
used to control what marks are understood."
)
(rtest:defexample test-org-choose:thd:file-w-2-types-mark-data
(append
test-org-choose:thd:file-simple-mark-data
test-org-choose:thd:file-nonautomatic-mark-data))
(rtest:defexample test-org-choose:thd:file-w-2-types-t1-high-ix
3)
(rtest:defexample test-org-choose:thd:file-w-2-types-t1-leaning-id
"c8e7d7af-15a2-4650-a604-50ade52bd06c")
(rtest:defexample test-org-choose:thd:file-w-2-types-t1-list-o-marks
'("REJECTED" "NOT_CHOSEN" "MAYBE" "LEANING_TOWARDS" "CHOSEN"))
(rtest:defexample test-org-choose:thd:file-w-2-types-t2-high-ix
2)
(rtest:defexample test-org-choose:thd:file-w-2-types-t2-yes-id
"02e917f5-ac3d-477f-baf5-7eb7c8961683")
(rtest:defexample test-org-choose:thd:file-w-2-types-t2-list-o-marks
'("YES" "MAYBE_YN" "NO"))
(rtest:defexample test-org-choose:thd:file-w-some-nils-high-ix
4)
(rtest:defexample test-org-choose:thd:file-w-some-nils-sib-marked-id
"a4e52131-1145-49f5-8b4b-dc4264900a05")
(rtest:defexample test-org-choose:thd:file-w-some-nils-sib-nil-id
"d9729468-db22-4870-8969-9500da63d560")
(rtest:defexample test-org-choose:thd:file-w-some-nils-list-o-marks
'("REJECTED" "NOT_CHOSEN" "MAYBE" "LEANING_TOWARDS" "CHOSEN"))
(rtest:defexample test-org-choose:thd:file-nosibs-sib
"78fb63fa-4fad-4c7f-aa4a-954ee3431754")
(rtest:defexample test-org-choose:thd:file-nosibs-high-ix
0)
;;;_ , Tests of org-choose-filter-one
(rtest:defexample test-org-choose:thd:singlemark-1-input-output
'("ONE(,0)" ("ONE" "ONE" default-mark))
"Pairs of single marks: Input and output"
)
(rtest:defexample test-org-choose:thd:singlemark-2-input-output
'("TWO" ("TWO" "TWO"))
"Pairs of single marks: Input and output"
)
(rtest:defexample test-org-choose:thd:singlemark-3-input-output
'("THREE(b)" ("THREE" "THREE(b)"))
"Pairs of single marks: Input and output")
(rtest:defexample test-org-choose:thd:singlemark-4-input-output
'("FOUR(c,0)" ("FOUR" "FOUR(c)" default-mark))
"Pairs of single marks: Input and output")
(rtest:defexample test-org-choose:thd:singlemark-5-input-output
'("FIVE(d,+)" ("FIVE" "FIVE(d)" top-upper-range))
"Pairs of single marks: Input and output")
(rtest:defexample test-org-choose:thd:singlemark-6-input-output
'("SIX(e,-)" ("SIX" "SIX(e)" bot-lower-range))
"Pairs of single marks: Input and output")
(rtest:defexample test-org-choose:thd:singlemark-7-input-output
'("SEVEN(,)" ("SEVEN" "SEVEN"))
"Pairs of single marks: Input and output")
(rtest:defexample test-org-choose:thd:singlemark-8-input-output
'("EIGHT(x!/@,)" ("EIGHT" "EIGHT(x!/@)"))
"Pairs of single marks: Input and output")
(rtest:deftest org-choose-filter-one
( "Does the examples correctly."
(equal
(org-choose-filter-one
(car test-org-choose:thd:singlemark-1-input-output))
(second
test-org-choose:thd:singlemark-1-input-output)))
( "Does the examples correctly."
(equal
(org-choose-filter-one
(car test-org-choose:thd:singlemark-2-input-output))
(second
test-org-choose:thd:singlemark-2-input-output)))
( "Does the examples correctly."
(equal
(org-choose-filter-one
(car test-org-choose:thd:singlemark-3-input-output))
(second
test-org-choose:thd:singlemark-3-input-output)))
( "Does the examples correctly."
(equal
(org-choose-filter-one
(car test-org-choose:thd:singlemark-4-input-output))
(second
test-org-choose:thd:singlemark-4-input-output)))
( "Does the examples correctly."
(equal
(org-choose-filter-one
(car test-org-choose:thd:singlemark-5-input-output))
(second
test-org-choose:thd:singlemark-5-input-output)))
( "Does the examples correctly."
(equal
(org-choose-filter-one
(car test-org-choose:thd:singlemark-6-input-output))
(second
test-org-choose:thd:singlemark-6-input-output)))
( "Does the examples correctly."
(equal
(org-choose-filter-one
(car test-org-choose:thd:singlemark-7-input-output))
(second
test-org-choose:thd:singlemark-7-input-output)))
( "Does the examples correctly."
(equal
(org-choose-filter-one
(car test-org-choose:thd:singlemark-8-input-output))
(second
test-org-choose:thd:singlemark-8-input-output)))
)
;;;_ , Tests of org-choose-setup-vars
(rtest:deftest org-choose-setup-vars
( "The `*-setup-args' examples are proper args to
`org-choose-setup-vars'. It sets org-choose-mark-data
correspondingly."
(with-temp-buffer
(apply #'org-choose-setup-vars
test-org-choose:thd:nofile-1-setup-args)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:nofile-1-mark-data)))
( "The `*-setup-args' examples are proper args to
`org-choose-setup-vars'. It sets org-choose-mark-data
correspondingly."
(with-temp-buffer
(apply #'org-choose-setup-vars
test-org-choose:thd:nofile-2-setup-args)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:nofile-2-mark-data)))
( "The `*-setup-args' examples are proper args to
`org-choose-setup-vars'. It sets org-choose-mark-data
correspondingly."
(with-temp-buffer
(apply #'org-choose-setup-vars
test-org-choose:thd:nofile-4-setup-args)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:nofile-4-mark-data)))
( "The `*-setup-args' examples are proper args to
`org-choose-setup-vars'. It sets org-choose-mark-data
correspondingly."
(with-temp-buffer
(apply #'org-choose-setup-vars
test-org-choose:thd:file-simple-setup-args)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:file-simple-mark-data)))
( "The `*-setup-args' examples are proper args to
`org-choose-setup-vars'. It sets org-choose-mark-data
correspondingly."
(with-temp-buffer
(apply #'org-choose-setup-vars
test-org-choose:thd:file-nonautomatic-setup-args)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:file-nonautomatic-mark-data)))
)
;;;_ , Tests of the setup filter
(rtest:deftest org-choose-setup-filter
;;I'd like to have also tested that output is conformant. But
;;AFAICT no existing predicate reports that, so I'll only test that
;;output matches what's expected, which I'll eyeball.
( "Situation: Called manually, passed data with another interpretation.
Response: Return value is `nil'."
(equal
(with-temp-buffer
(org-choose-setup-filter
test-org-choose:thd:nofile-3-raw-marks))
test-org-choose:thd:nofile-3-output-marks))
( "Situation: Called manually, passed known data.
Response: Return value is as expected."
(equal
(with-temp-buffer
(org-choose-setup-filter
test-org-choose:thd:nofile-1-raw-marks))
test-org-choose:thd:nofile-1-output-marks))
( "Situation: Called manually, passed known data.
Response: Return value is as expected."
(equal
(with-temp-buffer
(org-choose-setup-filter
test-org-choose:thd:nofile-2-raw-marks))
test-org-choose:thd:nofile-2-output-marks))
( "Situation: Called manually, passed known data.
Response: Variables have been set up as expected."
(with-temp-buffer
(org-choose-setup-filter
test-org-choose:thd:nofile-1-raw-marks)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:nofile-1-mark-data)))
( "Situation: Called manually, passed known data.
Response: Variables have been set up as expected."
(with-temp-buffer
(org-choose-setup-filter
test-org-choose:thd:nofile-2-raw-marks)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:nofile-2-mark-data)))
( "Situation: Called manually, passed known data.
Response: Variables have been set up as expected."
(with-temp-buffer
(org-choose-setup-filter
test-org-choose:thd:nofile-4-raw-marks)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:nofile-4-mark-data)))
( "Situation: In temp buffer, given the same marks as for file 3.
Response: `org-choose-mark-data' have been set up as expected."
(with-temp-buffer
(org-choose-setup-filter
test-org-choose:thd:file-nonautomatic-raw-marks)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:file-nonautomatic-mark-data)))
( "Situation: `org-choose-mark-data' has already been set with
marks from this set
Response: `org-choose-mark-data' gets the expected value and
nothing extra."
(with-temp-buffer
(let
((org-choose-mark-data
test-org-choose:thd:file-nonautomatic-mark-data))
(org-choose-setup-filter
test-org-choose:thd:file-nonautomatic-raw-marks)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:file-nonautomatic-mark-data))))
( "Situation: `org-choose-mark-data' has already been set with
marks from another set
Response: `org-choose-mark-data' gets the new marks and keeps the
marks from the other set."
(with-temp-buffer
(let
((org-choose-mark-data
test-org-choose:thd:file-simple-mark-data))
(org-choose-setup-filter
test-org-choose:thd:file-nonautomatic-raw-marks)
(rtest:sets=
org-choose-mark-data
(append
test-org-choose:thd:file-simple-mark-data
test-org-choose:thd:file-nonautomatic-mark-data)))))
;;Insinuated tests, so that setup filter is called automatically by
;;setup.
( "Situation: In example file 1.
Response: `org-choose-mark-data' gets the expected value."
(with-buffer-containing-object (:file test-org-choose:thd:file-simple)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:file-simple-mark-data)))
( "Situation: In example file 2.
Response: `org-choose-mark-data' gets the expected value."
(with-buffer-containing-object (:file test-org-choose:thd:file-w-1-chosen)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:file-w-1-chosen-mark-data)))
( "Situation: In example file 3.
Response: `org-choose-mark-data' gets the expected value."
(with-buffer-containing-object (:file test-org-choose:thd:file-nonautomatic)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:file-nonautomatic-mark-data)))
( "Situation: In example file 4.
Response: `org-choose-mark-data' gets the expected value."
(with-buffer-containing-object (:file test-org-choose:thd:file-w-2-types)
(rtest:sets=
org-choose-mark-data
test-org-choose:thd:file-w-2-types-mark-data))))
;;;_ , Tests of the function to get default
;;;_ . Test helper
;;;_ . org-choose:th:in-buffer-at
(defmacro* org-choose:th:in-buffer-at ((&key file id) &rest body)
""
`(with-buffer-containing-object
(:file ,file)
;;Have to show entries otherwise we might fail to go to them.
(show-all)
;;Go to one of the entries. Use `org-find-entry-with-id' so we
;;can't accidentally leave this file, as we could with
;;`org-id-find'.
(goto-char
(org-find-entry-with-id ,id))
,@body))
;;;_ , Tests
(put 'org-choose:th:in-buffer-at 'rtest:test-thru
'org-choose-get-entry-index)
;;;_ . org-choose-get-entry-index
(rtest:deftest org-choose-get-entry-index
;;These tests are tests after insinuation.
( "Situation: Point is in a marked entry.
Response: Return the index of that entry."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-maybe-id)
(equal
(org-choose-get-entry-index
test-org-choose:thd:file-simple-list-o-marks)
test-org-choose:thd:file-simple-sib-maybe-ix)))
( "Situation: Point is in a unmarked entry (nil).
Response: Return nil."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-some-nils
:id test-org-choose:thd:file-w-some-nils-sib-nil-id)
(equal
(org-choose-get-entry-index
test-org-choose:thd:file-w-some-nils-list-o-marks)
nil)))
( "Situation: Point is in an entry with a mark from a different set.
Response: Return nil."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-2-types
:id test-org-choose:thd:file-w-2-types-t2-yes-id)
(equal
(org-choose-get-entry-index
test-org-choose:thd:file-w-2-types-t1-list-o-marks)
nil)))
)
;;;_ . org-choose-get-highest-mark-index
(rtest:deftest org-choose-get-highest-mark-index
( "Situation: Point is in one of the sibling entries
Response: Returns the highest index."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-maybe-id)
(equal
(org-choose-get-highest-mark-index
test-org-choose:thd:file-simple-list-o-marks)
test-org-choose:thd:file-simple-high-ix)))
( "Situation: Point is in a different one of the sibling entries
Response: Returns the highest index."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-rejected-id)
(equal
(org-choose-get-highest-mark-index
test-org-choose:thd:file-simple-list-o-marks)
test-org-choose:thd:file-simple-high-ix)))
( "Situation: Point is in one of the sibling entries
Response: Returns the highest index."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-1-chosen
:id test-org-choose:thd:file-w-1-chosen-sib-not-chosen-a-id)
(equal
(org-choose-get-highest-mark-index
test-org-choose:thd:file-w-1-chosen-list-o-marks)
test-org-choose:thd:file-w-1-chosen-high-ix)))
( "Situation: Point is in one of the sibling entries
Response: Returns the highest index."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-nonautomatic
:id test-org-choose:thd:file-nonautomatic-sib-yes-id)
(equal
(org-choose-get-highest-mark-index
test-org-choose:thd:file-nonautomatic-list-o-marks)
test-org-choose:thd:file-nonautomatic-high-ix)))
( "Situation: Point is in one of the sibling entries of one type.
Response: Returns the highest index of siblings of that type, ignoring
the others."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-2-types
:id test-org-choose:thd:file-w-2-types-t1-leaning-id)
(equal
(org-choose-get-highest-mark-index
test-org-choose:thd:file-w-2-types-t1-list-o-marks)
test-org-choose:thd:file-w-2-types-t1-high-ix)))
( "Situation: Point is in one of the sibling entries of one type,
in a sibling group that has 2 types.
Response: Returns the highest index of siblings of that type, ignoring
the others."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-2-types
:id test-org-choose:thd:file-w-2-types-t2-yes-id)
(equal
(org-choose-get-highest-mark-index
test-org-choose:thd:file-w-2-types-t2-list-o-marks)
test-org-choose:thd:file-w-2-types-t2-high-ix)))
( "Situation: Point is in one of the sibling entries. Some
entries are nil.
Response: Returns the highest index, ignoring the `nil's."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-some-nils
:id test-org-choose:thd:file-w-some-nils-sib-marked-id)
(equal
(org-choose-get-highest-mark-index
test-org-choose:thd:file-w-some-nils-list-o-marks)
test-org-choose:thd:file-w-some-nils-high-ix)))
( "Situation: There are no entries of choose type.
Response: Return 0"
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-nosibs
:id test-org-choose:thd:file-nosibs-sib)
(equal
(org-choose-get-highest-mark-index
test-org-choose:thd:file-simple-list-o-marks)
0)))
)
;;;_ . org-choose-get-default-mark-index
(put 'org-choose-get-default-mark-index 'rtest:test-thru
'org-choose-get-default-mark)
;;;_ . org-choose-get-mark-N
(rtest:deftest org-choose-get-mark-N
( "Behavior: Gets the corresponding mark from the set."
(let
((org-choose-mark-data
test-org-choose:thd:nofile-4-mark-data))
(equal
(org-choose-get-mark-N 0
(assoc "ONE" org-choose-mark-data))
"ZERO")))
( "Behavior: Gets the corresponding mark from the set."
(let
((org-choose-mark-data
test-org-choose:thd:nofile-4-mark-data))
(equal
(org-choose-get-mark-N 4
(assoc "THREE" org-choose-mark-data))
"FOUR")))
)
;;;_ . org-choose-get-default-mark
;;;_ , Test helpers
(defun org-choose-get-default-mark-index:th (new-mark mark-data)
"Test helper"
(org-choose-get-default-mark-index
(assoc new-mark mark-data)))
(defun org-choose:th:collect-childrens-todo-marks (parent-id)
""
(save-excursion
(show-all) ;;In case anything got hidden
(goto-char
(org-find-entry-with-id
parent-id))
(save-restriction
(org-map-entries
#'(lambda ()
(org-entry-get (point) "TODO"))
nil 'tree))))
;;;_ . Tests of org-choose:th:collect-childrens-todo-marks
(rtest:deftest org-choose:th:collect-childrens-todo-marks
("Situation: In a known file.
Param: The id of the parent entry.
Response: Returns the TODO marks of the children."
(with-buffer-containing-object
(:file test-org-choose:thd:file-simple)
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
test-org-choose:thd:file-simple-original-marks))))
;;;_ , Tests
(rtest:deftest org-choose-get-default-mark
( "Situation: we're not going into a choose type
Response: Return nil, signalling to use the mark we were going to."
(let
((org-todo-kwd-alist
test-org-choose:thd:context:kwd-alist))
(equal
(org-choose-get-default-mark nil "DONE")
nil)))
( "Situation: We were already in a choose type.
Response: Return nil, signalling to use the mark we were going to."
(let
((org-todo-kwd-alist
test-org-choose:thd:context:kwd-alist))
(equal
(org-choose-get-default-mark "YES" "MAYBE_YN")
nil)))
;;These tests test the index return for
;;`org-choose-get-default-mark-index' and also test the string
;;return for `org-choose-get-default-mark'. Combining the tests
;;under `and' is not good style but I don't want to write each
;;setup twice.
( "Situation: there are no ranges.
Response: return the static default."
(let
((org-choose-mark-data
test-org-choose:thd:file-nonautomatic-mark-data)
(org-todo-kwd-alist
test-org-choose:thd:context:kwd-alist))
(with-mock
(stub org-choose-get-highest-mark-index => nil)
(and
(equal
(org-choose-get-default-mark-index:th "NO"
test-org-choose:thd:file-nonautomatic-mark-data)
1)
(equal
(org-choose-get-default-mark "NO" nil)
"MAYBE_YN")))))
( "Situation: no current mark is in the upper range.
Response: return the static default."
(let
((org-choose-mark-data
test-org-choose:thd:nofile-4-mark-data)
(org-todo-kwd-alist
test-org-choose:thd:nofile-4-kwd-alist))
(with-mock
(stub org-choose-get-highest-mark-index => 2)
(and
(equal
(org-choose-get-default-mark-index:th
"ONE"
test-org-choose:thd:nofile-4-mark-data)
4)
(equal
(org-choose-get-default-mark "ONE" nil)
"FOUR")
))))
;;Because the static default is at or above the top of lower range,
;;any mirror-wise constraint is a stronger constraint than it. So
;;no additional test is needed for the interaction between those
;;two constraints.
( "Situation: a current mark is in the upper range.
Response: return an accordingly lower index.."
(let
((org-choose-mark-data
test-org-choose:thd:nofile-4-mark-data)
(org-todo-kwd-alist
test-org-choose:thd:nofile-4-kwd-alist))
(with-mock
(stub org-choose-get-highest-mark-index => 6)
(and
(equal
(org-choose-get-default-mark-index:th
"ONE"
test-org-choose:thd:nofile-4-mark-data)
3)
(equal
(org-choose-get-default-mark "ONE" nil)
"THREE")))))
("Situation: Point is on a heading.
The only type of TODO in this buffer is a choose type.
The default type is MAYBE.
No sibling mark is higher than LEANING_TOWARDS.
Operation: Add a new todo heading.
Result: It then has the mark MAYBE."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-maybe-id)
(org-insert-todo-heading 1)
(equal
(org-entry-get (point) "TODO")
"MAYBE")))
("Situation: Point is on a heading with no mark.
The only type of TODO in this buffer is a choose type.
The default type is MAYBE.
No sibling mark is higher than LEANING_TOWARDS.
Operation: Add a todo mark to the heading.
Result: It then has the mark MAYBE."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-maybe-id)
(org-insert-heading)
(org-todo)
(equal
(org-entry-get (point) "TODO")
"MAYBE")))
("Situation: Point is on a heading.
The only type of TODO in this buffer is a choose type.
The default type is MAYBE.
A sibling mark is CHOSEN
The mark NOT_CHOSEN mirrors the mark CHOSEN.
Operation: Add a todo mark to the heading.
Result: It then has the mark NOT_CHOSEN."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-1-chosen
:id test-org-choose:thd:file-w-1-chosen-sib-not-chosen-a-id)
(org-insert-heading)
(org-todo)
(equal
(org-entry-get (point) "TODO")
"NOT_CHOSEN"))))
;;;_ , Tests of the trigger function
;;;_ . org-choose-conform-after-promotion
;;;_ , Test helper
(defun* org-choose-conform-after-promotion:th (&key file id
mark-data
other-was
other-changed-to
expect
demoted)
""
(org-choose:th:in-buffer-at
(:file file :id id)
(let*
(
(data
(or
(assoc other-changed-to mark-data)
(error
"Mark-data should contain the entry being changed to")))
(keywords
(org-choose-mark-data.-all-keywords data))
(index
(org-choose-get-index-in-keywords
other-changed-to keywords))
(old-index
(when other-was
(org-choose-get-index-in-keywords
other-was keywords))))
(if demoted
(org-choose-conform-after-demotion
0 ;;Fake position that matches nothing
keywords
(let
((new-highest
(org-choose-highest-other-ok index data))
(static-default
(org-choose-mark-data.-static-default data)))
(if new-highest
(min new-highest static-default)
static-default))
(org-choose-highest-other-ok old-index data))
(org-choose-conform-after-promotion
0 ;;Fake position that matches nothing
keywords
(org-choose-highest-other-ok index data))))
(equal
(org-entry-get (point) "TODO")
expect)))
;;;_ , Tests
(rtest:deftest org-choose-conform-after-promotion
( "Situation: Entry's mark is from some other workflow state.
Response: Do nothing."
(org-choose-conform-after-promotion:th
:file test-org-choose:thd:file-w-2-types
:id test-org-choose:thd:file-w-2-types-t2-yes-id
:mark-data test-org-choose:thd:file-w-2-types-mark-data
:other-changed-to "CHOSEN"
:expect "YES"))
( "Situation: Entry's mark is already lower than the highest allowed index.
Response: No change."
(org-choose-conform-after-promotion:th
:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-rejected-id
:mark-data test-org-choose:thd:file-simple-mark-data
:other-changed-to "CHOSEN"
:expect "REJECTED"))
( "Situation: Entry's mark is higher than the highest allowed index.
Response: Demote it."
(org-choose-conform-after-promotion:th
:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-leaning-id
:mark-data test-org-choose:thd:file-simple-mark-data
:other-changed-to "LEANING_TOWARDS"
:expect "MAYBE"))
)
;;;_ . org-choose-conform-after-demotion
;;;_ , Tests
(rtest:deftest org-choose-conform-after-demotion
( "Situation: The other entry was not keeping this node below the default.
Response: This node is unchanged."
(org-choose-conform-after-promotion:th
:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-maybe-id
:mark-data test-org-choose:thd:file-simple-mark-data
:other-was "LEANING_TOWARDS"
:other-changed-to "MAYBE"
:demoted t
:expect "MAYBE"))
( "Situation: The other entry was keeping this node below the default.
Response: This node is promoted."
(org-choose-conform-after-promotion:th
:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-maybe-id
:mark-data test-org-choose:thd:file-simple-mark-data
:other-was "LEANING_TOWARDS"
:other-changed-to "CHOSEN"
:demoted t
:expect "NOT_CHOSEN"))
( "Situation: The other entry was keeping this node below the
default. It was just demoted quite low.
Response: This node is promoted only to the default."
(org-choose-conform-after-promotion:th
:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-not-chosen-id
:mark-data test-org-choose:thd:file-simple-mark-data
:other-was "CHOSEN"
:other-changed-to "REJECTED"
:demoted t
:expect "MAYBE"))
)
;;;_ . org-choose-keep-sensible
;;;_ , Helper
(defun* org-choose-keep-sensible:th:manual (&key from to)
""
(let
(org-blocker-hook)
(org-todo to)
(org-choose-keep-sensible
(list
:from from
:to to
:position (point-at-bol)))))
;;;_ , Tests
(rtest:deftest org-choose-keep-sensible
;;Non-insinuated tests, `org-choose-keep-sensible' is just
;;called manually.
( "Operation: An entry's todo mark is changed into a TODO from
some other workflow state.
Response: No change to our entries."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-rejected-id)
(let
((org-todo-kwd-alist
test-org-choose:thd:context:kwd-alist-simple))
(org-choose-keep-sensible:th:manual
:from "RESPONSE:" :to "NOT_CHOSEN"))
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
'("MAYBE""NOT_CHOSEN""LEANING_TOWARDS""NOT_CHOSEN"))))
( "Operation: An entry is promoted, but not high enough to cause
inconsistent state.
Response: It gets promoted. Other nodes keep their values"
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-rejected-id)
(org-choose-keep-sensible:th:manual
:from "RESPONSE:" :to "NOT_CHOSEN")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
'("MAYBE""NOT_CHOSEN""LEANING_TOWARDS""NOT_CHOSEN"))))
( "Operation: An entry is promoted high enough to cause
inconsistent state. Leaning_towards becomes Chosen.
Response: It gets promoted. Other nodes are demoted just enough to
keep the state consistent."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-leaning-id)
(org-choose-keep-sensible:th:manual
:from "LEANING_TOWARDS" :to "CHOSEN")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
'("NOT_CHOSEN""REJECTED""CHOSEN""NOT_CHOSEN"))))
( "Operation: An entry is promoted high enough to cause
inconsistent state. Rejected becomes Leaning_towards.
Response: It gets promoted. Other nodes are demoted just enough to
keep the state consistent."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-rejected-id)
(org-choose-keep-sensible:th:manual
:from "REJECTED" :to "LEANING_TOWARDS")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
'("MAYBE""LEANING_TOWARDS""MAYBE""NOT_CHOSEN"))))
( "Situation: An entry was medium-high-marked; it's not high
enough to be keeping other nodes down below the default.
Operation: That entry is demoted one place. LEANING_TOWARDS becomes MAYBE.
Response: It gets demoted. Other nodes are unchanged."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-leaning-id)
(org-choose-keep-sensible:th:manual
:from "LEANING_TOWARDS" :to "MAYBE")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
'("MAYBE""REJECTED""MAYBE""NOT_CHOSEN"))))
( "Situation: An entry was high-marked, holding other nodes below
the top of the low range.
Operation: That entry is demoted one place. CHOSEN becomes LEANING_TOWARDS.
Response: It gets demoted. Nodes that it was holding down are
promoted. NOT_CHOSEN becomes MAYBE."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-1-chosen
:id test-org-choose:thd:file-w-1-chosen-sib-chosen-id)
(org-choose-keep-sensible:th:manual
:from "CHOSEN" :to "LEANING_TOWARDS")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-w-1-chosen-parent-id)
'( "MAYBE" "REJECTED" "LEANING_TOWARDS" "MAYBE"))))
( "Situation: An entry was high-marked, holding other nodes below
the top of the low range.
Operation: That entry is demoted two places. CHOSEN becomes MAYBE.
Response: It gets demoted. Nodes that it was holding down are
promoted as if by two one-place operations.
NOT_CHOSEN becomes MAYBE."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-1-chosen
:id test-org-choose:thd:file-w-1-chosen-sib-chosen-id)
(org-choose-keep-sensible:th:manual
:from "CHOSEN" :to "MAYBE")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-w-1-chosen-parent-id)
'("MAYBE" "REJECTED" "MAYBE" "MAYBE"))))
;;No tests for the situation where a node is demoted to the middle
;;of the upper range and should both potentially raise some others
;;and lower some others. It's unlikely to be an important
;;situation. YAGNI.
;;Tests of org-choose after having been insinuated
;;Implicit operations of `org-todo'
( "Operation: An entry is implicitly promoted.
Response: It gets promoted to the next value."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-rejected-id)
(org-todo)
(equal
(org-entry-get (point) "TODO")
"NOT_CHOSEN")))
( "Operation: An entry is implicitly promoted, but not high enough to cause
inconsistent state.
Response: It gets promoted. Other nodes keep their values"
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-rejected-id)
(org-todo)
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
'("MAYBE""NOT_CHOSEN""LEANING_TOWARDS""NOT_CHOSEN"))))
;;Tests that operations still behave after insinuation the same as
;;they did manually.
( "Operation: An entry is explicitly promoted, but not high enough to cause
inconsistent state.
Response: It gets promoted. Other nodes keep their values"
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-rejected-id)
(org-todo "NOT_CHOSEN")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
'("MAYBE""NOT_CHOSEN""LEANING_TOWARDS""NOT_CHOSEN"))))
( "Operation: An entry is promoted high enough to cause
inconsistent state. Leaning_towards becomes Chosen.
Response: It gets promoted. Other nodes are demoted just enough to
keep the state consistent."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-leaning-id)
(org-todo "CHOSEN")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
'("NOT_CHOSEN""REJECTED""CHOSEN""NOT_CHOSEN"))))
( "Operation: An entry is promoted high enough to cause
inconsistent state. Rejected becomes Leaning_towards.
Response: It gets promoted. Other nodes are demoted just enough to
keep the state consistent."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-rejected-id)
(org-todo "LEANING_TOWARDS")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
'("MAYBE""LEANING_TOWARDS""MAYBE""NOT_CHOSEN"))))
( "Situation: An entry was medium-high-marked; it's not high
enough to be keeping other nodes down below the default.
Operation: That entry is demoted one place. LEANING_TOWARDS becomes MAYBE.
Response: It gets demoted."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-simple
:id test-org-choose:thd:file-simple-sib-leaning-id)
(org-todo "MAYBE")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-simple-parent-id)
'("MAYBE""REJECTED""MAYBE""NOT_CHOSEN"))))
( "Situation: An entry was high-marked, holding other nodes below
the top of the low range.
Operation: That entry is demoted one place. CHOSEN becomes LEANING_TOWARDS.
Response: It gets demoted. Nodes that it was holding down are
promoted. NOT_CHOSEN becomes MAYBE."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-1-chosen
:id test-org-choose:thd:file-w-1-chosen-sib-chosen-id)
(org-todo "LEANING_TOWARDS")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-w-1-chosen-parent-id)
'( "MAYBE" "REJECTED" "LEANING_TOWARDS" "MAYBE"))))
( "Situation: An entry was high-marked, holding other nodes below
the top of the low range.
Operation: That entry is demoted two places. CHOSEN becomes MAYBE.
Response: It gets demoted. Nodes that it was holding down are
promoted as if by two one-place operations.
NOT_CHOSEN becomes MAYBE."
(org-choose:th:in-buffer-at
(:file test-org-choose:thd:file-w-1-chosen
:id test-org-choose:thd:file-w-1-chosen-sib-chosen-id)
(org-todo "MAYBE")
(equal
(org-choose:th:collect-childrens-todo-marks
test-org-choose:thd:file-w-1-chosen-parent-id)
'("MAYBE" "REJECTED" "MAYBE" "MAYBE"))))
)
;;;_. Footers
;;;_ , Provides
(provide 'test-org-choose)
;;;_ * Local emacs vars.
;;;_ + Local variables:
;;;_ + End:
;;;_ , End
;;; test-org-choose.el ends here
[-- Attachment #5: Type: text/plain, Size: 204 bytes --]
_______________________________________________
Emacs-orgmode mailing list
Remember: use `Reply All' to send replies to the list.
Emacs-orgmode@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-orgmode
^ permalink raw reply [flat|nested] 2+ messages in thread