diff options
author | Nicolas Goaziou <n.goaziou@gmail.com> | 2010-12-17 19:54:25 +0100 |
---|---|---|
committer | Nicolas Goaziou <n.goaziou@gmail.com> | 2011-02-18 12:45:07 +0100 |
commit | 1829aa79b51c462032a270431217e98e63c37ecc (patch) | |
tree | b6f0d7c61b9f2980b9549e25e4e954fd5da77fcd | |
parent | 8a3a81c08eec031d8636737024d652a4178cf317 (diff) | |
download | org-mode-1829aa79b51c462032a270431217e98e63c37ecc.tar.gz |
org-list: use list structure to update checkboxes and cookies
* lisp/org-list.el (org-toggle-checkbox): use structures to fix
checkboxes of a list
(org-update-checkbox-count): use structures to update cookies
-rw-r--r-- | lisp/org-list.el | 364 |
1 files changed, 191 insertions, 173 deletions
diff --git a/lisp/org-list.el b/lisp/org-list.el index 6a2f3ac..5cb494d 100644 --- a/lisp/org-list.el +++ b/lisp/org-list.el @@ -1798,77 +1798,91 @@ If the cursor is in a headline, apply this to all checkbox items in the text below the heading, taking as reference the first item in subtree, ignoring drawers." (interactive "P") - ;; Bounds is a list of type (beg end single-p) where single-p is t - ;; when `org-toggle-checkbox' is applied to a single item. Only - ;; toggles on single items will return errors. - (let* ((bounds - (cond - ((org-region-active-p) - (let ((rbeg (region-beginning)) - (rend (region-end))) - (save-excursion - (goto-char rbeg) - (if (org-search-forward-unenclosed org-item-beginning-re rend 'move) - (list (point-at-bol) rend nil) - (error "No item in region"))))) - ((org-on-heading-p) - ;; In this case, reference line is the first item in - ;; subtree outside drawers - (let ((pos (point)) - (limit (save-excursion (outline-next-heading) (point)))) - (save-excursion - (goto-char limit) - (org-search-backward-unenclosed ":END:" pos 'move) - (org-search-forward-unenclosed - org-item-beginning-re limit 'move) - (list (point) limit nil)))) - ((org-at-item-p) - (list (point-at-bol) (1+ (point-at-eol)) t)) - (t (error "Not at an item or heading, and no active region")))) - (beg (car bounds)) - ;; marker is needed because deleting or inserting checkboxes - ;; will change bottom point - (end (copy-marker (nth 1 bounds))) - (single-p (nth 2 bounds)) - (ref-presence (save-excursion - (goto-char beg) - (org-at-item-checkbox-p))) - (ref-status (equal (match-string 1) "[X]")) - (act-on-item - (lambda (ref-pres ref-stat) - (if (equal toggle-presence '(4)) - (cond - ((and ref-pres (org-at-item-checkbox-p)) - (replace-match "")) - ((and (not ref-pres) - (not (org-at-item-checkbox-p)) - (org-at-item-p)) - (goto-char (match-end 0)) - ;; Ignore counter, if any - (when (looking-at "\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?") - (goto-char (match-end 0))) - (let ((desc-p (and (org-at-item-description-p) - (cdr (assq 'checkbox org-list-automatic-rules))))) - (cond - ((and single-p desc-p) - (error "Cannot add a checkbox in a description list")) - ((not desc-p) (insert "[ ] ")))))) - (let ((blocked (org-checkbox-blocked-p))) - (cond - ((and blocked single-p) - (error "Checkbox blocked because of unchecked box in line %d" blocked)) - (blocked nil) - ((org-at-item-checkbox-p) - (replace-match - (cond ((equal toggle-presence '(16)) "[-]") - (ref-stat "[ ]") - (t "[X]")) - t t nil 1)))))))) - (save-excursion - (goto-char beg) - (while (< (point) end) - (funcall act-on-item ref-presence ref-status) - (org-search-forward-unenclosed org-item-beginning-re end 'move))) + (save-excursion + (let* (singlep + block-item + lim-up + lim-down + (orderedp (ignore-errors (org-entry-get nil "ORDERED"))) + (bounds + ;; In a region, start at first item in region + (cond + ((org-region-active-p) + (let ((limit (region-end))) + (goto-char (region-beginning)) + (if (org-search-forward-unenclosed org-item-beginning-re + limit t) + (setq lim-up (point-at-bol)) + (error "No item in region")) + (setq lim-down (copy-marker limit)))) + ((org-on-heading-p) + ;; On an heading, start at first item after drawers + (let ((limit (save-excursion (outline-next-heading) (point)))) + (forward-line 1) + (when (looking-at org-drawer-regexp) + (re-search-forward "^[ \t]*:END:" limit nil)) + (if (org-search-forward-unenclosed org-item-beginning-re + limit t) + (setq lim-up (point-at-bol)) + (error "No item in subtree")) + (setq lim-down (copy-marker limit)))) + ;; Just one item: set singlep flag + ((org-at-item-p) + (setq singlep t) + (setq lim-up (point-at-bol) + lim-down (point-at-eol))) + (t (error "Not at an item or heading, and no active region")))) + ;; determine the checkbox going to be applied to all items + ;; within bounds + (ref-checkbox + (progn + (goto-char lim-up) + (let ((cbox (and (org-at-item-checkbox-p) (match-string 1)))) + (cond + ((equal toggle-presence '(16)) "[-]") + ((equal toggle-presence '(4)) + (unless cbox "[ ]")) + ((equal "[ ]" cbox) "[X]") + (t "[ ]")))))) + ;; When an item is found within bounds, grab the full list at + ;; point structure, then: 1. set checkbox of all its items + ;; within bounds to ref-checkbox; 2. fix checkboxes of the whole + ;; list; 3. move point after the list. + (goto-char lim-up) + (while (and (< (point) lim-down) + (org-search-forward-unenclosed + org-item-beginning-re lim-down 'move)) + (let* ((struct (org-list-struct)) + (struct-copy (mapcar (lambda (e) (copy-alist e)) struct)) + (parents (org-list-struct-parent-alist struct)) + (bottom (copy-marker (org-list-get-bottom-point struct))) + (items-to-toggle (org-remove-if + (lambda (e) (or (< e lim-up) (> e lim-down))) + (mapcar 'car (cdr struct))))) + (mapc (lambda (e) (org-list-set-checkbox + e struct + ;; if there is no box at item, leave as-is + ;; unless function was called with C-u prefix + (let ((cur-box (org-list-get-checkbox e struct))) + (if (or cur-box (equal toggle-presence '(4))) + ref-checkbox + cur-box)))) + items-to-toggle) + (setq block-item (org-list-struct-fix-box struct parents orderedp)) + ;; Report some problems due to ORDERED status of subtree. If + ;; only one box was being checked, throw an error, else, + ;; only signal problems. + (cond + ((and singlep block-item (> lim-up block-item)) + (error + "Checkbox blocked because of unchecked box at line %d" + (org-current-line block-item))) + (block-item + (message + "Checkboxes were removed due to unchecked box at line %d" + (org-current-line block-item)))) + (goto-char bottom) + (org-list-struct-apply-struct struct struct-copy)))) (org-update-checkbox-count-maybe))) (defun org-reset-checkbox-state-subtree () @@ -1901,110 +1915,114 @@ information.") (defun org-update-checkbox-count (&optional all) "Update the checkbox statistics in the current section. -This will find all statistic cookies like [57%] and [6/12] and update them -with the current numbers. With optional prefix argument ALL, do this for -the whole buffer." +This will find all statistic cookies like [57%] and [6/12] and +update them with the current numbers. + +With optional prefix argument ALL, do this for the whole buffer." (interactive "P") (save-excursion - (let ((cstat 0)) - (catch 'exit - (while t - (let* ((buffer-invisibility-spec (org-inhibit-invisibility)) ; Emacs 21 - (beg (condition-case nil - (progn (org-back-to-heading) (point)) - (error (point-min)))) - (end (copy-marker (save-excursion - (outline-next-heading) (point)))) - (re-cookie "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)") - (re-box "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\(\\[[- X]\\]\\)") - beg-cookie end-cookie is-percent c-on c-off lim new - curr-ind next-ind continue-from startsearch list-beg list-end - (recursive - (or (not org-hierarchical-checkbox-statistics) - (string-match "\\<recursive\\>" - (or (ignore-errors - (org-entry-get nil "COOKIE_DATA")) - ""))))) - (goto-char end) - ;; find each statistics cookie - (while (and (org-search-backward-unenclosed re-cookie beg 'move) - (not (save-match-data - (and (org-on-heading-p) - (string-match "\\<todo\\>" - (downcase - (or (org-entry-get - nil "COOKIE_DATA") - ""))))))) - (setq beg-cookie (match-beginning 1) - end-cookie (match-end 1) - cstat (+ cstat (if end-cookie 1 0)) - startsearch (point-at-eol) - continue-from (match-beginning 0) - is-percent (match-beginning 2) - lim (cond - ((org-on-heading-p) (outline-next-heading) (point)) - ;; Ensure many cookies in the same list won't imply - ;; computing list boundaries as many times. - ((org-at-item-p) - (unless (and list-beg (>= (point) list-beg)) - (setq list-beg (org-list-top-point) - list-end (copy-marker - (org-list-bottom-point)))) - (org-get-end-of-item list-end)) - (t nil)) - c-on 0 - c-off 0) - (when lim - ;; find first checkbox for this cookie and gather - ;; statistics from all that are at this indentation level - (goto-char startsearch) - (if (org-search-forward-unenclosed re-box lim t) - (progn - (beginning-of-line) - (setq curr-ind (org-get-indentation)) - (setq next-ind curr-ind) - (while (and (bolp) (org-at-item-p) - (if recursive - (<= curr-ind next-ind) - (= curr-ind next-ind))) - (when (org-at-item-checkbox-p) - (if (member (match-string 1) '("[ ]" "[-]")) - (setq c-off (1+ c-off)) - (setq c-on (1+ c-on)))) - (if (not recursive) - ;; org-get-next-item goes through list-enders - ;; with proper limit. - (goto-char (or (org-get-next-item (point) lim) lim)) - (end-of-line) - (when (org-search-forward-unenclosed - org-item-beginning-re lim t) - (beginning-of-line))) - (setq next-ind (org-get-indentation))))) - (goto-char continue-from) - ;; update cookie - (when end-cookie - (setq new (if is-percent - (format "[%d%%]" (/ (* 100 c-on) - (max 1 (+ c-on c-off)))) - (format "[%d/%d]" c-on (+ c-on c-off)))) - (goto-char beg-cookie) - (insert new) - (delete-region (point) (+ (point) (- end-cookie beg-cookie)))) - ;; update items checkbox if it has one - (when (and (org-at-item-checkbox-p) - (> (+ c-on c-off) 0)) - (setq beg-cookie (match-beginning 1) - end-cookie (match-end 1)) - (delete-region beg-cookie end-cookie) - (goto-char beg-cookie) - (cond ((= c-off 0) (insert "[X]")) - ((= c-on 0) (insert "[ ]")) - (t (insert "[-]"))))) - (goto-char continue-from))) - (unless (and all (outline-next-heading)) (throw 'exit nil)))) - (when (interactive-p) - (message "Checkbox statistics updated %s (%d places)" - (if all "in entire file" "in current outline entry") cstat))))) + (let ((cookie-re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)") + (box-re "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\(\\[[- X]\\]\\)") + (recursivep + (or (not org-hierarchical-checkbox-statistics) + (string-match "\\<recursive\\>" + (or (ignore-errors + (org-entry-get nil "COOKIE_DATA")) + "")))) + (bounds (if all + (cons (point-min) (point-max)) + (cons (or (ignore-errors (org-back-to-heading) (point)) + (point-min)) + (save-excursion (outline-next-heading) (point))))) + (count-boxes + (function + ;; add checked boxes and boxes of all types in all + ;; structures in STRUCTS to c-on and c-all, respectively. + ;; This looks at RECURSIVEP value. If ITEM is nil, count + ;; across the whole structure, else count only across + ;; subtree whose ancestor is ITEM. + (lambda (item structs) + (mapc + (lambda (s) + (let* ((pre (org-list-struct-prev-alist s)) + (items + (if recursivep + (or (and item (org-list-get-subtree item s pre)) + (mapcar 'car s)) + (or (and item (org-list-get-all-children item s pre)) + (org-list-get-all-items + (org-list-get-top-point s) s pre)))) + (cookies (delq nil (mapcar + (lambda (e) + (org-list-get-checkbox e s)) + items)))) + (setq c-all (+ (length cookies) c-all) + c-on (+ (org-count "[X]" cookies) c-on)))) + structs)))) + cookies-list backup-end structs-backup) + (goto-char (car bounds)) + ;; 1. Build an alist for each cookie found within BOUNDS. The + ;; key will be position at beginning of cookie and values + ;; ending position, format of cookie, number of checked boxes + ;; to report, and total number of boxes. + (while (re-search-forward cookie-re (cdr bounds) t) + (save-excursion + (let ((c-on 0) (c-all 0)) + (save-match-data + ;; There are two types of cookies: those at headings and those + ;; at list items. + (cond + ((and (org-on-heading-p) + (string-match "\\<todo\\>" + (downcase + (or (org-entry-get nil "COOKIE_DATA") ""))))) + ;; This cookie is at an heading, but specifically for + ;; todo, not for checkboxes: skip it. + ((org-on-heading-p) + (setq backup-end (save-excursion + (outline-next-heading) (point))) + ;; This cookie is at an heading. Grab structure of + ;; every list containing a checkbox between point and + ;; next headline, and save them in STRUCTS-BACKUP + (while (org-search-forward-unenclosed box-re backup-end 'move) + (let* ((struct (org-list-struct)) + (bottom (org-list-get-bottom-point struct))) + (setq structs-backup (cons struct structs-backup)) + (goto-char bottom))) + (funcall count-boxes nil structs-backup)) + ((org-at-item-p) + ;; This cookie is at an item. Look in STRUCTS-BACKUP + ;; to see if we have the structure of list at point in + ;; it. Else compute the structure. + (let ((item (point-at-bol))) + (if (and backup-end (< item backup-end)) + (funcall count-boxes item structs-backup) + (setq end-entry bottom + structs-backup (list (org-list-struct))) + (funcall count-boxes item structs-backup)))))) + ;; Build the cookies list, with appropriate information + (setq cookies-list (cons (list (match-beginning 1) ; cookie start + (match-end 1) ; cookie end + (match-beginning 2) ; percent? + c-on ; checked boxes + c-all) ; total boxes + cookies-list))))) + ;; 2. Apply alist to buffer, in reverse order so positions stay + ;; unchanged after cookie modifications. + (mapc (lambda (cookie) + (let* ((beg (car cookie)) + (end (nth 1 cookie)) + (percentp (nth 2 cookie)) + (checked (nth 3 cookie)) + (total (nth 4 cookie)) + (new (if percentp + (format "[%d%%]" (/ (* 100 checked) + (max 1 total))) + (format "[%d/%d]" checked total)))) + (goto-char beg) + (insert new) + (delete-region (point) (+ (point) (- end beg))))) + cookies-list)))) (defun org-get-checkbox-statistics-face () "Select the face for checkbox statistics. |