diff options
Diffstat (limited to 'elpa/org-9.5.2/org-list.el')
| -rw-r--r-- | elpa/org-9.5.2/org-list.el | 3582 |
1 files changed, 3582 insertions, 0 deletions
diff --git a/elpa/org-9.5.2/org-list.el b/elpa/org-9.5.2/org-list.el new file mode 100644 index 0000000..2bd9dc4 --- /dev/null +++ b/elpa/org-9.5.2/org-list.el @@ -0,0 +1,3582 @@ +;;; org-list.el --- Plain lists for Org -*- lexical-binding: t; -*- +;; +;; Copyright (C) 2004-2021 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten.dominik@gmail.com> +;; Bastien Guerry <bzg@gnu.org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: https://orgmode.org +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <https://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the code dealing with plain lists in Org mode. + +;; The core concept behind lists is their structure. A structure is +;; a snapshot of the list, in the shape of a data tree (see +;; `org-list-struct'). + +;; Once the list structure is stored, it is possible to make changes +;; on it that will be mirrored to the real list or to get information +;; about the list, using accessors and methods provided in the +;; library. Most of them require the use of one or two helper +;; functions, namely `org-list-parents-alist' and +;; `org-list-prevs-alist'. + +;; Structure is eventually applied to the buffer with +;; `org-list-write-struct'. This function repairs (bullets, +;; indentation, checkboxes) the list in the process. It should be +;; called near the end of any function working on structures. + +;; Thus, a function applying to lists should usually follow this +;; template: + +;; 1. Verify point is in a list and grab item beginning (with the same +;; function `org-in-item-p'). If the function requires the cursor +;; to be at item's bullet, `org-at-item-p' is more selective. It +;; is also possible to move point to the closest item with +;; `org-list-search-backward', or `org-list-search-forward', +;; applied to the function `org-item-beginning-re'. + +;; 2. Get list structure with `org-list-struct'. + +;; 3. Compute one, or both, helper functions, +;; (`org-list-parents-alist', `org-list-prevs-alist') depending on +;; needed accessors. + +;; 4. Proceed with the modifications, using methods and accessors. + +;; 5. Verify and apply structure to buffer, using +;; `org-list-write-struct'. + +;; 6. If changes made to the list might have modified check-boxes, +;; call `org-update-checkbox-count-maybe'. + +;; Computing a structure can be a costly operation on huge lists (a +;; few thousand lines long). Thus, code should follow the rule: +;; "collect once, use many". As a corollary, it is usually a bad idea +;; to use directly an interactive function inside the code, as those, +;; being independent entities, read the whole list structure another +;; time. + +;;; Code: + +(require 'cl-lib) +(require 'org-macs) +(require 'org-compat) + +(defvar org-M-RET-may-split-line) +(defvar org-adapt-indentation) +(defvar org-auto-align-tags) +(defvar org-blank-before-new-entry) +(defvar org-clock-string) +(defvar org-closed-string) +(defvar org-deadline-string) +(defvar org-done-keywords) +(defvar org-drawer-regexp) +(defvar org-element-all-objects) +(defvar org-inhibit-startup) +(defvar org-loop-over-headlines-in-active-region) +(defvar org-odd-levels-only) +(defvar org-outline-regexp-bol) +(defvar org-scheduled-string) +(defvar org-todo-line-regexp) +(defvar org-ts-regexp) +(defvar org-ts-regexp-both) + +(declare-function org-at-heading-p "org" (&optional invisible-ok)) +(declare-function org-back-to-heading "org" (&optional invisible-ok)) +(declare-function org-before-first-heading-p "org" ()) +(declare-function org-current-level "org" ()) +(declare-function org-element-at-point "org-element" ()) +(declare-function org-element-context "org-element" (&optional element)) +(declare-function org-element-interpret-data "org-element" (data)) +(declare-function org-element-lineage "org-element" (blob &optional types with-self)) +(declare-function org-element-macro-interpreter "org-element" (macro ##)) +(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated)) +(declare-function org-element-normalize-string "org-element" (s)) +(declare-function org-element-parse-buffer "org-element" (&optional granularity visible-only)) +(declare-function org-element-property "org-element" (property element)) +(declare-function org-element-put-property "org-element" (element property value)) +(declare-function org-element-set-element "org-element" (old new)) +(declare-function org-element-type "org-element" (element)) +(declare-function org-element-update-syntax "org-element" ()) +(declare-function org-end-of-meta-data "org" (&optional full)) +(declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) +(declare-function org-export-create-backend "ox" (&rest rest) t) +(declare-function org-export-data-with-backend "ox" (data backend info)) +(declare-function org-export-get-backend "ox" (name)) +(declare-function org-export-get-environment "ox" (&optional backend subtreep ext-plist)) +(declare-function org-export-get-next-element "ox" (blob info &optional n)) +(declare-function org-export-with-backend "ox" (backend data &optional contents info)) +(declare-function org-fix-tags-on-the-fly "org" ()) +(declare-function org-get-todo-state "org" ()) +(declare-function org-in-block-p "org" (names)) +(declare-function org-inlinetask-goto-beginning "org-inlinetask" ()) +(declare-function org-inlinetask-goto-end "org-inlinetask" ()) +(declare-function org-inlinetask-in-task-p "org-inlinetask" ()) +(declare-function org-inlinetask-outline-regexp "org-inlinetask" ()) +(declare-function org-level-increment "org" ()) +(declare-function org-mode "org" ()) +(declare-function org-narrow-to-subtree "org" ()) +(declare-function org-outline-level "org" ()) +(declare-function org-previous-line-empty-p "org" ()) +(declare-function org-reduced-level "org" (L)) +(declare-function org-set-tags "org" (tags)) +(declare-function org-show-subtree "org" ()) +(declare-function org-sort-remove-invisible "org" (S)) +(declare-function org-time-string-to-seconds "org" (s)) +(declare-function org-timer-hms-to-secs "org-timer" (hms)) +(declare-function org-timer-item "org-timer" (&optional arg)) +(declare-function outline-next-heading "outline" ()) +(declare-function outline-previous-heading "outline" ()) + + + +;;; Configuration variables + +(defgroup org-plain-lists nil + "Options concerning plain lists in Org mode." + :tag "Org Plain lists" + :group 'org-structure) + +(defcustom org-cycle-include-plain-lists t + "When t, make TAB cycle visibility on plain list items. +Cycling plain lists works only when the cursor is on a plain list +item. When the cursor is on an outline heading, plain lists are +treated as text. This is the most stable way of handling this, +which is why it is the default. + +When this is the symbol `integrate', then integrate plain list +items when cycling, as if they were children of outline headings. + +This setting can lead to strange effects when switching visibility +to `children', because the first \"child\" in a subtree decides +what children should be listed. If that first \"child\" is a +plain list item with an implied large level number, all true +children and grand children of the outline heading will be +exposed in a children' view." + :group 'org-plain-lists + :group 'org-cycle + :type '(choice + (const :tag "Never" nil) + (const :tag "With cursor in plain list (recommended)" t) + (const :tag "As children of outline headings" integrate))) + +(defcustom org-list-demote-modify-bullet nil + "Default bullet type installed when demoting an item. +This is an association list, for each bullet type, this alist will point +to the bullet that should be used when this item is demoted. +For example, + + (setq org-list-demote-modify-bullet + \\='((\"+\" . \"-\") (\"-\" . \"+\") (\"*\" . \"+\"))) + +will make + + + Movies + + Silence of the Lambs + + My Cousin Vinny + + Books + + The Hunt for Red October + + The Road to Omaha + +into + + + Movies + - Silence of the Lambs + - My Cousin Vinny + + Books + - The Hunt for Red October + - The Road to Omaha" + :group 'org-plain-lists + :type '(repeat + (cons + (choice :tag "If the current bullet is " + (const "-") + (const "+") + (const "*") + (const "1.") + (const "1)")) + (choice :tag "demotion will change it to" + (const "-") + (const "+") + (const "*") + (const "1.") + (const "1)"))))) + +(defcustom org-plain-list-ordered-item-terminator t + "The character that makes a line with leading number an ordered list item. +Valid values are ?. and ?\\). To get both terminators, use t. + +This variable needs to be set before org.el is loaded. If you +need to make a change while Emacs is running, use the customize +interface or run the following code after updating it: + + `\\[org-element-update-syntax]'" + :group 'org-plain-lists + :type '(choice (const :tag "dot like in \"2.\"" ?.) + (const :tag "paren like in \"2)\"" ?\)) + (const :tag "both" t)) + :set (lambda (var val) (set var val) + (when (featurep 'org-element) (org-element-update-syntax)))) + +(defcustom org-list-allow-alphabetical nil + "Non-nil means single character alphabetical bullets are allowed. + +Both uppercase and lowercase are handled. Lists with more than +26 items will fallback to standard numbering. Alphabetical +counters like \"[@c]\" will be recognized. + +This variable needs to be set before org.el is loaded. If you +need to make a change while Emacs is running, use the customize +interface or run the following code after updating it: + + `\\[org-element-update-syntax]'" + :group 'org-plain-lists + :version "24.1" + :type 'boolean + :set (lambda (var val) (set var val) + (when (featurep 'org-element) (org-element-update-syntax)))) + +(defcustom org-list-two-spaces-after-bullet-regexp nil + "A regular expression matching bullets that should have 2 spaces after them. +When nil, no bullet will have two spaces after them. When +a string, it will be used as a regular expression. When the +bullet type of a list is changed, the new bullet type will be +matched against this regexp. If it matches, there will be two +spaces instead of one after the bullet in each item of the list." + :group 'org-plain-lists + :type '(choice + (const :tag "never" nil) + (regexp))) + +(defcustom org-list-automatic-rules '((checkbox . t) + (indent . t)) + "Non-nil means apply set of rules when acting on lists. +\\<org-mode-map> +By default, automatic actions are taken when using + `\\[org-meta-return]', + `\\[org-metaright]', + `\\[org-metaleft]', + `\\[org-shiftmetaright]', + `\\[org-shiftmetaleft]', + `\\[org-ctrl-c-minus]', + `\\[org-toggle-checkbox]', + `\\[org-insert-todo-heading]'. + +You can disable individually these rules by setting them to nil. +Valid rules are: + +checkbox when non-nil, checkbox statistics is updated each time + you either insert a new checkbox or toggle a checkbox. +indent when non-nil, indenting or outdenting list top-item + with its subtree will move the whole list and + outdenting a list whose bullet is * to column 0 will + change that bullet to \"-\"." + :group 'org-plain-lists + :version "24.1" + :type '(alist :tag "Sets of rules" + :key-type + (choice + (const :tag "Checkbox" checkbox) + (const :tag "Indent" indent)) + :value-type + (boolean :tag "Activate" :value t))) + +(defcustom org-list-use-circular-motion nil + "Non-nil means commands implying motion in lists should be cyclic. +\\<org-mode-map> +In that case, the item following the last item is the first one, +and the item preceding the first item is the last one. + +This affects the behavior of + `\\[org-move-item-up]', + `\\[org-move-item-down]', + `\\[org-next-item]', + `\\[org-previous-item]'." + :group 'org-plain-lists + :version "24.1" + :type 'boolean) + +(defvar org-checkbox-statistics-hook nil + "Hook that is run whenever Org thinks checkbox statistics should be updated. +This hook runs even if checkbox rule in +`org-list-automatic-rules' does not apply, so it can be used to +implement alternative ways of collecting statistics +information.") + +(defcustom org-checkbox-hierarchical-statistics t + "Non-nil means checkbox statistics counts only the state of direct children. +When nil, all boxes below the cookie are counted. +This can be set to nil on a per-node basis using a COOKIE_DATA property +with the word \"recursive\" in the value." + :group 'org-plain-lists + :type 'boolean) + +(defcustom org-list-indent-offset 0 + "Additional indentation for sub-items in a list. +By setting this to a small number, usually 1 or 2, one can more +clearly distinguish sub-items in a list." + :group 'org-plain-lists + :version "24.1" + :type 'integer) + +(defvar org-list-forbidden-blocks '("example" "verse" "src" "export") + "Names of blocks where lists are not allowed. +Names must be in lower case.") + + +;;; Predicates and regexps + +(defconst org-list-end-re "^[ \t]*\n[ \t]*\n" + "Regex matching the end of a plain list.") + +(defconst org-list-full-item-re + (concat "^[ \t]*\\(\\(?:[-+*]\\|\\(?:[0-9]+\\|[A-Za-z]\\)[.)]\\)\\(?:[ \t]+\\|$\\)\\)" + "\\(?:\\[@\\(?:start:\\)?\\([0-9]+\\|[A-Za-z]\\)\\][ \t]*\\)?" + "\\(?:\\(\\[[ X-]\\]\\)\\(?:[ \t]+\\|$\\)\\)?" + "\\(?:\\(.*\\)[ \t]+::\\(?:[ \t]+\\|$\\)\\)?") + "Matches a list item and puts everything into groups: +group 1: bullet +group 2: counter +group 3: checkbox +group 4: description tag") + +(defun org-item-re () + "Return the correct regular expression for plain lists." + (let ((term (cond + ((eq org-plain-list-ordered-item-terminator t) "[.)]") + ((= org-plain-list-ordered-item-terminator ?\)) ")") + ((= org-plain-list-ordered-item-terminator ?.) "\\.") + (t "[.)]"))) + (alpha (if org-list-allow-alphabetical "\\|[A-Za-z]" ""))) + (concat "\\([ \t]*\\([-+]\\|\\(\\([0-9]+" alpha "\\)" term + "\\)\\)\\|[ \t]+\\*\\)\\([ \t]+\\|$\\)"))) + +(defsubst org-item-beginning-re () + "Regexp matching the beginning of a plain list item." + (concat "^" (org-item-re))) + +(defun org-list-at-regexp-after-bullet-p (regexp) + "Is point at a list item with REGEXP after bullet?" + (and (org-at-item-p) + (save-excursion + (goto-char (match-end 0)) + (let ((counter-re (concat "\\(?:\\[@\\(?:start:\\)?" + (if org-list-allow-alphabetical + "\\([0-9]+\\|[A-Za-z]\\)" + "[0-9]+") + "\\][ \t]*\\)"))) + ;; Ignore counter if any + (when (looking-at counter-re) (goto-char (match-end 0)))) + (looking-at regexp)))) + +(defun org-list-in-valid-context-p () + "Is point in a context where lists are allowed?" + (not (org-in-block-p org-list-forbidden-blocks))) + +(defun org-in-item-p () + "Return item beginning position when in a plain list, nil otherwise." + (save-excursion + (beginning-of-line) + (let* ((case-fold-search t) + (context (org-list-context)) + (lim-up (car context)) + (inlinetask-re (and (featurep 'org-inlinetask) + (org-inlinetask-outline-regexp))) + (item-re (org-item-re)) + ;; Indentation isn't meaningful when point starts at an empty + ;; line or an inline task. + (ind-ref (if (or (looking-at "^[ \t]*$") + (and inlinetask-re (looking-at inlinetask-re))) + 10000 + (current-indentation)))) + (cond + ((eq (nth 2 context) 'invalid) nil) + ((looking-at item-re) (point)) + (t + ;; Detect if cursor in amidst `org-list-end-re'. First, count + ;; number HL of hard lines it takes, then call `org-in-regexp' + ;; to compute its boundaries END-BOUNDS. When point is + ;; in-between, move cursor before regexp beginning. + (let ((hl 0) (i -1) end-bounds) + (when (and (progn + (while (setq i (string-match + "[\r\n]" org-list-end-re (1+ i))) + (setq hl (1+ hl))) + (setq end-bounds (org-in-regexp org-list-end-re hl))) + (>= (point) (car end-bounds)) + (< (point) (cdr end-bounds))) + (goto-char (car end-bounds)) + (forward-line -1))) + ;; Look for an item, less indented that reference line. + (catch 'exit + (while t + (let ((ind (current-indentation))) + (cond + ;; This is exactly what we want. + ((and (looking-at item-re) (< ind ind-ref)) + (throw 'exit (point))) + ;; At upper bound of search or looking at the end of a + ;; previous list: search is over. + ((<= (point) lim-up) (throw 'exit nil)) + ((looking-at org-list-end-re) (throw 'exit nil)) + ;; Skip blocks, drawers, inline-tasks, blank lines + ((and (looking-at "^[ \t]*#\\+end_") + (re-search-backward "^[ \t]*#\\+begin_" lim-up t))) + ((and (looking-at "^[ \t]*:END:") + (re-search-backward org-drawer-regexp lim-up t)) + (beginning-of-line)) + ((and inlinetask-re (looking-at inlinetask-re)) + (org-inlinetask-goto-beginning) + (forward-line -1)) + ((looking-at "^[ \t]*$") (forward-line -1)) + ;; Text at column 0 cannot belong to a list: stop. + ((zerop ind) (throw 'exit nil)) + ;; Normal text less indented than reference line, take + ;; it as new reference. + ((< ind ind-ref) + (setq ind-ref ind) + (forward-line -1)) + (t (forward-line -1))))))))))) + +(defun org-at-item-p () + "Is point in a line starting a hand-formatted item?" + (save-excursion + (beginning-of-line) + (and (looking-at (org-item-re)) (org-list-in-valid-context-p)))) + +(defun org-at-item-bullet-p () + "Is point at the bullet of a plain list item?" + (and (org-at-item-p) + (not (member (char-after) '(?\ ?\t))) + (< (point) (match-end 0)))) + +(defun org-at-item-timer-p () + "Is point at a line starting a plain list item with a timer?" + (org-list-at-regexp-after-bullet-p + "\\([0-9]+:[0-9]+:[0-9]+\\)[ \t]+::[ \t]+")) + +(defun org-at-item-description-p () + "Is point at a description list item?" + (org-list-at-regexp-after-bullet-p "\\(\\S-.+\\)[ \t]+::\\([ \t]+\\|$\\)")) + +(defun org-at-item-checkbox-p () + "Is point at a line starting a plain-list item with a checklet?" + (org-list-at-regexp-after-bullet-p "\\(\\[[- X]\\]\\)[ \t]+")) + +(defun org-at-item-counter-p () + "Is point at a line starting a plain-list item with a counter?" + (and (org-at-item-p) + (looking-at org-list-full-item-re) + (match-string 2))) + + + +;;; Structures and helper functions + +(defun org-list-context () + "Determine context, and its boundaries, around point. + +Context will be a cell like (MIN MAX CONTEXT) where MIN and MAX +are boundaries and CONTEXT is a symbol among `drawer', `block', +`invalid', `inlinetask' and nil. + +Contexts `block' and `invalid' refer to `org-list-forbidden-blocks'." + (save-match-data + (save-excursion + (org-with-limited-levels + (beginning-of-line) + (let ((case-fold-search t) (pos (point)) beg end context-type + ;; Get positions of surrounding headings. This is the + ;; default context. + (lim-up (or (save-excursion (and (ignore-errors (org-back-to-heading t)) + (point))) + (point-min))) + (lim-down (or (save-excursion (outline-next-heading)) (point-max)))) + ;; Is point inside a drawer? + (let ((end-re "^[ \t]*:END:") + (beg-re org-drawer-regexp)) + (when (save-excursion + (and (not (looking-at beg-re)) + (not (looking-at end-re)) + (setq beg (and (re-search-backward beg-re lim-up t) + (1+ (point-at-eol)))) + (setq end (or (and (re-search-forward end-re lim-down t) + (1- (match-beginning 0))) + lim-down)) + (>= end pos))) + (setq lim-up beg lim-down end context-type 'drawer))) + ;; Is point strictly in a block, and of which type? + (let ((block-re "^[ \t]*#\\+\\(begin\\|end\\)_") type) + (when (save-excursion + (and (not (looking-at block-re)) + (setq beg (and (re-search-backward block-re lim-up t) + (1+ (point-at-eol)))) + (looking-at "^[ \t]*#\\+begin_\\(\\S-+\\)") + (setq type (downcase (match-string 1))) + (goto-char beg) + (setq end (or (and (re-search-forward block-re lim-down t) + (1- (point-at-bol))) + lim-down)) + (>= end pos) + (equal (downcase (match-string 1)) "end"))) + (setq lim-up beg lim-down end + context-type (if (member type org-list-forbidden-blocks) + 'invalid 'block)))) + ;; Is point in an inlinetask? + (when (and (featurep 'org-inlinetask) + (save-excursion + (let* ((beg-re (org-inlinetask-outline-regexp)) + (end-re (concat beg-re "END[ \t]*$"))) + (and (not (looking-at "^\\*+")) + (setq beg (and (re-search-backward beg-re lim-up t) + (1+ (point-at-eol)))) + (not (looking-at end-re)) + (setq end (and (re-search-forward end-re lim-down t) + (1- (match-beginning 0)))) + (> (point) pos))))) + (setq lim-up beg lim-down end context-type 'inlinetask)) + ;; Return context boundaries and type. + (list lim-up lim-down context-type)))))) + +(defun org-list-struct () + "Return structure of list at point. + +A list structure is an alist where key is point at item, and +values are: +1. indentation, +2. bullet with trailing whitespace, +3. bullet counter, if any, +4. checkbox, if any, +5. description tag, if any, +6. position at item end. + +Thus the following list, where numbers in parens are +point-at-bol: + +- [X] first item (1) + 1. sub-item 1 (18) + 5. [@5] sub-item 2 (34) + some other text belonging to first item (55) +- last item (97) + + tag :: description (109) + (131) + +will get the following structure: + + ((1 0 \"- \" nil \"[X]\" nil 97) + (18 2 \"1. \" nil nil nil 34) + (34 2 \"5. \" \"5\" nil nil 55) + (97 0 \"- \" nil nil nil 131) + (109 2 \"+ \" nil nil \"tag\" 131)) + +Assume point is at an item." + (save-excursion + (beginning-of-line) + (let* ((case-fold-search t) + (context (org-list-context)) + (lim-up (car context)) + (lim-down (nth 1 context)) + (text-min-ind 10000) + (item-re (org-item-re)) + (inlinetask-re (and (featurep 'org-inlinetask) + (org-inlinetask-outline-regexp))) + (beg-cell (cons (point) (current-indentation))) + itm-lst itm-lst-2 end-lst end-lst-2 struct + (assoc-at-point + ;; Return association at point. + (lambda (ind) + (looking-at org-list-full-item-re) + (let ((bullet (match-string-no-properties 1))) + (list (point) + ind + bullet + (match-string-no-properties 2) ; counter + (match-string-no-properties 3) ; checkbox + ;; Description tag. + (and (string-match-p "[-+*]" bullet) + (match-string-no-properties 4)))))) + (end-before-blank + ;; Ensure list ends at the first blank line. + (lambda () + (skip-chars-backward " \r\t\n") + (min (1+ (point-at-eol)) lim-down)))) + ;; 1. Read list from starting item to its beginning, and save + ;; top item position and indentation in BEG-CELL. Also store + ;; ending position of items in END-LST. + (save-excursion + (catch 'exit + (while t + (let ((ind (current-indentation))) + (cond + ((<= (point) lim-up) + ;; At upward limit: if we ended at an item, store it, + ;; else dismiss useless data recorded above BEG-CELL. + ;; Jump to part 2. + (throw 'exit + (setq itm-lst + (if (not (looking-at item-re)) + (memq (assq (car beg-cell) itm-lst) itm-lst) + (setq beg-cell (cons (point) ind)) + (cons (funcall assoc-at-point ind) itm-lst))))) + ;; Looking at a list ending regexp. Dismiss useless + ;; data recorded above BEG-CELL. Jump to part 2. + ((looking-at org-list-end-re) + (throw 'exit + (setq itm-lst + (memq (assq (car beg-cell) itm-lst) itm-lst)))) + ;; Point is at an item. Add data to ITM-LST. It may + ;; also end a previous item: save it in END-LST. If + ;; ind is less or equal than BEG-CELL and there is no + ;; end at this ind or lesser, this item becomes the new + ;; BEG-CELL. + ((looking-at item-re) + (push (funcall assoc-at-point ind) itm-lst) + (push (cons ind (point)) end-lst) + (when (< ind text-min-ind) (setq beg-cell (cons (point) ind))) + (forward-line -1)) + ;; Skip blocks, drawers, inline tasks, blank lines. + ((and (looking-at "^[ \t]*#\\+end_") + (re-search-backward "^[ \t]*#\\+begin_" lim-up t))) + ((and (looking-at "^[ \t]*:END:") + (re-search-backward org-drawer-regexp lim-up t)) + (beginning-of-line)) + ((and inlinetask-re (looking-at inlinetask-re)) + (org-inlinetask-goto-beginning) + (forward-line -1)) + ((looking-at "^[ \t]*$") + (forward-line -1)) + ;; From there, point is not at an item. Interpret + ;; line's indentation: + ;; - text at column 0 is necessarily out of any list. + ;; Dismiss data recorded above BEG-CELL. Jump to + ;; part 2. + ;; - any other case may be an ending position for an + ;; hypothetical item above. Store it and proceed. + ((zerop ind) + (throw 'exit + (setq itm-lst + (memq (assq (car beg-cell) itm-lst) itm-lst)))) + (t + (when (< ind text-min-ind) (setq text-min-ind ind)) + (push (cons ind (point)) end-lst) + (forward-line -1))))))) + ;; 2. Read list from starting point to its end, that is until we + ;; get out of context, or that a non-item line is less or + ;; equally indented than BEG-CELL's cdr. Also, store ending + ;; position of items in END-LST-2. + (catch 'exit + (while t + (let ((ind (current-indentation))) + (cond + ((>= (point) lim-down) + ;; At downward limit: this is de facto the end of the + ;; list. Save point as an ending position, and jump to + ;; part 3. + (throw 'exit + (push (cons 0 (funcall end-before-blank)) end-lst-2))) + ;; Looking at a list ending regexp. Save point as an + ;; ending position and jump to part 3. + ((looking-at org-list-end-re) + (throw 'exit (push (cons 0 (point)) end-lst-2))) + ((looking-at item-re) + ;; Point is at an item. Add data to ITM-LST-2. It may + ;; also end a previous item, so save it in END-LST-2. + (push (funcall assoc-at-point ind) itm-lst-2) + (push (cons ind (point)) end-lst-2) + (forward-line 1)) + ;; Skip inline tasks and blank lines along the way + ((and inlinetask-re (looking-at inlinetask-re)) + (org-inlinetask-goto-end)) + ((looking-at "^[ \t]*$") + (forward-line 1)) + ;; Ind is lesser or equal than BEG-CELL's. The list is + ;; over: store point as an ending position and jump to + ;; part 3. + ((<= ind (cdr beg-cell)) + (throw 'exit + (push (cons 0 (funcall end-before-blank)) end-lst-2))) + ;; Else, if ind is lesser or equal than previous item's, + ;; this is an ending position: store it. In any case, + ;; skip block or drawer at point, and move to next line. + (t + (when (<= ind (nth 1 (car itm-lst-2))) + (push (cons ind (point)) end-lst-2)) + (cond + ((and (looking-at "^[ \t]*#\\+begin_") + (re-search-forward "^[ \t]*#\\+end_" lim-down t))) + ((and (looking-at org-drawer-regexp) + (re-search-forward "^[ \t]*:END:" lim-down t)))) + (forward-line 1)))))) + (setq struct (append itm-lst (cdr (nreverse itm-lst-2))) + end-lst (append end-lst (cdr (nreverse end-lst-2)))) + ;; 3. Associate each item to its end position. + (org-list-struct-assoc-end struct end-lst) + ;; 4. Return STRUCT + struct))) + +(defun org-list-struct-assoc-end (struct end-list) + "Associate proper ending point to items in STRUCT. + +END-LIST is a pseudo-alist where car is indentation and cdr is +ending position. + +This function modifies STRUCT." + (let ((endings end-list)) + (mapc + (lambda (elt) + (let ((pos (car elt)) + (ind (nth 1 elt))) + ;; Remove end candidates behind current item. + (while (or (<= (cdar endings) pos)) + (pop endings)) + ;; Add end position to item assoc. + (let ((old-end (nthcdr 6 elt)) + (new-end (assoc-default ind endings '<=))) + (if old-end + (setcar old-end new-end) + (setcdr elt (append (cdr elt) (list new-end))))))) + struct))) + +(defun org-list-prevs-alist (struct) + "Return alist between item and previous item in STRUCT." + (let ((item-end-alist (mapcar (lambda (e) (cons (car e) (nth 6 e))) + struct))) + (mapcar (lambda (e) + (let ((prev (car (rassq (car e) item-end-alist)))) + (cons (car e) prev))) + struct))) + +(defun org-list-parents-alist (struct) + "Return alist between item and parent in STRUCT." + (let* ((ind-to-ori (list (list (nth 1 (car struct))))) + (top-item (org-list-get-top-point struct)) + (prev-pos (list top-item))) + (cons prev-pos + (mapcar (lambda (item) + (let ((pos (car item)) + (ind (nth 1 item)) + (prev-ind (caar ind-to-ori))) + (push pos prev-pos) + (cond + ((> prev-ind ind) + ;; A sub-list is over. Find the associated + ;; origin in IND-TO-ORI. If it cannot be + ;; found (ill-formed list), set its parent as + ;; the first item less indented. If there is + ;; none, make it a top-level item. + (setq ind-to-ori + (or (member (assq ind ind-to-ori) ind-to-ori) + (catch 'exit + (mapc + (lambda (e) + (when (< (car e) ind) + (throw 'exit (member e ind-to-ori)))) + ind-to-ori) + (list (list ind))))) + (cons pos (cdar ind-to-ori))) + ;; A sub-list starts. Every item at IND will + ;; have previous item as its parent. + ((< prev-ind ind) + (let ((origin (nth 1 prev-pos))) + (push (cons ind origin) ind-to-ori) + (cons pos origin))) + ;; Another item in the same sub-list: it shares + ;; the same parent as the previous item. + (t (cons pos (cdar ind-to-ori)))))) + (cdr struct))))) + +(defun org-list--delete-metadata () + "Delete metadata from the heading at point. +Metadata are tags, planning information and properties drawers." + (save-match-data + (org-with-wide-buffer + (org-set-tags nil) + (delete-region (line-beginning-position 2) + (save-excursion + (org-end-of-meta-data) + (org-skip-whitespace) + (if (eobp) (point) (line-beginning-position))))))) + + +;;; Accessors + +(defsubst org-list-get-nth (n key struct) + "Return the Nth value of KEY in STRUCT." + (nth n (assq key struct))) + +(defun org-list-set-nth (n key struct new) + "Set the Nth value of KEY in STRUCT to NEW. +\nThis function modifies STRUCT." + (setcar (nthcdr n (assq key struct)) new)) + +(defsubst org-list-get-ind (item struct) + "Return indentation of ITEM in STRUCT." + (org-list-get-nth 1 item struct)) + +(defun org-list-set-ind (item struct ind) + "Set indentation of ITEM in STRUCT to IND. +\nThis function modifies STRUCT." + (org-list-set-nth 1 item struct ind)) + +(defsubst org-list-get-bullet (item struct) + "Return bullet of ITEM in STRUCT." + (org-list-get-nth 2 item struct)) + +(defun org-list-set-bullet (item struct bullet) + "Set bullet of ITEM in STRUCT to BULLET. +\nThis function modifies STRUCT." + (org-list-set-nth 2 item struct bullet)) + +(defsubst org-list-get-counter (item struct) + "Return counter of ITEM in STRUCT." + (org-list-get-nth 3 item struct)) + +(defsubst org-list-get-checkbox (item struct) + "Return checkbox of ITEM in STRUCT or nil." + (org-list-get-nth 4 item struct)) + +(defun org-list-set-checkbox (item struct checkbox) + "Set checkbox of ITEM in STRUCT to CHECKBOX. +\nThis function modifies STRUCT." + (org-list-set-nth 4 item struct checkbox)) + +(defsubst org-list-get-tag (item struct) + "Return end position of ITEM in STRUCT." + (org-list-get-nth 5 item struct)) + +(defun org-list-get-item-end (item struct) + "Return end position of ITEM in STRUCT." + (org-list-get-nth 6 item struct)) + +(defun org-list-get-item-end-before-blank (item struct) + "Return point at end of ITEM in STRUCT, before any blank line. +Point returned is at end of line." + (save-excursion + (goto-char (org-list-get-item-end item struct)) + (skip-chars-backward " \r\t\n") + (point-at-eol))) + +(defun org-list-get-parent (item struct parents) + "Return parent of ITEM or nil. +STRUCT is the list structure. PARENTS is the alist of parents, +as returned by `org-list-parents-alist'." + (let ((parents (or parents (org-list-parents-alist struct)))) + (cdr (assq item parents)))) + +(defun org-list-has-child-p (item struct) + "Non-nil if ITEM has a child. + +STRUCT is the list structure. + +Value returned is the position of the first child of ITEM." + (let ((ind (org-list-get-ind item struct)) + (child-maybe (car (nth 1 (member (assq item struct) struct))))) + (when (and child-maybe + (< ind (org-list-get-ind child-maybe struct))) + child-maybe))) + +(defun org-list-get-next-item (item _struct prevs) + "Return next item in same sub-list as ITEM, or nil. +STRUCT is the list structure. PREVS is the alist of previous +items, as returned by `org-list-prevs-alist'." + (car (rassq item prevs))) + +(defun org-list-get-prev-item (item _struct prevs) + "Return previous item in same sub-list as ITEM, or nil. +STRUCT is the list structure. PREVS is the alist of previous +items, as returned by `org-list-prevs-alist'." + (cdr (assq item prevs))) + +(defun org-list-get-subtree (item struct) + "List all items having ITEM as a common ancestor, or nil. +STRUCT is the list structure." + (let* ((item-end (org-list-get-item-end item struct)) + (sub-struct (cdr (member (assq item struct) struct))) + items) + (catch :exit + (pcase-dolist (`(,pos . ,_) sub-struct) + (if (< pos item-end) + (push pos items) + (throw :exit nil)))) + (nreverse items))) + +(defun org-list-get-all-items (item struct prevs) + "List all items in the same sub-list as ITEM. +STRUCT is the list structure. PREVS is the alist of previous +items, as returned by `org-list-prevs-alist'." + (let ((prev-item item) + (next-item item) + before-item after-item) + (while (setq prev-item (org-list-get-prev-item prev-item struct prevs)) + (push prev-item before-item)) + (while (setq next-item (org-list-get-next-item next-item struct prevs)) + (push next-item after-item)) + (append before-item (list item) (nreverse after-item)))) + +(defun org-list-get-children (item _struct parents) + "List all children of ITEM, or nil. +STRUCT is the list structure. PARENTS is the alist of parents, +as returned by `org-list-parents-alist'." + (let (all child) + (while (setq child (car (rassq item parents))) + (setq parents (cdr (member (assq child parents) parents))) + (push child all)) + (nreverse all))) + +(defun org-list-get-top-point (struct) + "Return point at beginning of list. +STRUCT is the list structure." + (caar struct)) + +(defun org-list-get-bottom-point (struct) + "Return point at bottom of list. +STRUCT is the list structure." + (apply #'max + (mapcar (lambda (e) (org-list-get-item-end (car e) struct)) struct))) + +(defun org-list-get-list-begin (item struct prevs) + "Return point at beginning of sub-list ITEM belongs. +STRUCT is the list structure. PREVS is the alist of previous +items, as returned by `org-list-prevs-alist'." + (let ((first-item item) prev-item) + (while (setq prev-item (org-list-get-prev-item first-item struct prevs)) + (setq first-item prev-item)) + first-item)) + +(defalias 'org-list-get-first-item 'org-list-get-list-begin) + +(defun org-list-get-last-item (item struct prevs) + "Return point at last item of sub-list ITEM belongs. +STRUCT is the list structure. PREVS is the alist of previous +items, as returned by `org-list-prevs-alist'." + (let ((last-item item) next-item) + (while (setq next-item (org-list-get-next-item last-item struct prevs)) + (setq last-item next-item)) + last-item)) + +(defun org-list-get-list-end (item struct prevs) + "Return point at end of sub-list ITEM belongs. +STRUCT is the list structure. PREVS is the alist of previous +items, as returned by `org-list-prevs-alist'." + (org-list-get-item-end (org-list-get-last-item item struct prevs) struct)) + +(defun org-list-get-list-type (item struct prevs) + "Return the type of the list containing ITEM, as a symbol. + +STRUCT is the list structure. PREVS is the alist of previous +items, as returned by `org-list-prevs-alist'. + +Possible types are `descriptive', `ordered' and `unordered'. The +type is determined by the first item of the list." + (let ((first (org-list-get-list-begin item struct prevs))) + (cond + ((string-match-p "[[:alnum:]]" (org-list-get-bullet first struct)) 'ordered) + ((org-list-get-tag first struct) 'descriptive) + (t 'unordered)))) + +(defun org-list-get-item-number (item struct prevs parents) + "Return ITEM's sequence number. + +STRUCT is the list structure. PREVS is the alist of previous +items, as returned by `org-list-prevs-alist'. PARENTS is the +alist of ancestors, as returned by `org-list-parents-alist'. + +Return value is a list of integers. Counters have an impact on +that value." + (let ((get-relative-number + (lambda (item struct prevs) + ;; Return relative sequence number of ITEM in the sub-list + ;; it belongs. STRUCT is the list structure. PREVS is + ;; the alist of previous items. + (let ((seq 0) (pos item) counter) + (while (and (not (setq counter (org-list-get-counter pos struct))) + (setq pos (org-list-get-prev-item pos struct prevs))) + (cl-incf seq)) + (if (not counter) (1+ seq) + (cond + ((string-match "[A-Za-z]" counter) + (+ (- (string-to-char (upcase (match-string 0 counter))) 64) + seq)) + ((string-match "[0-9]+" counter) + (+ (string-to-number (match-string 0 counter)) seq)) + (t (1+ seq)))))))) + ;; Cons each parent relative number into return value (OUT). + (let ((out (list (funcall get-relative-number item struct prevs))) + (parent item)) + (while (setq parent (org-list-get-parent parent struct parents)) + (push (funcall get-relative-number parent struct prevs) out)) + ;; Return value. + out))) + + + +;;; Searching + +(defun org-list-search-generic (search re bound noerr) + "Search a string in valid contexts for lists. +Arguments SEARCH, RE, BOUND and NOERR are similar to those used +in `re-search-forward'." + (catch 'exit + (let ((origin (point))) + (while t + ;; 1. No match: return to origin or bound, depending on NOERR. + (unless (funcall search re bound noerr) + (throw 'exit (and (goto-char (if (memq noerr '(t nil)) origin bound)) + nil))) + ;; 2. Match in valid context: return point. Else, continue + ;; searching. + (when (org-list-in-valid-context-p) (throw 'exit (point))))))) + +(defun org-list-search-backward (regexp &optional bound noerror) + "Like `re-search-backward' but stop only where lists are recognized. +Arguments REGEXP, BOUND and NOERROR are similar to those used in +`re-search-backward'." + (org-list-search-generic #'re-search-backward + regexp (or bound (point-min)) noerror)) + +(defun org-list-search-forward (regexp &optional bound noerror) + "Like `re-search-forward' but stop only where lists are recognized. +Arguments REGEXP, BOUND and NOERROR are similar to those used in +`re-search-forward'." + (org-list-search-generic #'re-search-forward + regexp (or bound (point-max)) noerror)) + + + +;;; Methods on structures + +(defsubst org-list-bullet-string (bullet) + "Return BULLET with the correct number of whitespaces. +It determines the number of whitespaces to append by looking at +`org-list-two-spaces-after-bullet-regexp'." + (save-match-data + (let ((spaces (if (and org-list-two-spaces-after-bullet-regexp + (string-match + org-list-two-spaces-after-bullet-regexp bullet)) + " " + " "))) + (if (string-match "\\S-+\\([ \t]*\\)" bullet) + (replace-match spaces nil nil bullet 1) + bullet)))) + +(defun org-list-swap-items (beg-A beg-B struct) + "Swap item starting at BEG-A with item starting at BEG-B in STRUCT. + +Blank lines at the end of items are left in place. Item +visibility is preserved. Return the new structure after the +changes. + +Assume BEG-A is lesser than BEG-B and that BEG-A and BEG-B belong +to the same sub-list. + +This function modifies STRUCT." + (save-excursion + (let* ((end-A-no-blank (org-list-get-item-end-before-blank beg-A struct)) + (end-B-no-blank (org-list-get-item-end-before-blank beg-B struct)) + (end-A (org-list-get-item-end beg-A struct)) + (end-B (org-list-get-item-end beg-B struct)) + (size-A (- end-A-no-blank beg-A)) + (size-B (- end-B-no-blank beg-B)) + (body-A (buffer-substring beg-A end-A-no-blank)) + (body-B (buffer-substring beg-B end-B-no-blank)) + (between-A-no-blank-and-B (buffer-substring end-A-no-blank beg-B)) + (sub-A (cons beg-A (org-list-get-subtree beg-A struct))) + (sub-B (cons beg-B (org-list-get-subtree beg-B struct))) + ;; Store overlays responsible for visibility status. We + ;; also need to store their boundaries as they will be + ;; removed from buffer. + (overlays + (cons + (delq nil + (mapcar (lambda (o) + (and (>= (overlay-start o) beg-A) + (<= (overlay-end o) end-A) + (list o (overlay-start o) (overlay-end o)))) + (overlays-in beg-A end-A))) + (delq nil + (mapcar (lambda (o) + (and (>= (overlay-start o) beg-B) + (<= (overlay-end o) end-B) + (list o (overlay-start o) (overlay-end o)))) + (overlays-in beg-B end-B)))))) + ;; 1. Move effectively items in buffer. + (goto-char beg-A) + (delete-region beg-A end-B-no-blank) + (insert (concat body-B between-A-no-blank-and-B body-A)) + ;; 2. Now modify struct. No need to re-read the list, the + ;; transformation is just a shift of positions. Some special + ;; attention is required for items ending at END-A and END-B + ;; as empty spaces are not moved there. In others words, + ;; item BEG-A will end with whitespaces that were at the end + ;; of BEG-B and the same applies to BEG-B. + (dolist (e struct) + (let ((pos (car e))) + (cond + ((< pos beg-A)) + ((memq pos sub-A) + (let ((end-e (nth 6 e))) + (setcar e (+ pos (- end-B-no-blank end-A-no-blank))) + (setcar (nthcdr 6 e) + (+ end-e (- end-B-no-blank end-A-no-blank))) + (when (= end-e end-A) (setcar (nthcdr 6 e) end-B)))) + ((memq pos sub-B) + (let ((end-e (nth 6 e))) + (setcar e (- (+ pos beg-A) beg-B)) + (setcar (nthcdr 6 e) (+ end-e (- beg-A beg-B))) + (when (= end-e end-B) + (setcar (nthcdr 6 e) + (+ beg-A size-B (- end-A end-A-no-blank)))))) + ((< pos beg-B) + (let ((end-e (nth 6 e))) + (setcar e (+ pos (- size-B size-A))) + (setcar (nthcdr 6 e) (+ end-e (- size-B size-A)))))))) + (setq struct (sort struct #'car-less-than-car)) + ;; Restore visibility status, by moving overlays to their new + ;; position. + (dolist (ov (car overlays)) + (move-overlay + (car ov) + (+ (nth 1 ov) (- (+ beg-B (- size-B size-A)) beg-A)) + (+ (nth 2 ov) (- (+ beg-B (- size-B size-A)) beg-A)))) + (dolist (ov (cdr overlays)) + (move-overlay (car ov) + (+ (nth 1 ov) (- beg-A beg-B)) + (+ (nth 2 ov) (- beg-A beg-B)))) + ;; Return structure. + struct))) + +(defun org-list-separating-blank-lines-number (pos struct prevs) + "Return number of blank lines that should separate items in list. + +POS is the position of point where `org-list-insert-item' was called. + +STRUCT is the list structure. PREVS is the alist of previous +items, as returned by `org-list-prevs-alist'. + +Assume point is at item's beginning. If the item is alone, apply +some heuristics to guess the result." + (save-excursion + (let ((item (point)) + (insert-blank-p + (cdr (assq 'plain-list-item org-blank-before-new-entry))) + usr-blank + (count-blanks + (lambda () + ;; Count blank lines above beginning of line. + (save-excursion + (count-lines (goto-char (point-at-bol)) + (progn (skip-chars-backward " \r\t\n") + (forward-line) + (point))))))) + (cond + ;; Trivial cases where there should be none. + ((not insert-blank-p) 0) + ;; When `org-blank-before-new-entry' says so, it is 1. + ((eq insert-blank-p t) 1) + ;; `plain-list-item' is 'auto. Count blank lines separating + ;; neighbors' items in list. + (t (let ((next-p (org-list-get-next-item item struct prevs))) + (cond + ;; Is there a next item? + (next-p (goto-char next-p) + (funcall count-blanks)) + ;; Is there a previous item? + ((org-list-get-prev-item item struct prevs) + (funcall count-blanks)) + ;; User inserted blank lines, trust him. + ((and (> pos (org-list-get-item-end-before-blank item struct)) + (> (save-excursion (goto-char pos) + (setq usr-blank (funcall count-blanks))) + 0)) + usr-blank) + ;; Are there blank lines inside the list so far? + ((save-excursion + (goto-char (org-list-get-top-point struct)) + ;; Do not use `org-list-search-forward' so blank lines + ;; in blocks can be counted in. + (re-search-forward + "^[ \t]*$" (org-list-get-item-end-before-blank item struct) t)) + 1) + ;; Default choice: no blank line. + (t 0)))))))) + +(defun org-list-insert-item (pos struct prevs &optional checkbox after-bullet) + "Insert a new list item at POS and return the new structure. +If POS is before first character after bullet of the item, the +new item will be created before the current one. + +STRUCT is the list structure. PREVS is the alist of previous +items, as returned by `org-list-prevs-alist'. + +Insert a checkbox if CHECKBOX is non-nil, and string AFTER-BULLET +after the bullet. Cursor will be after this text once the +function ends. + +This function modifies STRUCT." + (let* ((case-fold-search t) + ;; Get information about list: ITEM containing POS, position + ;; of point with regards to item start (BEFOREP), blank lines + ;; number separating items (BLANK-NB), if we're allowed to + ;; (SPLIT-LINE-P). + (item + (catch :exit + (let ((i nil)) + (pcase-dolist (`(,start ,_ ,_ ,_ ,_ ,_ ,end) struct) + (cond + ((> start pos) (throw :exit i)) + ((< end pos) nil) ;skip sub-lists before point + (t (setq i start)))) + ;; If no suitable item is found, insert a sibling of the + ;; last item in buffer. + (or i (caar (reverse struct)))))) + (item-end (org-list-get-item-end item struct)) + (item-end-no-blank (org-list-get-item-end-before-blank item struct)) + (beforep + (progn + (goto-char item) + (looking-at org-list-full-item-re) + (<= pos + (cond + ((not (match-beginning 4)) (match-end 0)) + ;; Ignore tag in a non-descriptive list. + ((save-match-data (string-match "[.)]" (match-string 1))) + (match-beginning 4)) + (t (save-excursion + (goto-char (match-end 4)) + (skip-chars-forward " \t") + (point))))))) + (split-line-p (org-get-alist-option org-M-RET-may-split-line 'item)) + (blank-nb (org-list-separating-blank-lines-number pos struct prevs)) + ;; Build the new item to be created. Concatenate same bullet + ;; as item, checkbox, text AFTER-BULLET if provided, and text + ;; cut from point to end of item (TEXT-CUT) to form item's + ;; BODY. TEXT-CUT depends on BEFOREP and SPLIT-LINE-P. The + ;; difference of size between what was cut and what was + ;; inserted in buffer is stored in SIZE-OFFSET. + (ind (org-list-get-ind item struct)) + (ind-size (if indent-tabs-mode + (+ (/ ind tab-width) (mod ind tab-width)) + ind)) + (bullet (org-list-bullet-string (org-list-get-bullet item struct))) + (box (and checkbox "[ ]")) + (text-cut + (and (not beforep) + split-line-p + (progn + (goto-char pos) + ;; If POS is greater than ITEM-END, then point is in + ;; some white lines after the end of the list. Those + ;; must be removed, or they will be left, stacking up + ;; after the list. + (when (< item-end pos) + (delete-region (1- item-end) (point-at-eol))) + (skip-chars-backward " \r\t\n") + ;; Cut position is after any blank on the line. + (save-excursion + (skip-chars-forward " \t") + (setq pos (point))) + (delete-and-extract-region (point) item-end-no-blank)))) + (body + (concat bullet + (and box (concat box " ")) + after-bullet + (and text-cut + (if (string-match "\\`[ \t]+" text-cut) + (replace-match "" t t text-cut) + text-cut)))) + (item-sep (make-string (1+ blank-nb) ?\n)) + (item-size (+ ind-size (length body) (length item-sep))) + (size-offset (- item-size (length text-cut)))) + ;; Insert effectively item into buffer. + (goto-char item) + (indent-to-column ind) + (insert body item-sep) + ;; Add new item to STRUCT. + (dolist (e struct) + (let ((p (car e)) (end (nth 6 e))) + (cond + ;; Before inserted item, positions don't change but an item + ;; ending after insertion has its end shifted by SIZE-OFFSET. + ((< p item) + (when (> end item) + (setcar (nthcdr 6 e) (+ end size-offset)))) + ;; Item where insertion happens may be split in two parts. + ;; In this case, move start by ITEM-SIZE and end by + ;; SIZE-OFFSET. + ((and (= p item) (not beforep) split-line-p) + (setcar e (+ p item-size)) + (setcar (nthcdr 6 e) (+ end size-offset))) + ;; Items starting after modified item fall into two + ;; categories. + ;; + ;; If modified item was split, and current sub-item was + ;; located after split point, it was moved to the new item: + ;; the part between body start and split point (POS) was + ;; removed. So we compute the length of that part and shift + ;; item's positions accordingly. + ;; + ;; Otherwise, the item was simply shifted by SIZE-OFFSET. + ((and split-line-p (not beforep) (>= p pos) (<= p item-end-no-blank)) + (let ((offset (- pos item ind (length bullet) (length after-bullet)))) + (setcar e (- p offset)) + (setcar (nthcdr 6 e) (- end offset)))) + (t + (setcar e (+ p size-offset)) + (setcar (nthcdr 6 e) (+ end size-offset)))))) + (push (list item ind bullet nil box nil (+ item item-size)) struct) + (setq struct (sort struct #'car-less-than-car)) + ;; If not BEFOREP, new item must appear after ITEM, so exchange + ;; ITEM with the next item in list. Position cursor after bullet, + ;; counter, checkbox, and label. + (if beforep + (goto-char item) + (setq struct (org-list-swap-items item (+ item item-size) struct)) + (goto-char (org-list-get-next-item + item struct (org-list-prevs-alist struct)))) + struct)) + +(defun org-list-delete-item (item struct) + "Remove ITEM from the list and return the new structure. + +STRUCT is the list structure." + (let* ((end (org-list-get-item-end item struct)) + (beg (if (= (org-list-get-bottom-point struct) end) + ;; If ITEM ends with the list, delete blank lines + ;; before it. + (save-excursion + (goto-char item) + (skip-chars-backward " \r\t\n") + (min (1+ (point-at-eol)) (point-max))) + item))) + ;; Remove item from buffer. + (delete-region beg end) + ;; Remove item from structure and shift others items accordingly. + ;; Don't forget to shift also ending position when appropriate. + (let ((size (- end beg))) + (delq nil (mapcar (lambda (e) + (let ((pos (car e))) + (cond + ((< pos item) + (let ((end-e (nth 6 e))) + (cond + ((< end-e item) e) + ((= end-e item) + (append (butlast e) (list beg))) + (t + (append (butlast e) (list (- end-e size))))))) + ((< pos end) nil) + (t + (cons (- pos size) + (append (butlast (cdr e)) + (list (- (nth 6 e) size)))))))) + struct))))) + +(defun org-list-send-item (item dest struct) + "Send ITEM to destination DEST. + +STRUCT is the list structure. + +DEST can have various values. + +If DEST is a buffer position, the function will assume it points +to another item in the same list as ITEM, and will move the +latter just before the former. + +If DEST is `begin' (respectively `end'), ITEM will be moved at +the beginning (respectively end) of the list it belongs to. + +If DEST is a string like \"N\", where N is an integer, ITEM will +be moved at the Nth position in the list. + +If DEST is `kill', ITEM will be deleted and its body will be +added to the kill-ring. + +If DEST is `delete', ITEM will be deleted. + +Visibility of item is preserved. + +This function returns, destructively, the new list structure." + (let* ((prevs (org-list-prevs-alist struct)) + (item-end (org-list-get-item-end item struct)) + ;; Grab full item body minus its bullet. + (body (org-trim + (buffer-substring + (save-excursion + (goto-char item) + (looking-at + (concat "[ \t]*" + (regexp-quote (org-list-get-bullet item struct)))) + (match-end 0)) + item-end))) + ;; Change DEST into a buffer position. A trick is needed + ;; when ITEM is meant to be sent at the end of the list. + ;; Indeed, by setting locally `org-M-RET-may-split-line' to + ;; nil and insertion point (INS-POINT) to the first line's + ;; end of the last item, we ensure the new item will be + ;; inserted after the last item, and not after any of its + ;; hypothetical sub-items. + (ins-point (cond + ((or (eq dest 'kill) (eq dest 'delete))) + ((eq dest 'begin) + (setq dest (org-list-get-list-begin item struct prevs))) + ((eq dest 'end) + (setq dest (org-list-get-list-end item struct prevs)) + (save-excursion + (goto-char (org-list-get-last-item item struct prevs)) + (point-at-eol))) + ((string-match-p "\\`[0-9]+\\'" dest) + (let* ((all (org-list-get-all-items item struct prevs)) + (len (length all)) + (index (mod (string-to-number dest) len))) + (if (not (zerop index)) + (setq dest (nth (1- index) all)) + ;; Send ITEM at the end of the list. + (setq dest (org-list-get-list-end item struct prevs)) + (save-excursion + (goto-char + (org-list-get-last-item item struct prevs)) + (point-at-eol))))) + (t dest))) + (org-M-RET-may-split-line nil) + ;; Store inner overlays (to preserve visibility). + (overlays (cl-remove-if (lambda (o) (or (< (overlay-start o) item) + (> (overlay-end o) item))) + (overlays-in item item-end)))) + (cond + ((eq dest 'delete) (org-list-delete-item item struct)) + ((eq dest 'kill) + (kill-new body) + (org-list-delete-item item struct)) + ((and (integerp dest) (/= item ins-point)) + (setq item (copy-marker item)) + (setq struct (org-list-insert-item ins-point struct prevs nil body)) + ;; 1. Structure returned by `org-list-insert-item' may not be + ;; accurate, as it cannot see sub-items included in BODY. + ;; Thus, first compute the real structure so far. + (let ((moved-items + (cons (marker-position item) + (org-list-get-subtree (marker-position item) struct))) + (new-end (org-list-get-item-end (point) struct)) + (old-end (org-list-get-item-end (marker-position item) struct)) + (new-item (point)) + (shift (- (point) item))) + ;; 1.1. Remove the item just created in structure. + (setq struct (delete (assq new-item struct) struct)) + ;; 1.2. Copy ITEM and any of its sub-items at NEW-ITEM. + (setq struct (sort + (append + struct + (mapcar (lambda (e) + (let* ((cell (assq e struct)) + (pos (car cell)) + (end (nth 6 cell))) + (cons (+ pos shift) + (append (butlast (cdr cell)) + (list (if (= end old-end) + new-end + (+ end shift))))))) + moved-items)) + #'car-less-than-car))) + ;; 2. Restore inner overlays. + (dolist (o overlays) + (move-overlay o + (+ (overlay-start o) (- (point) item)) + (+ (overlay-end o) (- (point) item)))) + ;; 3. Eventually delete extra copy of the item and clean marker. + (prog1 (org-list-delete-item (marker-position item) struct) + (move-marker item nil))) + (t struct)))) + +(defun org-list-struct-outdent (start end struct parents) + "Outdent items between positions START and END. + +STRUCT is the list structure. PARENTS is the alist of items' +parents, as returned by `org-list-parents-alist'. + +START is included, END excluded." + (let* (acc + (out (lambda (cell) + (let* ((item (car cell)) + (parent (cdr cell))) + (cond + ;; Item not yet in zone: keep association. + ((< item start) cell) + ;; Item out of zone: follow associations in ACC. + ((>= item end) + (let ((convert (and parent (assq parent acc)))) + (if convert (cons item (cdr convert)) cell))) + ;; Item has no parent: error + ((not parent) + (error "Cannot outdent top-level items")) + ;; Parent is outdented: keep association. + ((>= parent start) + (push (cons parent item) acc) cell) + (t + ;; Parent isn't outdented: reparent to grand-parent. + (let ((grand-parent (org-list-get-parent + parent struct parents))) + (push (cons parent item) acc) + (cons item grand-parent)))))))) + (mapcar out parents))) + +(defun org-list-struct-indent (start end struct parents prevs) + "Indent items between positions START and END. + +STRUCT is the list structure. PARENTS is the alist of parents +and PREVS is the alist of previous items, returned by, +respectively, `org-list-parents-alist' and +`org-list-prevs-alist'. + +START is included and END excluded. + +STRUCT may be modified if `org-list-demote-modify-bullet' matches +bullets between START and END." + (let* (acc + (set-assoc (lambda (cell) (push cell acc) cell)) + (ind + (lambda (cell) + (let* ((item (car cell)) + (parent (cdr cell))) + (cond + ;; Item not yet in zone: keep association. + ((< item start) cell) + ((>= item end) + ;; Item out of zone: follow associations in ACC. + (let ((convert (assq parent acc))) + (if convert (cons item (cdr convert)) cell))) + (t + ;; Item is in zone... + (let ((prev (org-list-get-prev-item item struct prevs))) + ;; Check if bullet needs to be changed. + (pcase (assoc (let ((b (org-list-get-bullet item struct)) + (case-fold-search nil)) + (cond ((string-match "[A-Z]\\." b) "A.") + ((string-match "[A-Z])" b) "A)") + ((string-match "[a-z]\\." b) "a.") + ((string-match "[a-z])" b) "a)") + ((string-match "[0-9]\\." b) "1.") + ((string-match "[0-9])" b) "1)") + (t (org-trim b)))) + org-list-demote-modify-bullet) + (`(,_ . ,bullet) + (org-list-set-bullet + item struct (org-list-bullet-string bullet))) + (_ nil)) + (cond + ;; First item indented but not parent: error + ((and (not prev) (or (not parent) (< parent start))) + (user-error "Cannot indent the first item of a list")) + ;; First item and parent indented: keep same + ;; parent. + ((not prev) (funcall set-assoc cell)) + ;; Previous item not indented: reparent to it. + ((< prev start) (funcall set-assoc (cons item prev))) + ;; Previous item indented: reparent like it. + (t + (funcall set-assoc + (cons item (cdr (assq prev acc))))))))))))) + (mapcar ind parents))) + + + +;;; Repairing structures + +(defun org-list-use-alpha-bul-p (first struct prevs) + "Non-nil if list starting at FIRST can have alphabetical bullets. + +STRUCT is list structure. PREVS is the alist of previous items, +as returned by `org-list-prevs-alist'." + (and org-list-allow-alphabetical + (catch 'exit + (let ((item first) (ascii 64) (case-fold-search nil)) + ;; Pretend that bullets are uppercase and check if alphabet + ;; is sufficient, taking counters into account. + (while item + (let ((count (org-list-get-counter item struct))) + ;; Virtually determine current bullet + (if (and count (string-match-p "[a-zA-Z]" count)) + ;; Counters are not case-sensitive. + (setq ascii (string-to-char (upcase count))) + (setq ascii (1+ ascii))) + ;; Test if bullet would be over z or Z. + (if (> ascii 90) + (throw 'exit nil) + (setq item (org-list-get-next-item item struct prevs))))) + ;; All items checked. All good. + t)))) + +(defun org-list-inc-bullet-maybe (bullet) + "Increment BULLET if applicable." + (let ((case-fold-search nil)) + (cond + ;; Num bullet: increment it. + ((string-match "[0-9]+" bullet) + (replace-match + (number-to-string (1+ (string-to-number (match-string 0 bullet)))) + nil nil bullet)) + ;; Alpha bullet: increment it. + ((string-match "[A-Za-z]" bullet) + (replace-match + (char-to-string (1+ (string-to-char (match-string 0 bullet)))) + nil nil bullet)) + ;; Unordered bullet: leave it. + (t bullet)))) + +(defun org-list-struct-fix-bul (struct prevs) + "Verify and correct bullets in STRUCT. +PREVS is the alist of previous items, as returned by +`org-list-prevs-alist'. + +This function modifies STRUCT." + (let ((case-fold-search nil) + (fix-bul + ;; Set bullet of ITEM in STRUCT, depending on the type of + ;; first item of the list, the previous bullet and counter + ;; if any. + (lambda (item) + (let* ((prev (org-list-get-prev-item item struct prevs)) + (prev-bul (and prev (org-list-get-bullet prev struct))) + (counter (org-list-get-counter item struct)) + (bullet (org-list-get-bullet item struct)) + (alphap (and (not prev) + (org-list-use-alpha-bul-p item struct prevs)))) + (org-list-set-bullet + item struct + (org-list-bullet-string + (cond + ;; Alpha counter in alpha list: use counter. + ((and prev counter + (string-match "[a-zA-Z]" counter) + (string-match "[a-zA-Z]" prev-bul)) + ;; Use cond to be sure `string-match' is used in + ;; both cases. + (let ((real-count + (cond + ((string-match "[a-z]" prev-bul) (downcase counter)) + ((string-match "[A-Z]" prev-bul) (upcase counter))))) + (replace-match real-count nil nil prev-bul))) + ;; Num counter in a num list: use counter. + ((and prev counter + (string-match "[0-9]+" counter) + (string-match "[0-9]+" prev-bul)) + (replace-match counter nil nil prev-bul)) + ;; No counter: increase, if needed, previous bullet. + (prev + (org-list-inc-bullet-maybe (org-list-get-bullet prev struct))) + ;; Alpha counter at first item: use counter. + ((and counter (org-list-use-alpha-bul-p item struct prevs) + (string-match "[A-Za-z]" counter) + (string-match "[A-Za-z]" bullet)) + (let ((real-count + (cond + ((string-match "[a-z]" bullet) (downcase counter)) + ((string-match "[A-Z]" bullet) (upcase counter))))) + (replace-match real-count nil nil bullet))) + ;; Num counter at first item: use counter. + ((and counter + (string-match "[0-9]+" counter) + (string-match "[0-9]+" bullet)) + (replace-match counter nil nil bullet)) + ;; First bullet is alpha uppercase: use "A". + ((and alphap (string-match "[A-Z]" bullet)) + (replace-match "A" nil nil bullet)) + ;; First bullet is alpha lowercase: use "a". + ((and alphap (string-match "[a-z]" bullet)) + (replace-match "a" nil nil bullet)) + ;; First bullet is num: use "1". + ((string-match "\\([0-9]+\\|[A-Za-z]\\)" bullet) + (replace-match "1" nil nil bullet)) + ;; Not an ordered list: keep bullet. + (t bullet)))))))) + (mapc fix-bul (mapcar #'car struct)))) + +(defun org-list-struct-fix-ind (struct parents &optional bullet-size) + "Verify and correct indentation in STRUCT. + +PARENTS is the alist of parents, as returned by +`org-list-parents-alist'. + +If numeric optional argument BULLET-SIZE is set, assume all +bullets in list have this length to determine new indentation. + +This function modifies STRUCT." + (let* ((ancestor (org-list-get-top-point struct)) + (top-ind (org-list-get-ind ancestor struct)) + (new-ind + (lambda (item) + (let ((parent (org-list-get-parent item struct parents))) + (if parent + ;; Indent like parent + length of parent's bullet + + ;; sub-list offset. + (org-list-set-ind + item struct (+ (or bullet-size + (length + (org-list-get-bullet parent struct))) + (org-list-get-ind parent struct) + org-list-indent-offset)) + ;; If no parent, indent like top-point. + (org-list-set-ind item struct top-ind)))))) + (mapc new-ind (mapcar #'car (cdr struct))))) + +(defun org-list-struct-fix-box (struct parents prevs &optional ordered) + "Verify and correct checkboxes in STRUCT. + +PARENTS is the alist of parents and PREVS is the alist of +previous items, as returned by, respectively, +`org-list-parents-alist' and `org-list-prevs-alist'. + +If ORDERED is non-nil, a checkbox can only be checked when every +checkbox before it is checked too. If there was an attempt to +break this rule, the function will return the blocking item. In +all others cases, the return value will be nil. + +This function modifies STRUCT." + (let ((all-items (mapcar #'car struct)) + (set-parent-box + (lambda (item) + (let* ((box-list + (mapcar (lambda (child) + (org-list-get-checkbox child struct)) + (org-list-get-children item struct parents)))) + (org-list-set-checkbox + item struct + (cond + ((and (member "[ ]" box-list) (member "[X]" box-list)) "[-]") + ((member "[-]" box-list) "[-]") + ((member "[X]" box-list) "[X]") + ((member "[ ]" box-list) "[ ]") + ;; Parent has no boxed child: leave box as-is. + (t (org-list-get-checkbox item struct))))))) + parent-list) + ;; 1. List all parents with a checkbox. + (mapc + (lambda (e) + (let* ((parent (org-list-get-parent e struct parents)) + (parent-box-p (org-list-get-checkbox parent struct))) + (when (and parent-box-p (not (memq parent parent-list))) + (push parent parent-list)))) + all-items) + ;; 2. Sort those parents by decreasing indentation. + (setq parent-list (sort parent-list + (lambda (e1 e2) + (> (org-list-get-ind e1 struct) + (org-list-get-ind e2 struct))))) + ;; 3. For each parent, get all children's checkboxes to determine + ;; and set its checkbox accordingly. + (mapc set-parent-box parent-list) + ;; 4. If ORDERED is set, see if we need to uncheck some boxes. + (when ordered + (let* ((box-list + (mapcar (lambda (e) (org-list-get-checkbox e struct)) all-items)) + (after-unchecked (member "[ ]" box-list))) + ;; There are boxes checked after an unchecked one: fix that. + (when (member "[X]" after-unchecked) + (let ((index (- (length struct) (length after-unchecked)))) + (dolist (e (nthcdr index all-items)) + (when (org-list-get-checkbox e struct) + (org-list-set-checkbox e struct "[ ]"))) + ;; Verify once again the structure, without ORDERED. + (org-list-struct-fix-box struct parents prevs nil) + ;; Return blocking item. + (nth index all-items))))))) + +(defun org-list-struct-fix-item-end (struct) + "Verify and correct each item end position in STRUCT. + +This function modifies STRUCT." + (let (end-list acc-end) + (pcase-dolist (`(,pos . ,_) struct) + (let ((ind-pos (org-list-get-ind pos struct)) + (end-pos (org-list-get-item-end pos struct))) + (unless (assq end-pos struct) + ;; To determine real ind of an ending position that is not + ;; at an item, we have to find the item it belongs to: it is + ;; the last item (ITEM-UP), whose ending is further than the + ;; position we're interested in. + (let ((item-up (assoc-default end-pos acc-end #'>))) + (push (cons + ;; Else part is for the bottom point. + (if item-up (+ (org-list-get-ind item-up struct) 2) 0) + end-pos) + end-list))) + (push (cons ind-pos pos) end-list) + (push (cons end-pos pos) acc-end))) + (setq end-list (sort end-list (lambda (e1 e2) (< (cdr e1) (cdr e2))))) + (org-list-struct-assoc-end struct end-list))) + +(defun org-list-struct-apply-struct (struct old-struct) + "Apply set difference between STRUCT and OLD-STRUCT to the buffer. + +OLD-STRUCT is the structure before any modifications, and STRUCT +the structure to be applied. The function will only modify parts +of the list which have changed. + +Initial position of cursor is restored after the changes." + (let* ((origin (point-marker)) + (inlinetask-re (and (featurep 'org-inlinetask) + (org-inlinetask-outline-regexp))) + (item-re (org-item-re)) + (shift-body-ind + ;; Shift the indentation between END and BEG by DELTA. + ;; Start from the line before END. + (lambda (end beg delta) + (goto-char end) + (skip-chars-backward " \r\t\n") + (beginning-of-line) + (while (or (> (point) beg) + (and (= (point) beg) + (not (looking-at item-re)))) + (cond + ;; Skip inline tasks. + ((and inlinetask-re (looking-at inlinetask-re)) + (org-inlinetask-goto-beginning)) + ;; Shift only non-empty lines. + ((looking-at-p "^[ \t]*\\S-") + (indent-line-to (+ (current-indentation) delta)))) + (forward-line -1)))) + (modify-item + ;; Replace ITEM first line elements with new elements from + ;; STRUCT, if appropriate. + (lambda (item) + (goto-char item) + (let* ((new-ind (org-list-get-ind item struct)) + (old-ind (current-indentation)) + (new-bul (org-list-bullet-string + (org-list-get-bullet item struct))) + (old-bul (org-list-get-bullet item old-struct)) + (new-box (org-list-get-checkbox item struct))) + (looking-at org-list-full-item-re) + ;; a. Replace bullet + (unless (equal old-bul new-bul) + (replace-match new-bul nil nil nil 1)) + ;; b. Replace checkbox. + (cond + ((equal (match-string 3) new-box)) + ((and (match-string 3) new-box) + (replace-match new-box nil nil nil 3)) + ((match-string 3) + (looking-at ".*?\\([ \t]*\\[[ X-]\\]\\)") + (replace-match "" nil nil nil 1)) + (t (let ((counterp (match-end 2))) + (goto-char (if counterp (1+ counterp) (match-end 1))) + (insert (concat new-box (unless counterp " ")))))) + ;; c. Indent item to appropriate column. + (unless (= new-ind old-ind) + (delete-region (goto-char (point-at-bol)) + (progn (skip-chars-forward " \t") (point))) + (indent-to new-ind)))))) + ;; 1. First get list of items and position endings. We maintain + ;; two alists: ITM-SHIFT, determining indentation shift needed + ;; at item, and END-LIST, a pseudo-alist where key is ending + ;; position and value point. + (let (end-list acc-end itm-shift all-ends sliced-struct) + (dolist (e old-struct) + (let* ((pos (car e)) + (ind-pos (org-list-get-ind pos struct)) + (ind-old (org-list-get-ind pos old-struct)) + (bul-pos (org-list-get-bullet pos struct)) + (bul-old (org-list-get-bullet pos old-struct)) + (ind-shift (- (+ ind-pos (length bul-pos)) + (+ ind-old (length bul-old)))) + (end-pos (org-list-get-item-end pos old-struct))) + (push (cons pos ind-shift) itm-shift) + (unless (assq end-pos old-struct) + ;; To determine real ind of an ending position that + ;; is not at an item, we have to find the item it + ;; belongs to: it is the last item (ITEM-UP), whose + ;; ending is further than the position we're + ;; interested in. + (let ((item-up (assoc-default end-pos acc-end #'>))) + (push (cons end-pos item-up) end-list))) + (push (cons end-pos pos) acc-end))) + ;; 2. Slice the items into parts that should be shifted by the + ;; same amount of indentation. Each slice follow the pattern + ;; (END BEG DELTA). Slices are returned in reverse order. + (setq all-ends (sort (append (mapcar #'car itm-shift) + (org-uniquify (mapcar #'car end-list))) + #'<) + acc-end (nreverse acc-end)) + (while (cdr all-ends) + (let* ((up (pop all-ends)) + (down (car all-ends)) + (itemp (assq up struct)) + (delta + (if itemp (cdr (assq up itm-shift)) + ;; If we're not at an item, there's a child of the + ;; item point belongs to above. Make sure the less + ;; indented line in this slice has the same column + ;; as that child. + (let* ((child (cdr (assq up acc-end))) + (ind (org-list-get-ind child struct)) + (min-ind most-positive-fixnum)) + (save-excursion + (goto-char up) + (while (< (point) down) + ;; Ignore empty lines. Also ignore blocks and + ;; drawers contents. + (unless (looking-at-p "[ \t]*$") + (setq min-ind (min (current-indentation) min-ind)) + (cond + ((and (looking-at "#\\+BEGIN\\(:\\|_\\S-+\\)") + (re-search-forward + (format "^[ \t]*#\\+END%s[ \t]*$" + (match-string 1)) + down t))) + ((and (looking-at org-drawer-regexp) + (re-search-forward "^[ \t]*:END:[ \t]*$" + down t))))) + (forward-line))) + (- ind min-ind))))) + (push (list down up delta) sliced-struct))) + ;; 3. Shift each slice in buffer, provided delta isn't 0, from + ;; end to beginning. Take a special action when beginning is + ;; at item bullet. + (dolist (e sliced-struct) + (unless (zerop (nth 2 e)) (apply shift-body-ind e)) + (let* ((beg (nth 1 e)) + (cell (assq beg struct))) + (unless (or (not cell) (equal cell (assq beg old-struct))) + (funcall modify-item beg))))) + ;; 4. Go back to initial position and clean marker. + (goto-char origin) + (move-marker origin nil))) + +(defun org-list-write-struct (struct parents &optional old-struct) + "Correct bullets, checkboxes and indentation in list at point. + +STRUCT is the list structure. PARENTS is the alist of parents, +as returned by `org-list-parents-alist'. + +When non-nil, optional argument OLD-STRUCT is the reference +structure of the list. It should be provided whenever STRUCT +doesn't correspond anymore to the real list in buffer." + ;; Order of functions matters here: checkboxes and endings need + ;; correct indentation to be set, and indentation needs correct + ;; bullets. + ;; + ;; 0. Save a copy of structure before modifications + (let ((old-struct (or old-struct (copy-tree struct)))) + ;; 1. Set a temporary, but coherent with PARENTS, indentation in + ;; order to get items endings and bullets properly + (org-list-struct-fix-ind struct parents 2) + ;; 2. Fix each item end to get correct prevs alist. + (org-list-struct-fix-item-end struct) + ;; 3. Get bullets right. + (let ((prevs (org-list-prevs-alist struct))) + (org-list-struct-fix-bul struct prevs) + ;; 4. Now get real indentation. + (org-list-struct-fix-ind struct parents) + ;; 5. Eventually fix checkboxes. + (org-list-struct-fix-box struct parents prevs)) + ;; 6. Apply structure modifications to buffer. + (org-list-struct-apply-struct struct old-struct)) + ;; 7. Return the updated structure + struct) + + + +;;; Misc Tools + +(defun org-apply-on-list (function init-value &rest args) + "Call FUNCTION on each item of the list at point. +FUNCTION must be called with at least one argument: INIT-VALUE, +that will contain the value returned by the function at the +previous item, plus ARGS extra arguments. + +FUNCTION is applied on items in reverse order. + +As an example, \(org-apply-on-list \(lambda \(result) \(1+ result)) 0) +will return the number of items in the current list. + +Sublists of the list are skipped. Cursor is always at the +beginning of the item." + (let* ((struct (org-list-struct)) + (prevs (org-list-prevs-alist struct)) + (item (copy-marker (point-at-bol))) + (all (org-list-get-all-items (marker-position item) struct prevs)) + (value init-value)) + (dolist (e (nreverse all)) + (goto-char e) + (setq value (apply function value args))) + (goto-char item) + (move-marker item nil) + value)) + +(defun org-list-set-item-visibility (item struct view) + "Set visibility of ITEM in STRUCT to VIEW. + +Possible values are: `folded', `children' or `subtree'. See +`org-cycle' for more information." + (cond + ((eq view 'folded) + (let ((item-end (org-list-get-item-end-before-blank item struct))) + ;; Hide from eol + (org-flag-region (save-excursion (goto-char item) (line-end-position)) + item-end t 'outline))) + ((eq view 'children) + ;; First show everything. + (org-list-set-item-visibility item struct 'subtree) + ;; Then fold every child. + (let* ((parents (org-list-parents-alist struct)) + (children (org-list-get-children item struct parents))) + (dolist (child children) + (org-list-set-item-visibility child struct 'folded)))) + ((eq view 'subtree) + ;; Show everything + (let ((item-end (org-list-get-item-end item struct))) + (org-flag-region item item-end nil 'outline))))) + +(defun org-list-item-body-column (item) + "Return column at which body of ITEM should start." + (save-excursion + (goto-char item) + (looking-at "[ \t]*\\(\\S-+\\)") + (+ (progn (goto-char (match-end 1)) (current-column)) + (if (and org-list-two-spaces-after-bullet-regexp + (string-match-p org-list-two-spaces-after-bullet-regexp + (match-string 1))) + 2 + 1)))) + + + +;;; Interactive functions + +(defalias 'org-list-get-item-begin 'org-in-item-p) + +(defun org-beginning-of-item () + "Go to the beginning of the current item. +Throw an error when not in a list." + (interactive) + (let ((begin (org-in-item-p))) + (if begin (goto-char begin) (error "Not in an item")))) + +(defun org-beginning-of-item-list () + "Go to the beginning item of the current list or sublist. +Throw an error when not in a list." + (interactive) + (let ((begin (org-in-item-p))) + (if (not begin) + (error "Not in an item") + (goto-char begin) + (let* ((struct (org-list-struct)) + (prevs (org-list-prevs-alist struct))) + (goto-char (org-list-get-list-begin begin struct prevs)))))) + +(defun org-end-of-item-list () + "Go to the end of the current list or sublist. +Throw an error when not in a list." + (interactive) + (let ((begin (org-in-item-p))) + (if (not begin) + (error "Not in an item") + (goto-char begin) + (let* ((struct (org-list-struct)) + (prevs (org-list-prevs-alist struct))) + (goto-char (org-list-get-list-end begin struct prevs)))))) + +(defun org-end-of-item () + "Go to the end of the current item. +Throw an error when not in a list." + (interactive) + (let ((begin (org-in-item-p))) + (if (not begin) + (error "Not in an item") + (goto-char begin) + (let ((struct (org-list-struct))) + (goto-char (org-list-get-item-end begin struct)))))) + +(defun org-previous-item () + "Move to the beginning of the previous item. +Throw an error when not in a list. Also throw an error when at +first item, unless `org-list-use-circular-motion' is non-nil." + (interactive) + (let ((item (org-in-item-p))) + (if (not item) + (error "Not in an item") + (goto-char item) + (let* ((struct (org-list-struct)) + (prevs (org-list-prevs-alist struct)) + (prevp (org-list-get-prev-item item struct prevs))) + (cond + (prevp (goto-char prevp)) + (org-list-use-circular-motion + (goto-char (org-list-get-last-item item struct prevs))) + (t (error "On first item"))))))) + +(defun org-next-item () + "Move to the beginning of the next item. +Throw an error when not in a list. Also throw an error when at +last item, unless `org-list-use-circular-motion' is non-nil." + (interactive) + (let ((item (org-in-item-p))) + (if (not item) + (error "Not in an item") + (goto-char item) + (let* ((struct (org-list-struct)) + (prevs (org-list-prevs-alist struct)) + (prevp (org-list-get-next-item item struct prevs))) + (cond + (prevp (goto-char prevp)) + (org-list-use-circular-motion + (goto-char (org-list-get-first-item item struct prevs))) + (t (error "On last item"))))))) + +(defun org-move-item-down () + "Move the item at point down, i.e. swap with following item. +Sub-items (items with larger indentation) are considered part of +the item, so this really moves item trees." + (interactive) + (unless (org-at-item-p) (error "Not at an item")) + (let* ((col (current-column)) + (item (point-at-bol)) + (struct (org-list-struct)) + (prevs (org-list-prevs-alist struct)) + (next-item (org-list-get-next-item (point-at-bol) struct prevs))) + (unless (or next-item org-list-use-circular-motion) + (user-error "Cannot move this item further down")) + (if (not next-item) + (setq struct (org-list-send-item item 'begin struct)) + (setq struct (org-list-swap-items item next-item struct)) + (goto-char + (org-list-get-next-item item struct (org-list-prevs-alist struct)))) + (org-list-write-struct struct (org-list-parents-alist struct)) + (org-move-to-column col))) + +(defun org-move-item-up () + "Move the item at point up, i.e. swap with previous item. +Sub-items (items with larger indentation) are considered part of +the item, so this really moves item trees." + (interactive) + (unless (org-at-item-p) (error "Not at an item")) + (let* ((col (current-column)) + (item (point-at-bol)) + (struct (org-list-struct)) + (prevs (org-list-prevs-alist struct)) + (prev-item (org-list-get-prev-item (point-at-bol) struct prevs))) + (unless (or prev-item org-list-use-circular-motion) + (user-error "Cannot move this item further up")) + (if (not prev-item) + (setq struct (org-list-send-item item 'end struct)) + (setq struct (org-list-swap-items prev-item item struct))) + (org-list-write-struct struct (org-list-parents-alist struct)) + (org-move-to-column col))) + +(defun org-insert-item (&optional checkbox) + "Insert a new item at the current level. +If cursor is before first character after bullet of the item, the +new item will be created before the current one. + +If CHECKBOX is non-nil, add a checkbox next to the bullet. + +Return t when things worked, nil when we are not in an item, or +item is invisible." + (interactive "P") + (let ((itemp (org-in-item-p)) + (pos (point))) + ;; If cursor isn't is a list or if list is invisible, return nil. + (unless (or (not itemp) + (save-excursion + (goto-char itemp) + (org-invisible-p))) + (if (save-excursion + (goto-char itemp) + (org-at-item-timer-p)) + ;; Timer list: delegate to `org-timer-item'. + (progn (org-timer-item) t) + (let* ((struct (save-excursion (goto-char itemp) + (org-list-struct))) + (prevs (org-list-prevs-alist struct)) + ;; If we're in a description list, ask for the new term. + (desc (when (eq (org-list-get-list-type itemp struct prevs) + 'descriptive) + " :: "))) + (setq struct (org-list-insert-item pos struct prevs checkbox desc)) + (org-list-write-struct struct (org-list-parents-alist struct)) + (when checkbox (org-update-checkbox-count-maybe)) + (looking-at org-list-full-item-re) + (goto-char (if (and (match-beginning 4) + (save-match-data + (string-match "[.)]" (match-string 1)))) + (match-beginning 4) + (match-end 0))) + (when desc (backward-char 1)) + t))))) + +(defun org-list-repair () + "Fix indentation, bullets and checkboxes in the list at point." + (interactive) + (unless (org-at-item-p) (error "This is not a list")) + (let* ((struct (org-list-struct)) + (parents (org-list-parents-alist struct))) + (org-list-write-struct struct parents))) + +(defun org-cycle-list-bullet (&optional which) + "Cycle through the different itemize/enumerate bullets. +This cycle the entire list level through the sequence: + + `-' -> `+' -> `*' -> `1.' -> `1)' + +If WHICH is a valid string, use that as the new bullet. If WHICH +is an integer, 0 means `-', 1 means `+' etc. If WHICH is +`previous', cycle backwards." + (interactive "P") + (unless (org-at-item-p) (error "Not at an item")) + (save-excursion + (beginning-of-line) + (let* ((struct (org-list-struct)) + (parents (org-list-parents-alist struct)) + (prevs (org-list-prevs-alist struct)) + (list-beg (org-list-get-first-item (point) struct prevs)) + (bullet (org-list-get-bullet list-beg struct)) + (alpha-p (org-list-use-alpha-bul-p list-beg struct prevs)) + (case-fold-search nil) + (current (cond + ((string-match "[a-z]\\." bullet) "a.") + ((string-match "[a-z])" bullet) "a)") + ((string-match "[A-Z]\\." bullet) "A.") + ((string-match "[A-Z])" bullet) "A)") + ((string-match "\\." bullet) "1.") + ((string-match ")" bullet) "1)") + (t (org-trim bullet)))) + ;; Compute list of possible bullets, depending on context. + (bullet-list + (append '("-" "+" ) + ;; *-bullets are not allowed at column 0. + (unless (looking-at "\\S-") '("*")) + ;; Description items cannot be numbered. + (unless (or (eq org-plain-list-ordered-item-terminator ?\)) + (org-at-item-description-p)) + '("1.")) + (unless (or (eq org-plain-list-ordered-item-terminator ?.) + (org-at-item-description-p)) + '("1)")) + (unless (or (not alpha-p) + (eq org-plain-list-ordered-item-terminator ?\)) + (org-at-item-description-p)) + '("a." "A.")) + (unless (or (not alpha-p) + (eq org-plain-list-ordered-item-terminator ?.) + (org-at-item-description-p)) + '("a)" "A)")))) + (len (length bullet-list)) + (item-index (- len (length (member current bullet-list)))) + (get-value (lambda (index) (nth (mod index len) bullet-list))) + (new (cond + ((member which bullet-list) which) + ((numberp which) (funcall get-value which)) + ((eq 'previous which) (funcall get-value (1- item-index))) + (t (funcall get-value (1+ item-index)))))) + ;; Use a short variation of `org-list-write-struct' as there's + ;; no need to go through all the steps. + (let ((old-struct (copy-tree struct))) + (org-list-set-bullet list-beg struct (org-list-bullet-string new)) + (org-list-struct-fix-bul struct prevs) + (org-list-struct-fix-ind struct parents) + (org-list-struct-apply-struct struct old-struct))))) + +;;;###autoload +(define-minor-mode org-list-checkbox-radio-mode + "When turned on, use list checkboxes as radio buttons." + :lighter " CheckBoxRadio" + (unless (eq major-mode 'org-mode) + (user-error "Cannot turn this mode outside org-mode buffers"))) + +(defun org-toggle-radio-button (&optional arg) + "Toggle off all checkboxes and toggle on the one at point." + (interactive "P") + (if (not (org-at-item-p)) + (user-error "Cannot toggle checkbox outside of a list") + (let* ((cpos (org-in-item-p)) + (struct (org-list-struct)) + (orderedp (org-entry-get nil "ORDERED")) + (parents (org-list-parents-alist struct)) + (old-struct (copy-tree struct)) + (cbox (org-list-get-checkbox cpos struct)) + (prevs (org-list-prevs-alist struct)) + (start (org-list-get-list-begin (point-at-bol) struct prevs)) + (new (unless (and cbox (equal arg '(4)) (equal start cpos)) + "[ ]"))) + (dolist (pos (org-list-get-all-items + start struct (org-list-prevs-alist struct))) + (org-list-set-checkbox pos struct new)) + (when new + (org-list-set-checkbox + cpos struct + (cond ((equal arg '(4)) (unless cbox "[ ]")) + ((equal arg '(16)) (unless cbox "[-]")) + (t (if (equal cbox "[X]") "[ ]" "[X]"))))) + (org-list-struct-fix-box struct parents prevs orderedp) + (org-list-struct-apply-struct struct old-struct) + (org-update-checkbox-count-maybe)))) + +(defun org-at-radio-list-p () + "Is point at a list item with radio buttons?" + (when (org-match-line (org-item-re)) ;short-circuit + (let* ((e (save-excursion (beginning-of-line) (org-element-at-point)))) + ;; Check we're really on a line with a bullet. + (when (memq (org-element-type e) '(item plain-list)) + ;; Look for ATTR_ORG attribute in the current plain list. + (let ((plain-list (org-element-lineage e '(plain-list) t))) + (org-with-point-at (org-element-property :post-affiliated plain-list) + (let ((case-fold-search t) + (regexp "^[ \t]*#\\+attr_org:.* :radio \\(\\S-+\\)") + (begin (org-element-property :begin plain-list))) + (and (re-search-backward regexp begin t) + (not (string-equal "nil" (match-string 1))))))))))) + +(defun org-toggle-checkbox (&optional toggle-presence) + "Toggle the checkbox in the current line. + +With prefix argument TOGGLE-PRESENCE, add or remove checkboxes. +With a double prefix argument, set the checkbox to \"[-]\". + +When there is an active region, toggle status or presence of the +first checkbox there, and make every item inside have the same +status or presence, respectively. + +If point is on a headline, apply this to all checkbox items in +the text below the heading, taking as reference the first item in +subtree, ignoring planning line and any drawer following it." + (interactive "P") + (if (org-at-radio-list-p) + (org-toggle-radio-button toggle-presence) + (save-excursion + (let* (singlep + block-item + lim-up + lim-down + (orderedp (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-list-search-forward (org-item-beginning-re) limit t) + (setq lim-up (point-at-bol)) + (error "No item in region")) + (setq lim-down (copy-marker limit)))) + ((org-at-heading-p) + ;; On a heading, start at first item after drawers and + ;; time-stamps (scheduled, etc.). + (let ((limit (save-excursion (outline-next-heading) (point)))) + (org-end-of-meta-data t) + (if (org-list-search-forward (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 (copy-marker (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 "[X]" cbox) "[ ]") + (t "[X]")))))) + ;; When an item is found within bounds, grab the full list at + ;; point structure, then: (1) set check-box of all its items + ;; within bounds to REF-CHECKBOX, (2) fix check-boxes of the + ;; whole list, (3) move point after the list. + (goto-char lim-up) + (while (and (< (point) lim-down) + (org-list-search-forward (org-item-beginning-re) + lim-down 'move)) + (let* ((struct (org-list-struct)) + (struct-copy (copy-tree struct)) + (parents (org-list-parents-alist struct)) + (prevs (org-list-prevs-alist struct)) + (bottom (copy-marker (org-list-get-bottom-point struct))) + (items-to-toggle (cl-remove-if + (lambda (e) (or (< e lim-up) (> e lim-down))) + (mapcar #'car struct)))) + (dolist (e items-to-toggle) + (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)))) + (setq block-item (org-list-struct-fix-box + struct parents prevs 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) + (move-marker bottom nil) + (org-list-struct-apply-struct struct struct-copy))) + (move-marker lim-down nil)))) + (org-update-checkbox-count-maybe)) + +(defun org-reset-checkbox-state-subtree () + "Reset all checkboxes in an entry subtree." + (interactive "*") + (if (org-before-first-heading-p) + (error "Not inside a tree") + (save-restriction + (save-excursion + (org-narrow-to-subtree) + (org-show-subtree) + (goto-char (point-min)) + (let ((end (point-max))) + (while (< (point) end) + (when (org-at-item-checkbox-p) + (replace-match "[ ]" t t nil 1)) + (beginning-of-line 2))) + (org-update-checkbox-count-maybe 'all))))) + +(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." + (interactive "P") + (org-with-wide-buffer + (let* ((cookie-re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)") + (box-re "^[ \t]*\\([-+*]\\|\\([0-9]+\\|[A-Za-z]\\)[.)]\\)[ \t]+\ +\\(?:\\[@\\(?:start:\\)?\\([0-9]+\\|[A-Za-z]\\)\\][ \t]*\\)?\\(\\[[- X]\\]\\)") + (cookie-data (or (org-entry-get nil "COOKIE_DATA") "")) + (recursivep + (or (not org-checkbox-hierarchical-statistics) + (string-match-p "\\<recursive\\>" cookie-data))) + (within-inlinetask (and (not all) + (featurep 'org-inlinetask) + (org-inlinetask-in-task-p))) + (end (cond (all (point-max)) + (within-inlinetask + (save-excursion (outline-next-heading) (point))) + (t (save-excursion + (org-with-limited-levels (outline-next-heading)) + (point))))) + (count-boxes + (lambda (item structs recursivep) + ;; Return number of checked boxes and boxes of all types + ;; in all structures in STRUCTS. If RECURSIVEP is + ;; non-nil, also count boxes in sub-lists. If ITEM is + ;; nil, count across the whole structure, else count only + ;; across subtree whose ancestor is ITEM. + (let ((c-on 0) (c-all 0)) + (dolist (s structs (list c-on c-all)) + (let* ((pre (org-list-prevs-alist s)) + (par (org-list-parents-alist s)) + (items + (cond + ((and recursivep item) (org-list-get-subtree item s)) + (recursivep (mapcar #'car s)) + (item (org-list-get-children item s par)) + (t (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)))) + (cl-incf c-all (length cookies)) + (cl-incf c-on (cl-count "[X]" cookies :test #'equal))))))) + cookies-list cache) + ;; Move to start. + (cond (all (goto-char (point-min))) + (within-inlinetask (org-back-to-heading t)) + (t (org-with-limited-levels (outline-previous-heading)))) + ;; Build an alist for each cookie found. The key is the 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 end t) + (let ((context (save-excursion (backward-char) + (save-match-data (org-element-context))))) + (when (and (eq (org-element-type context) 'statistics-cookie) + (not (string-match-p "\\<todo\\>" cookie-data))) + (push + (append + (list (match-beginning 1) (match-end 1) (match-end 2)) + (let* ((container + (org-element-lineage + context + '(drawer center-block dynamic-block inlinetask item + quote-block special-block verse-block))) + (beg (if container + (org-element-property :contents-begin container) + (save-excursion + (org-with-limited-levels + (outline-previous-heading)) + (point))))) + (or (cdr (assq beg cache)) + (save-excursion + (goto-char beg) + (let ((end + (if container + (org-element-property :contents-end container) + (save-excursion + (org-with-limited-levels (outline-next-heading)) + (point)))) + structs) + (while (re-search-forward box-re end t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'item) + (push (org-element-property :structure element) + structs) + ;; Skip whole list since we have its + ;; structure anyway. + (while (setq element (org-element-lineage + element '(plain-list))) + (goto-char + (min (org-element-property :end element) + end)))))) + ;; Cache count for cookies applying to the same + ;; area. Then return it. + (let ((count + (funcall count-boxes + (and (eq (org-element-type container) + 'item) + (org-element-property + :begin container)) + structs + recursivep))) + (push (cons beg count) cache) + count)))))) + cookies-list)))) + ;; Apply alist to buffer. + (dolist (cookie cookies-list) + (let* ((beg (car cookie)) + (end (nth 1 cookie)) + (percent (nth 2 cookie)) + (checked (nth 3 cookie)) + (total (nth 4 cookie))) + (goto-char beg) + (insert + (if percent (format "[%d%%]" (floor (* 100.0 checked) + (max 1 total))) + (format "[%d/%d]" checked total))) + (delete-region (point) (+ (point) (- end beg))) + (when org-auto-align-tags (org-fix-tags-on-the-fly))))))) + +(defun org-get-checkbox-statistics-face () + "Select the face for checkbox statistics. +The face will be `org-done' when all relevant boxes are checked. +Otherwise it will be `org-todo'." + (if (match-end 1) + (if (equal (match-string 1) "100%") + 'org-checkbox-statistics-done + 'org-checkbox-statistics-todo) + (if (and (> (match-end 2) (match-beginning 2)) + (equal (match-string 2) (match-string 3))) + 'org-checkbox-statistics-done + 'org-checkbox-statistics-todo))) + +(defun org-update-checkbox-count-maybe (&optional all) + "Update checkbox statistics unless turned off by user. +With an optional argument ALL, update them in the whole buffer." + (when (cdr (assq 'checkbox org-list-automatic-rules)) + (org-update-checkbox-count all)) + (run-hooks 'org-checkbox-statistics-hook)) + +(defvar org-last-indent-begin-marker (make-marker)) +(defvar org-last-indent-end-marker (make-marker)) +(defun org-list-indent-item-generic (arg no-subtree struct) + "Indent a local list item including its children. +When number ARG is a negative, item will be outdented, otherwise +it will be indented. + +If a region is active, all items inside will be moved. + +If NO-SUBTREE is non-nil, only indent the item itself, not its +children. + +STRUCT is the list structure. + +Return t if successful." + (save-excursion + (let* ((regionp (org-region-active-p)) + (rbeg (and regionp (region-beginning))) + (rend (and regionp (region-end))) + (top (org-list-get-top-point struct)) + (parents (org-list-parents-alist struct)) + (prevs (org-list-prevs-alist struct)) + ;; Are we going to move the whole list? + (specialp + (and (not regionp) + (= top (point-at-bol)) + (cdr (assq 'indent org-list-automatic-rules)) + (if no-subtree + (user-error + "At first item: use S-M-<left/right> to move the whole list") + t)))) + ;; Determine begin and end points of zone to indent. If moving + ;; more than one item, save them for subsequent moves. + (unless (and (memq last-command '(org-shiftmetaright org-shiftmetaleft)) + (memq this-command '(org-shiftmetaright org-shiftmetaleft))) + (if regionp + (progn + (set-marker org-last-indent-begin-marker rbeg) + (set-marker org-last-indent-end-marker rend)) + (set-marker org-last-indent-begin-marker (point-at-bol)) + (set-marker org-last-indent-end-marker + (cond + (specialp (org-list-get-bottom-point struct)) + (no-subtree (1+ (point-at-bol))) + (t (org-list-get-item-end (point-at-bol) struct)))))) + (let* ((beg (marker-position org-last-indent-begin-marker)) + (end (marker-position org-last-indent-end-marker))) + (cond + ;; Special case: moving top-item with indent rule. + (specialp + (let* ((level-skip (org-level-increment)) + (offset (if (< arg 0) (- level-skip) level-skip)) + (top-ind (org-list-get-ind beg struct)) + (old-struct (copy-tree struct))) + (if (< (+ top-ind offset) 0) + (error "Cannot outdent beyond margin") + ;; Change bullet if necessary. + (when (and (= (+ top-ind offset) 0) + (string-match "\\*" + (org-list-get-bullet beg struct))) + (org-list-set-bullet beg struct + (org-list-bullet-string "-"))) + ;; Shift every item by OFFSET and fix bullets. Then + ;; apply changes to buffer. + (pcase-dolist (`(,pos . ,_) struct) + (let ((ind (org-list-get-ind pos struct))) + (org-list-set-ind pos struct (+ ind offset)))) + (org-list-struct-fix-bul struct prevs) + (org-list-struct-apply-struct struct old-struct)))) + ;; Forbidden move: + ((and (< arg 0) + ;; If only one item is moved, it mustn't have a child. + (or (and no-subtree + (not regionp) + (org-list-has-child-p beg struct)) + ;; If a subtree or region is moved, the last item + ;; of the subtree mustn't have a child. + (let ((last-item (caar + (reverse + (cl-remove-if + (lambda (e) (>= (car e) end)) + struct))))) + (org-list-has-child-p last-item struct)))) + (error "Cannot outdent an item without its children")) + ;; Normal shifting + (t + (let* ((old-struct (copy-tree struct)) + (new-parents + (if (< arg 0) + (org-list-struct-outdent beg end struct parents) + (org-list-struct-indent beg end struct parents prevs)))) + (org-list-write-struct struct new-parents old-struct)) + (org-update-checkbox-count-maybe)))))) + t) + +(defun org-outdent-item () + "Outdent a local list item, but not its children. +If a region is active, all items inside will be moved." + (interactive) + (let ((regionp (org-region-active-p))) + (cond + ((or (org-at-item-p) + (and regionp + (save-excursion (goto-char (region-beginning)) + (org-at-item-p)))) + (let ((struct (if (not regionp) (org-list-struct) + (save-excursion (goto-char (region-beginning)) + (org-list-struct))))) + (org-list-indent-item-generic -1 t struct))) + (regionp (error "Region not starting at an item")) + (t (error "Not at an item"))))) + +(defun org-indent-item () + "Indent a local list item, but not its children. +If a region is active, all items inside will be moved." + (interactive) + (let ((regionp (org-region-active-p))) + (cond + ((or (org-at-item-p) + (and regionp + (save-excursion (goto-char (region-beginning)) + (org-at-item-p)))) + (let ((struct (if (not regionp) (org-list-struct) + (save-excursion (goto-char (region-beginning)) + (org-list-struct))))) + (org-list-indent-item-generic 1 t struct))) + (regionp (error "Region not starting at an item")) + (t (error "Not at an item"))))) + +(defun org-outdent-item-tree () + "Outdent a local list item including its children. +If a region is active, all items inside will be moved." + (interactive) + (let ((regionp (org-region-active-p))) + (cond + ((or (org-at-item-p) + (and regionp + (save-excursion (goto-char (region-beginning)) + (org-at-item-p)))) + (let ((struct (if (not regionp) (org-list-struct) + (save-excursion (goto-char (region-beginning)) + (org-list-struct))))) + (org-list-indent-item-generic -1 nil struct))) + (regionp (error "Region not starting at an item")) + (t (error "Not at an item"))))) + +(defun org-indent-item-tree () + "Indent a local list item including its children. +If a region is active, all items inside will be moved." + (interactive) + (let ((regionp (org-region-active-p))) + (cond + ((or (org-at-item-p) + (and regionp + (save-excursion (goto-char (region-beginning)) + (org-at-item-p)))) + (let ((struct (if (not regionp) (org-list-struct) + (save-excursion (goto-char (region-beginning)) + (org-list-struct))))) + (org-list-indent-item-generic 1 nil struct))) + (regionp (error "Region not starting at an item")) + (t (error "Not at an item"))))) + +(defvar org-tab-ind-state) +(defun org-cycle-item-indentation () + "Cycle levels of indentation of an empty item. + +The first run indents the item, if applicable. Subsequent runs +outdent it at meaningful levels in the list. When done, item is +put back at its original position with its original bullet. + +Return t at each successful move." + (when (org-at-item-p) + (let* ((struct (org-list-struct)) + (item (line-beginning-position)) + (ind (org-list-get-ind item struct))) + ;; Accept empty items or if cycle has already started. + (when (or (eq last-command 'org-cycle-item-indentation) + (and (org-match-line org-list-full-item-re) + (>= (match-end 0) + (save-excursion + (goto-char (org-list-get-item-end item struct)) + (skip-chars-backward " \t\n") + (point))))) + (setq this-command 'org-cycle-item-indentation) + (let ((prevs (org-list-prevs-alist struct)) + (parents (org-list-parents-alist struct))) + (if (eq last-command 'org-cycle-item-indentation) + ;; When in the middle of the cycle, try to outdent. If + ;; it fails, move point back to its initial position and + ;; reset cycle. + (pcase-let ((`(,old-ind . ,old-bul) org-tab-ind-state) + (allow-outdent + (lambda (struct prevs parents) + ;; Non-nil if current item can be + ;; outdented. + (and (not (org-list-get-next-item item nil prevs)) + (not (org-list-has-child-p item struct)) + (org-list-get-parent item struct parents))))) + (cond + ((and (> ind old-ind) + (org-list-get-prev-item item nil prevs)) + (org-list-indent-item-generic 1 t struct)) + ((and (< ind old-ind) + (funcall allow-outdent struct prevs parents)) + (org-list-indent-item-generic -1 t struct)) + (t + (delete-region (line-beginning-position) (line-end-position)) + (indent-to-column old-ind) + (insert old-bul " ") + (let* ((struct (org-list-struct)) + (parents (org-list-parents-alist struct))) + (if (and (> ind old-ind) + ;; We were previously indenting item. It + ;; is no longer possible. Try to outdent + ;; from initial position. + (funcall allow-outdent + struct + (org-list-prevs-alist struct) + parents)) + (org-list-indent-item-generic -1 t struct) + (org-list-write-struct struct parents) + ;; Start cycle over. + (setq this-command 'identity) + t))))) + ;; If a cycle is starting, remember initial indentation + ;; and bullet, then try to indent. If it fails, try to + ;; outdent. + (setq org-tab-ind-state + (cons ind (org-trim (org-current-line-string)))) + (cond + ((org-list-get-prev-item item nil prevs) + (org-list-indent-item-generic 1 t struct)) + ((and (not (org-list-get-next-item item nil prevs)) + (org-list-get-parent item struct parents)) + (org-list-indent-item-generic -1 t struct)) + (t + ;; This command failed. So will the following one. + ;; There's no point in starting the cycle. + (setq this-command 'identity) + (user-error "Cannot move item"))))))))) + +(defun org-sort-list + (&optional with-case sorting-type getkey-func compare-func interactive?) + "Sort list items. +The cursor may be at any item of the list that should be sorted. +Sublists are not sorted. Checkboxes, if any, are ignored. + +Sorting can be alphabetically, numerically, by date/time as given +by a time stamp, by a property or by priority. + +Comparing entries ignores case by default. However, with an +optional argument WITH-CASE, the sorting considers case as well, +if the current locale allows for it. + +The command prompts for the sorting type unless it has been given +to the function through the SORTING-TYPE argument, which needs to +be a character, among ?n ?N ?a ?A ?t ?T ?f ?F ?x or ?X. Here is +the detailed meaning of each character: + +n Numerically, by converting the beginning of the item to a number. +a Alphabetically. Only the first line of item is checked. +t By date/time, either the first active time stamp in the entry, if + any, or by the first inactive one. In a timer list, sort the timers. +x By \"checked\" status of a check list. + +Capital letters will reverse the sort order. + +If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies +a function to be called with point at the beginning of the +record. It must return a value that is compatible with COMPARE-FUNC, +the function used to compare entries. + +Sorting is done against the visible part of the headlines, it +ignores hidden links. + +A non-nil value for INTERACTIVE? is used to signal that this +function is being called interactively." + (interactive (list current-prefix-arg nil nil nil t)) + (let* ((case-func (if with-case 'identity 'downcase)) + (struct (org-list-struct)) + (prevs (org-list-prevs-alist struct)) + (start (org-list-get-list-begin (point-at-bol) struct prevs)) + (end (org-list-get-list-end (point-at-bol) struct prevs)) + (sorting-type + (or sorting-type + (progn + (message + "Sort plain list: [a]lpha [n]umeric [t]ime [f]unc [x]checked A/N/T/F/X means reversed:") + (read-char-exclusive)))) + (dcst (downcase sorting-type)) + (getkey-func + (and (= dcst ?f) + (or getkey-func + (and interactive? + (org-read-function "Function for extracting keys: ")) + (error "Missing key extractor")))) + (sort-func + (cond + ((= dcst ?a) #'org-string-collate-lessp) + ((= dcst ?f) + (or compare-func + (and interactive? + (org-read-function + (concat "Function for comparing keys " + "(empty for default `sort-subr' predicate): ") + 'allow-empty)))) + ((= dcst ?t) #'<) + ((= dcst ?x) #'string<)))) + (message "Sorting items...") + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (let* ((case-fold-search nil) + (now (current-time)) + (next-record (lambda () + (skip-chars-forward " \r\t\n") + (or (eobp) (beginning-of-line)))) + (end-record (lambda () + (goto-char (org-list-get-item-end-before-blank + (point) struct)))) + (value-to-sort + (lambda () + (when (looking-at "[ \t]*[-+*0-9.)]+\\([ \t]+\\[[- X]\\]\\)?[ \t]+") + (cond + ((= dcst ?n) + (string-to-number + (org-sort-remove-invisible + (buffer-substring (match-end 0) (point-at-eol))))) + ((= dcst ?a) + (funcall case-func + (org-sort-remove-invisible + (buffer-substring + (match-end 0) (point-at-eol))))) + ((= dcst ?t) + (cond + ;; If it is a timer list, convert timer to seconds + ((org-at-item-timer-p) + (org-timer-hms-to-secs (match-string 1))) + ((or (save-excursion + (re-search-forward org-ts-regexp (point-at-eol) t)) + (save-excursion (re-search-forward org-ts-regexp-both + (point-at-eol) t))) + (org-time-string-to-seconds (match-string 0))) + (t (float-time now)))) + ((= dcst ?x) (or (and (stringp (match-string 1)) + (match-string 1)) + "")) + ((= dcst ?f) + (if getkey-func + (let ((value (funcall getkey-func))) + (if (stringp value) + (funcall case-func value) + value)) + (error "Invalid key function `%s'" getkey-func))) + (t (error "Invalid sorting type `%c'" sorting-type))))))) + (sort-subr (/= dcst sorting-type) + next-record + end-record + value-to-sort + nil + sort-func) + ;; Read and fix list again, as `sort-subr' probably destroyed + ;; its structure. + (org-list-repair) + (run-hooks 'org-after-sorting-entries-or-items-hook) + (message "Sorting items...done"))))) + +(defun org-toggle-item (arg) + "Convert headings or normal lines to items, items to normal lines. +If there is no active region, only the current line is considered. + +If the first non blank line in the region is a headline, convert +all headlines to items, shifting text accordingly. + +If it is an item, convert all items to normal lines. + +If it is normal text, change region into a list of items. +With a prefix argument ARG, change the region in a single item." + (interactive "P") + (let ((shift-text + (lambda (ind end) + ;; Shift text in current section to IND, from point to END. + ;; The function leaves point to END line. + (let ((min-i 1000) (end (copy-marker end))) + ;; First determine the minimum indentation (MIN-I) of + ;; the text. + (save-excursion + (catch 'exit + (while (< (point) end) + (let ((i (current-indentation))) + (cond + ;; Skip blank lines and inline tasks. + ((looking-at "^[ \t]*$")) + ((looking-at org-outline-regexp-bol)) + ;; We can't find less than 0 indentation. + ((zerop i) (throw 'exit (setq min-i 0))) + ((< i min-i) (setq min-i i)))) + (forward-line)))) + ;; Then indent each line so that a line indented to + ;; MIN-I becomes indented to IND. Ignore blank lines + ;; and inline tasks in the process. + (let ((delta (- ind min-i))) + (while (< (point) end) + (unless (or (looking-at "^[ \t]*$") + (looking-at org-outline-regexp-bol)) + (indent-line-to (+ (current-indentation) delta))) + (forward-line)))))) + (skip-blanks + (lambda (pos) + ;; Return beginning of first non-blank line, starting from + ;; line at POS. + (save-excursion + (goto-char pos) + (skip-chars-forward " \r\t\n") + (point-at-bol)))) + beg end) + ;; Determine boundaries of changes. + (if (org-region-active-p) + (setq beg (funcall skip-blanks (region-beginning)) + end (copy-marker (region-end))) + (setq beg (point-at-bol) + end (copy-marker (point-at-eol)))) + ;; Depending on the starting line, choose an action on the text + ;; between BEG and END. + (org-with-limited-levels + (save-excursion + (goto-char beg) + (cond + ;; Case 1. Start at an item: de-itemize. Note that it only + ;; happens when a region is active: `org-ctrl-c-minus' + ;; would call `org-cycle-list-bullet' otherwise. + ((org-at-item-p) + (while (< (point) end) + (when (org-at-item-p) + (skip-chars-forward " \t") + (delete-region (point) (match-end 0))) + (forward-line))) + ;; Case 2. Start at an heading: convert to items. + ((org-at-heading-p) + ;; Remove metadata + (let (org-loop-over-headlines-in-active-region) + (org-list--delete-metadata)) + (let* ((bul (org-list-bullet-string "-")) + (bul-len (length bul)) + ;; Indentation of the first heading. It should be + ;; relative to the indentation of its parent, if any. + (start-ind (save-excursion + (cond + ((not org-adapt-indentation) 0) + ((not (outline-previous-heading)) 0) + (t (length (match-string 0)))))) + ;; Level of first heading. Further headings will be + ;; compared to it to determine hierarchy in the list. + (ref-level (org-reduced-level (org-outline-level)))) + (while (< (point) end) + (let* ((level (org-reduced-level (org-outline-level))) + (delta (max 0 (- level ref-level))) + (todo-state (org-get-todo-state))) + ;; If current headline is less indented than the first + ;; one, set it as reference, in order to preserve + ;; subtrees. + (when (< level ref-level) (setq ref-level level)) + ;; Remove metadata + (let (org-loop-over-headlines-in-active-region) + (org-list--delete-metadata)) + ;; Remove stars and TODO keyword. + (let ((case-fold-search nil)) (looking-at org-todo-line-regexp)) + (delete-region (point) (or (match-beginning 3) + (line-end-position))) + (insert bul) + (indent-line-to (+ start-ind (* delta bul-len))) + ;; Turn TODO keyword into a check box. + (when todo-state + (let* ((struct (org-list-struct)) + (old (copy-tree struct))) + (org-list-set-checkbox + (line-beginning-position) + struct + (if (member todo-state org-done-keywords) + "[X]" + "[ ]")) + (org-list-write-struct struct + (org-list-parents-alist struct) + old))) + ;; Ensure all text down to END (or SECTION-END) belongs + ;; to the newly created item. + (let ((section-end (save-excursion + (or (outline-next-heading) (point))))) + (forward-line) + (funcall shift-text + (+ start-ind (* (1+ delta) bul-len)) + (min end section-end))))))) + ;; Case 3. Normal line with ARG: make the first line of region + ;; an item, and shift indentation of others lines to + ;; set them as item's body. + (arg (let* ((bul (org-list-bullet-string "-")) + (bul-len (length bul)) + (ref-ind (current-indentation))) + (skip-chars-forward " \t") + (insert bul) + (forward-line) + (while (< (point) end) + ;; Ensure that lines less indented than first one + ;; still get included in item body. + (funcall shift-text + (+ ref-ind bul-len) + (min end (save-excursion (or (outline-next-heading) + (point))))) + (forward-line)))) + ;; Case 4. Normal line without ARG: turn each non-item line + ;; into an item. + (t + (while (< (point) end) + (unless (or (org-at-heading-p) (org-at-item-p)) + (when (looking-at "\\([ \t]*\\)\\(\\S-\\)") + (replace-match + (concat "\\1" (org-list-bullet-string "-") "\\2")))) + (forward-line)))))))) + + +;;; Send and receive lists + +(defun org-list-to-lisp (&optional delete) + "Parse the list at point and maybe DELETE it. + +Return a list whose car is a symbol of list type, among +`ordered', `unordered' and `descriptive'. Then, each item is +a list of strings and other sub-lists. + +For example, the following list: + + 1. first item + + sub-item one + + [X] sub-item two + more text in first item + 2. [@3] last item + +is parsed as + + (ordered + (\"first item\" + (unordered + (\"sub-item one\") + (\"[X] sub-item two\")) + \"more text in first item\") + (\"[@3] last item\")) + +Point is left at list's end." + (letrec ((struct (org-list-struct)) + (prevs (org-list-prevs-alist struct)) + (parents (org-list-parents-alist struct)) + (top (org-list-get-top-point struct)) + (bottom (org-list-get-bottom-point struct)) + (trim + (lambda (text) + ;; Remove indentation and final newline from TEXT. + (org-remove-indentation + (if (string-match-p "\n\\'" text) + (substring text 0 -1) + text)))) + (parse-sublist + (lambda (e) + ;; Return a list whose car is list type and cdr a list + ;; of items' body. + (cons (org-list-get-list-type (car e) struct prevs) + (mapcar parse-item e)))) + (parse-item + (lambda (e) + ;; Return a list containing counter of item, if any, + ;; text and any sublist inside it. + (let* ((end (org-list-get-item-end e struct)) + (children (org-list-get-children e struct parents)) + (body + (save-excursion + (goto-char e) + (looking-at "[ \t]*\\S-+[ \t]*") + (list + (funcall + trim + (concat + (make-string (string-width (match-string 0)) ?\s) + (buffer-substring-no-properties + (match-end 0) (or (car children) end)))))))) + (while children + (let* ((child (car children)) + (sub (org-list-get-all-items child struct prevs)) + (last-in-sub (car (last sub)))) + (push (funcall parse-sublist sub) body) + ;; Remove whole sub-list from children. + (setq children (cdr (memq last-in-sub children))) + ;; There is a chunk of text belonging to the item + ;; if last child doesn't end where next child + ;; starts or where item ends. + (let ((sub-end (org-list-get-item-end last-in-sub struct)) + (next (or (car children) end))) + (when (/= sub-end next) + (push (funcall + trim + (buffer-substring-no-properties sub-end next)) + body))))) + (nreverse body))))) + ;; Store output, take care of cursor position and deletion of + ;; list, then return output. + (prog1 (funcall parse-sublist (org-list-get-all-items top struct prevs)) + (goto-char top) + (when delete + (delete-region top bottom) + (when (and (not (looking-at "[ \t]*$")) (looking-at org-list-end-re)) + (replace-match "")))))) + +(defun org-list-make-subtree () + "Convert the plain list at point into a subtree." + (interactive) + (let ((item (org-in-item-p))) + (unless item (error "Not in a list")) + (goto-char item) + (let ((level (pcase (org-current-level) + (`nil 1) + (l (1+ (org-reduced-level l))))) + (list (save-excursion (org-list-to-lisp t)))) + (insert (org-list-to-subtree list level) "\n")))) + +(defun org-list-to-generic (list params) + "Convert a LIST parsed through `org-list-to-lisp' to a custom format. + +LIST is a list as returned by `org-list-to-lisp', which see. +PARAMS is a property list of parameters used to tweak the output +format. + +Valid parameters are: + +:backend, :raw + + Export back-end used as a basis to transcode elements of the + list, when no specific parameter applies to it. It is also + used to translate its contents. You can prevent this by + setting :raw property to a non-nil value. + +:splice + + When non-nil, only export the contents of the top most plain + list, effectively ignoring its opening and closing lines. + +:ustart, :uend + + Strings to start and end an unordered list. They can also be + set to a function returning a string or nil, which will be + called with the depth of the list, counting from 1. + +:ostart, :oend + + Strings to start and end an ordered list. They can also be set + to a function returning a string or nil, which will be called + with the depth of the list, counting from 1. + +:dstart, :dend + + Strings to start and end a descriptive list. They can also be + set to a function returning a string or nil, which will be + called with the depth of the list, counting from 1. + +:dtstart, :dtend, :ddstart, :ddend + + Strings to start and end a descriptive term. + +:istart, :iend + + Strings to start or end a list item, and to start a list item + with a counter. They can also be set to a function returning + a string or nil, which will be called with two arguments: the + type of list and the depth of the item, counting from 1. + +:icount + + Strings to start a list item with a counter. It can also be + set to a function returning a string or nil, which will be + called with three arguments: the type of list, the depth of the + item, counting from 1, and the counter. Its value, when + non-nil, has precedence over `:istart'. + +:isep + + String used to separate items. It can also be set to + a function returning a string or nil, which will be called with + two arguments: the type of list and the depth of the item, + counting from 1. It always start on a new line. + +:ifmt + + Function to be applied to the contents of every item. It is + called with two arguments: the type of list and the contents. + +:cbon, :cboff, :cbtrans + + String to insert, respectively, an un-checked check-box, + a checked check-box and a check-box in transitional state." + (require 'ox) + (let* ((backend (plist-get params :backend)) + (custom-backend + (org-export-create-backend + :parent (or backend 'org) + :transcoders + `((plain-list . ,(org-list--to-generic-plain-list params)) + (item . ,(org-list--to-generic-item params)) + (macro . (lambda (m c i) (org-element-macro-interpreter m nil)))))) + data info) + ;; Write LIST back into Org syntax and parse it. + (with-temp-buffer + (let ((org-inhibit-startup t)) (org-mode)) + (letrec ((insert-list + (lambda (l) + (dolist (i (cdr l)) + (funcall insert-item i (car l))))) + (insert-item + (lambda (i type) + (let ((start (point))) + (insert (if (eq type 'ordered) "1. " "- ")) + (dolist (e i) + (if (consp e) (funcall insert-list e) + (insert e) + (insert "\n"))) + (beginning-of-line) + (save-excursion + (let ((ind (if (eq type 'ordered) 3 2))) + (while (> (point) start) + (unless (looking-at-p "[ \t]*$") + (indent-to ind)) + (forward-line -1)))))))) + (funcall insert-list list)) + (setf data + (org-element-map (org-element-parse-buffer) 'plain-list + #'identity nil t)) + (setf info (org-export-get-environment backend nil params))) + (when (and backend (symbolp backend) (not (org-export-get-backend backend))) + (user-error "Unknown :backend value")) + (unless backend (require 'ox-org)) + ;; When ':raw' property has a non-nil value, turn all objects back + ;; into Org syntax. + (when (and backend (plist-get params :raw)) + (org-element-map data org-element-all-objects + (lambda (object) + (org-element-set-element + object (org-element-interpret-data object))))) + ;; We use a low-level mechanism to export DATA so as to skip all + ;; usual pre-processing and post-processing, i.e., hooks, filters, + ;; Babel code evaluation, include keywords and macro expansion, + ;; and filters. + (let ((output (org-export-data-with-backend data custom-backend info))) + ;; Remove final newline. + (if (org-string-nw-p output) (substring-no-properties output 0 -1) "")))) + +(defun org-list--depth (element) + "Return the level of ELEMENT within current plain list. +ELEMENT is either an item or a plain list." + (cl-count-if (lambda (ancestor) (eq (org-element-type ancestor) 'plain-list)) + (org-element-lineage element nil t))) + +(defun org-list--trailing-newlines (string) + "Return the number of trailing newlines in STRING." + (with-temp-buffer + (insert string) + (skip-chars-backward " \t\n") + (count-lines (line-beginning-position 2) (point-max)))) + +(defun org-list--generic-eval (value &rest args) + "Evaluate VALUE according to its type. +VALUE is either nil, a string or a function. In the latter case, +it is called with arguments ARGS." + (cond ((null value) nil) + ((stringp value) value) + ((functionp value) (apply value args)) + (t (error "Wrong value: %s" value)))) + +(defun org-list--to-generic-plain-list (params) + "Return a transcoder for `plain-list' elements. +PARAMS is a plist used to tweak the behavior of the transcoder." + (let ((ustart (plist-get params :ustart)) + (uend (plist-get params :uend)) + (ostart (plist-get params :ostart)) + (oend (plist-get params :oend)) + (dstart (plist-get params :dstart)) + (dend (plist-get params :dend)) + (splice (plist-get params :splice)) + (backend (plist-get params :backend))) + (lambda (plain-list contents info) + (let* ((type (org-element-property :type plain-list)) + (depth (org-list--depth plain-list)) + (start (and (not splice) + (org-list--generic-eval + (pcase type + (`ordered ostart) + (`unordered ustart) + (_ dstart)) + depth))) + (end (and (not splice) + (org-list--generic-eval + (pcase type + (`ordered oend) + (`unordered uend) + (_ dend)) + depth)))) + ;; Make sure trailing newlines in END appear in the output by + ;; setting `:post-blank' property to their number. + (when end + (org-element-put-property + plain-list :post-blank (org-list--trailing-newlines end))) + ;; Build output. + (concat (and start (concat start "\n")) + (if (or start end splice (not backend)) + contents + (org-export-with-backend backend plain-list contents info)) + end))))) + +(defun org-list--to-generic-item (params) + "Return a transcoder for `item' elements. +PARAMS is a plist used to tweak the behavior of the transcoder." + (let ((backend (plist-get params :backend)) + (istart (plist-get params :istart)) + (iend (plist-get params :iend)) + (isep (plist-get params :isep)) + (icount (plist-get params :icount)) + (ifmt (plist-get params :ifmt)) + (cboff (plist-get params :cboff)) + (cbon (plist-get params :cbon)) + (cbtrans (plist-get params :cbtrans)) + (dtstart (plist-get params :dtstart)) + (dtend (plist-get params :dtend)) + (ddstart (plist-get params :ddstart)) + (ddend (plist-get params :ddend))) + (lambda (item contents info) + (let* ((type + (org-element-property :type (org-element-property :parent item))) + (tag (org-element-property :tag item)) + (depth (org-list--depth item)) + (separator (and (org-export-get-next-element item info) + (org-list--generic-eval isep type depth))) + (closing (pcase (org-list--generic-eval iend type depth) + ((or `nil "") "\n") + ((and (guard separator) s) + (if (equal (substring s -1) "\n") s (concat s "\n"))) + (s s)))) + ;; When a closing line or a separator is provided, make sure + ;; its trailing newlines are taken into account when building + ;; output. This is done by setting `:post-blank' property to + ;; the number of such lines in the last line to be added. + (let ((last-string (or separator closing))) + (when last-string + (org-element-put-property + item + :post-blank + (max (1- (org-list--trailing-newlines last-string)) 0)))) + ;; Build output. + (concat + (let ((c (org-element-property :counter item))) + (if (and c icount) (org-list--generic-eval icount type depth c) + (org-list--generic-eval istart type depth))) + (let ((body + (if (or istart iend icount ifmt cbon cboff cbtrans (not backend) + (and (eq type 'descriptive) + (or dtstart dtend ddstart ddend))) + (concat + (pcase (org-element-property :checkbox item) + (`on cbon) + (`off cboff) + (`trans cbtrans)) + (and tag + (concat dtstart + (if backend + (org-export-data-with-backend + tag backend info) + (org-element-interpret-data tag)) + dtend)) + (and tag ddstart) + (let ((contents + (if (= (length contents) 0) "" + (substring contents 0 -1)))) + (if ifmt (org-list--generic-eval ifmt type contents) + contents)) + (and tag ddend)) + (org-export-with-backend backend item contents info)))) + ;; Remove final newline. + (if (equal body "") "" + (substring (org-element-normalize-string body) 0 -1))) + closing + separator))))) + +(defun org-list-to-latex (list &optional params) + "Convert LIST into a LaTeX list. +LIST is a parsed plain list, as returned by `org-list-to-lisp'. +PARAMS is a property list with overruling parameters for +`org-list-to-generic'. Return converted list as a string." + (require 'ox-latex) + (org-list-to-generic list (org-combine-plists '(:backend latex) params))) + +(defun org-list-to-html (list &optional params) + "Convert LIST into a HTML list. +LIST is a parsed plain list, as returned by `org-list-to-lisp'. +PARAMS is a property list with overruling parameters for +`org-list-to-generic'. Return converted list as a string." + (require 'ox-html) + (org-list-to-generic list (org-combine-plists '(:backend html) params))) + +(defun org-list-to-texinfo (list &optional params) + "Convert LIST into a Texinfo list. +LIST is a parsed plain list, as returned by `org-list-to-lisp'. +PARAMS is a property list with overruling parameters for +`org-list-to-generic'. Return converted list as a string." + (require 'ox-texinfo) + (org-list-to-generic list (org-combine-plists '(:backend texinfo) params))) + +(defun org-list-to-org (list &optional params) + "Convert LIST into an Org plain list. +LIST is as returned by `org-list-parse-list'. PARAMS is a property list +with overruling parameters for `org-list-to-generic'." + (let* ((make-item + (lambda (type _depth &optional c) + (concat (if (eq type 'ordered) "1. " "- ") + (and c (format "[@%d] " c))))) + (defaults + (list :istart make-item + :icount make-item + :ifmt (lambda (_type contents) + (replace-regexp-in-string "\n" "\n " contents)) + :dtend " :: " + :cbon "[X] " + :cboff "[ ] " + :cbtrans "[-] "))) + (org-list-to-generic list (org-combine-plists defaults params)))) + +(defun org-list-to-subtree (list &optional start-level params) + "Convert LIST into an Org subtree. +LIST is as returned by `org-list-to-lisp'. Subtree starts at +START-LEVEL or level 1 if nil. PARAMS is a property list with +overruling parameters for `org-list-to-generic'." + (let* ((blank (pcase (cdr (assq 'heading org-blank-before-new-entry)) + (`t t) + (`auto (save-excursion + (org-with-limited-levels (outline-previous-heading)) + (org-previous-line-empty-p))))) + (level (or start-level 1)) + (make-stars + (lambda (_type depth &optional _count) + ;; Return the string for the heading, depending on DEPTH + ;; of current sub-list. + (let ((oddeven-level (+ level (1- depth)))) + (concat (make-string (if org-odd-levels-only + (1- (* 2 oddeven-level)) + oddeven-level) + ?*) + " "))))) + (org-list-to-generic + list + (org-combine-plists + (list :splice t + :istart make-stars + :icount make-stars + :dtstart " " :dtend " " + :isep (if blank "\n\n" "\n") + :cbon "DONE " :cboff "TODO " :cbtrans "TODO ") + params)))) + +(provide 'org-list) + +;; Local variables: +;; generated-autoload-file: "org-loaddefs.el" +;; End: + +;;; org-list.el ends here |