diff options
| -rw-r--r-- | pearl.el | 129 | ||||
| -rw-r--r-- | tests/test-pearl-grouping.el | 144 |
2 files changed, 273 insertions, 0 deletions
@@ -6973,6 +6973,135 @@ server-side sort reorders the merged buffer without losing local edits." (insert (mapconcat (lambda (c) (plist-get c :text)) sorted "")))) t)))))) +(defun pearl--shift-heading-levels (text delta) + "Return TEXT with every Org heading line's star count shifted by DELTA. +A positive DELTA demotes (adds stars), negative promotes (removes, floor 1). +Only heading lines (`^\\*+ ') are touched; body and drawer lines are left +alone. pearl-rendered issue bodies never begin a line with `* ' (markdown +headings render as bold, bullets as `-'), so a captured issue subtree shifts +its issue + comment headings together without disturbing content." + (if (= delta 0) + text + (with-temp-buffer + (insert text) + (goto-char (point-min)) + (while (re-search-forward "^\\(\\*+\\) " nil t) + (let ((n (max 1 (+ (length (match-string 1)) delta)))) + (replace-match (concat (make-string n ?*) " ") t t))) + (buffer-string)))) + +(defun pearl--buffer-issue-group-label (grouping) + "Return the group label for the issue subtree at point under GROUPING. +Reads the relevant `LINEAR-*' drawer field at point and maps it to the same +bucket `pearl--view-group-label' produces from a normalized issue, so a buffer +regroup matches a server-grouped render. Point must be on the issue heading. +GROUPING outside the drawer-backed set yields nil." + (pcase grouping + ("workflowState" + (let ((v (org-entry-get nil "LINEAR-STATE-NAME"))) + (if (and v (not (string-empty-p v))) v "No status"))) + ("project" + (let ((v (org-entry-get nil "LINEAR-PROJECT-NAME"))) + (if (and v (not (string-empty-p v))) v "No project"))) + ("assignee" + (let ((v (org-entry-get nil "LINEAR-ASSIGNEE-NAME"))) + (if (and v (not (string-empty-p v))) v "No assignee"))) + ("priority" + (pearl--get-linear-priority-name + (string-to-number (or (org-entry-get nil "LINEAR-PRIORITY") "0")))) + (_ nil))) + +(defun pearl--subtree-contains-issue-p (beg end) + "Return non-nil when the region BEG..END holds an issue heading (a `LINEAR-ID')." + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (catch 'found + (while (re-search-forward "^\\*+ " nil t) + (let ((id (org-entry-get nil "LINEAR-ID"))) + (when (and id (not (string-empty-p id))) (throw 'found t)))) + nil)))) + +(defun pearl--regroup-issue-subtrees (grouping) + "Re-lay-out the active view's issue subtrees by GROUPING, in place. +GROUPING is an `issueGrouping' value (issues sectioned under level-2 group +headings, at level 3) or nil (a flat level-2 list). Each issue subtree moves +byte-for-byte with only its heading levels shifted, so unsaved edits survive; +the group label is read from the subtree's drawer (see +`pearl--buffer-issue-group-label'). Non-issue level-2 subtrees are kept, after +the issue groups. Works whether the buffer is currently flat or already +grouped. Returns t, or `no-issues' when there are none." + (save-excursion + (let ((markers (pearl--issue-subtree-markers))) + (if (null markers) + 'no-issues + ;; Climb from the first issue to the level-1 view parent. + (goto-char (cdr (car markers))) + (while (> (or (org-current-level) 1) 1) + (org-up-heading-safe)) + (let ((content-beg (save-excursion (forward-line 1) (point))) + (parent-end (save-excursion (org-end-of-subtree t t) (point))) + (issues '()) ; (:label L :text canonical-level-2-text), doc order + (malformed '())) ; non-issue level-2 subtree text, kept last + (goto-char content-beg) + (while (re-search-forward "^\\*\\* " parent-end t) + (beginning-of-line) + (let* ((beg (point)) + (end (save-excursion (org-end-of-subtree t t) (point))) + (id (org-entry-get nil "LINEAR-ID"))) + (cond + ;; A level-2 issue (flat buffer): already canonical level 2. + ((and id (not (string-empty-p id))) + (push (list :label (pearl--buffer-issue-group-label grouping) + :text (buffer-substring-no-properties beg end)) + issues)) + ;; A level-2 group heading (contains issues): descend, capture each + ;; level-3 issue normalized to level 2, drop the group heading. + ;; pearl only ever emits issues under a group section, so a + ;; non-issue heading nested here isn't expected; if one appears + ;; it's skipped (not re-emitted) rather than mis-bucketed. + ((pearl--subtree-contains-issue-p beg end) + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (while (re-search-forward "^\\*+ " nil t) + (beginning-of-line) + (let ((cid (org-entry-get nil "LINEAR-ID"))) + (if (and cid (not (string-empty-p cid))) + (let* ((ibeg (point)) + (iend (save-excursion (org-end-of-subtree t t) (point))) + (lvl (org-current-level))) + (push (list :label (pearl--buffer-issue-group-label grouping) + :text (pearl--shift-heading-levels + (buffer-substring-no-properties ibeg iend) + (- 2 lvl))) + issues) + (goto-char iend)) + (forward-line 1)))))) + ;; A level-2 non-issue with no issues inside: malformed, keep it. + (t + (push (buffer-substring-no-properties beg end) malformed))) + (goto-char end))) + (setq issues (nreverse issues) + malformed (nreverse malformed)) + (delete-region content-beg parent-end) + (goto-char content-beg) + (if grouping + (let ((order '()) (table (make-hash-table :test 'equal))) + (dolist (it issues) + (let ((label (plist-get it :label))) + (unless (gethash label table) (push label order)) + (push it (gethash label table)))) + (dolist (label (nreverse order)) + (insert (format "** %s\n" label)) + (dolist (it (nreverse (gethash label table))) + (insert (pearl--shift-heading-levels (plist-get it :text) 1))))) + (dolist (it issues) + (insert (plist-get it :text)))) + (dolist (m malformed) (insert m)) + t))))) + (defun pearl--toggle-sort-target (source) "Return the (SORT . ORDER) to apply when toggling SOURCE's order. On a filter with no sort, establishes `updated' descending; otherwise flips the diff --git a/tests/test-pearl-grouping.el b/tests/test-pearl-grouping.el index 10902f1..af9c969 100644 --- a/tests/test-pearl-grouping.el +++ b/tests/test-pearl-grouping.el @@ -142,5 +142,149 @@ (should (equal (plist-get (pearl--read-active-source) :client-group) "workflowState")))) +;;; in-place regroup core (phase 2) + +(defconst test-pearl-grouping--flat + (concat + "#+LINEAR-SOURCE: (:type filter :name \"F\" :filter (:open t))\n\n" + "* F\n" + "** TODO SE-1: Alpha\n:PROPERTIES:\n:LINEAR-ID: i1\n" + ":LINEAR-STATE-NAME: In Progress\n:LINEAR-PROJECT-NAME: Apollo\n" + ":LINEAR-ASSIGNEE-NAME: Eric\n:LINEAR-PRIORITY: 2\n:END:\n" + "Body alpha.\n" + "*** Comments\n" + "**** Comment by Someone\n:PROPERTIES:\n:LINEAR-COMMENT-ID: c1\n:END:\nA comment.\n" + "** TODO SE-2: Beta\n:PROPERTIES:\n:LINEAR-ID: i2\n" + ":LINEAR-STATE-NAME: Todo\n:LINEAR-PROJECT-NAME: Apollo\n" + ":LINEAR-PRIORITY: 1\n:END:\n" + "Body beta.\n") + "A flat two-issue buffer with drawer fields for status/project/assignee/priority. +SE-1 has a comment subtree; SE-2 has no assignee.") + +(defun test-pearl-grouping--issue-level (id) + "Return the heading level of the issue with LINEAR-ID = ID, or nil." + (save-excursion + (goto-char (point-min)) + (catch 'found + (while (re-search-forward "^\\*+ " nil t) + (when (equal (org-entry-get nil "LINEAR-ID") id) + (throw 'found (org-current-level)))) + nil))) + +(defun test-pearl-grouping--group-headings () + "Return the level-2 non-issue headings (group labels) in document order." + (let (out) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\*\\* \\(.*\\)$" nil t) + ;; Capture the heading text before `org-entry-get', whose internal + ;; regex clobbers the match data. + (let ((text (match-string-no-properties 1))) + (unless (org-entry-get nil "LINEAR-ID") + (push text out))))) + (nreverse out))) + +(ert-deftest test-pearl-shift-heading-levels-demote () + "A +1 shift adds a star to every heading line, leaving body lines alone." + (should (equal (pearl--shift-heading-levels "** H\n:PROPERTIES:\n:X: 1\n:END:\nbody\n*** C\n" 1) + "*** H\n:PROPERTIES:\n:X: 1\n:END:\nbody\n**** C\n"))) + +(ert-deftest test-pearl-shift-heading-levels-promote () + "A -1 shift removes a star from every heading line." + (should (equal (pearl--shift-heading-levels "*** H\nbody\n**** C\n" -1) + "** H\nbody\n*** C\n"))) + +(ert-deftest test-pearl-shift-heading-levels-zero-is-identity () + "A zero delta returns the text unchanged." + (should (equal (pearl--shift-heading-levels "** H\nbody\n" 0) "** H\nbody\n"))) + +(ert-deftest test-pearl-regroup-flat-by-status () + "Grouping a flat buffer by status sections issues under level-2 group headings." + (test-pearl-grouping--in-org test-pearl-grouping--flat + (should (eq (pearl--regroup-issue-subtrees "workflowState") t)) + (should (equal (test-pearl-grouping--group-headings) '("In Progress" "Todo"))) + (should (= (test-pearl-grouping--issue-level "i1") 3)) + (should (= (test-pearl-grouping--issue-level "i2") 3)))) + +(ert-deftest test-pearl-regroup-flat-by-project-single-group () + "Grouping by a shared dimension puts both issues under one group heading." + (test-pearl-grouping--in-org test-pearl-grouping--flat + (should (eq (pearl--regroup-issue-subtrees "project") t)) + (should (equal (test-pearl-grouping--group-headings) '("Apollo"))) + (should (= (test-pearl-grouping--issue-level "i1") 3)) + (should (= (test-pearl-grouping--issue-level "i2") 3)))) + +(ert-deftest test-pearl-regroup-unset-dimension-bucket () + "An issue with no value for the dimension lands in the \"No X\" bucket." + (test-pearl-grouping--in-org test-pearl-grouping--flat + (should (eq (pearl--regroup-issue-subtrees "assignee") t)) + (should (member "No assignee" (test-pearl-grouping--group-headings))))) + +(ert-deftest test-pearl-regroup-priority-bucket-label () + "Priority grouping uses the Linear priority names (High, Urgent)." + (test-pearl-grouping--in-org test-pearl-grouping--flat + (should (eq (pearl--regroup-issue-subtrees "priority") t)) + (should (equal (sort (copy-sequence (test-pearl-grouping--group-headings)) #'string<) + '("High" "Urgent"))))) + +(ert-deftest test-pearl-regroup-none-flattens () + "Ungrouping a grouped buffer returns issues to level 2 with no group headings." + (test-pearl-grouping--in-org test-pearl-grouping--flat + (pearl--regroup-issue-subtrees "workflowState") + (should (eq (pearl--regroup-issue-subtrees nil) t)) + (should (null (test-pearl-grouping--group-headings))) + (should (= (test-pearl-grouping--issue-level "i1") 2)) + (should (= (test-pearl-grouping--issue-level "i2") 2)))) + +(ert-deftest test-pearl-regroup-grouped-to-different-dimension () + "Regrouping an already-grouped buffer by a new dimension re-buckets the issues." + (test-pearl-grouping--in-org test-pearl-grouping--flat + (pearl--regroup-issue-subtrees "workflowState") + (should (eq (pearl--regroup-issue-subtrees "project") t)) + (should (equal (test-pearl-grouping--group-headings) '("Apollo"))) + (should (= (test-pearl-grouping--issue-level "i1") 3)) + (should (= (test-pearl-grouping--issue-level "i2") 3)))) + +(ert-deftest test-pearl-regroup-roundtrips-flat () + "Group then ungroup restores the flat shape and keeps both issues." + (test-pearl-grouping--in-org test-pearl-grouping--flat + (pearl--regroup-issue-subtrees "workflowState") + (pearl--regroup-issue-subtrees nil) + (should (= (test-pearl-grouping--issue-level "i1") 2)) + (should (= (test-pearl-grouping--issue-level "i2") 2)) + (should (equal (sort (mapcar #'car (pearl--issue-subtree-markers)) #'string<) + '("i1" "i2"))))) + +(ert-deftest test-pearl-regroup-preserves-local-edits () + "Regroup moves subtrees byte-for-byte: an unsaved body edit survives." + (test-pearl-grouping--in-org test-pearl-grouping--flat + (goto-char (point-min)) + (search-forward "Body alpha.") + (replace-match "Body alpha EDITED LOCALLY.") + (should (eq (pearl--regroup-issue-subtrees "workflowState") t)) + (goto-char (point-min)) + (should (search-forward "Body alpha EDITED LOCALLY." nil t)) + ;; the comment child rode along under the regrouped issue + (should (= (test-pearl-grouping--issue-level "i1") 3)) + (goto-char (point-min)) + (should (search-forward "A comment." nil t)))) + +(ert-deftest test-pearl-regroup-keeps-malformed-subtree-last () + "A non-issue level-2 subtree is kept, placed after the issue groups." + (test-pearl-grouping--in-org + (concat test-pearl-grouping--flat + "** Stray non-issue heading\nSome notes.\n") + (should (eq (pearl--regroup-issue-subtrees "workflowState") t)) + (let ((headings (test-pearl-grouping--group-headings))) + (should (member "Stray non-issue heading" headings)) + ;; the stray heading sorts after the real group headings + (should (equal (car (last headings)) "Stray non-issue heading"))))) + +(ert-deftest test-pearl-regroup-no-issues () + "An issue-free buffer reports `no-issues' and is left alone." + (test-pearl-grouping--in-org + "#+LINEAR-SOURCE: (:type filter :name \"F\" :filter nil)\n\n* F\n" + (should (eq (pearl--regroup-issue-subtrees "workflowState") 'no-issues)))) + (provide 'test-pearl-grouping) ;;; test-pearl-grouping.el ends here |