path: root/tests/test-pearl-grouping.el

;;; test-pearl-grouping.el --- Tests for interactive grouping -*- lexical-binding: t; -*-

;; Copyright (C) 2026 Craig Jennings

;; Author: Craig Jennings <c@cjennings.net>

;; This program 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.

;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Tests for grouping the active view interactively (docs/interactive-grouping-spec.org):
;; the display<->value coercion and validation, the :client-group source
;; helper and the effective-grouping resolver, the in-place regroup (subtree
;; capture + heading-level shift + malformed-last), and the pearl-set-grouping
;; command.  Phase 1 covers the source/resolver plumbing.

;;; Code:

(require 'test-bootstrap (expand-file-name "test-bootstrap.el"))
(require 'cl-lib)

(defmacro test-pearl-grouping--in-org (content &rest body)
  "Run BODY in an org-mode temp buffer holding CONTENT."
  (declare (indent 1))
  `(let ((org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE"))))
     (with-temp-buffer
       (insert ,content)
       (org-mode)
       (goto-char (point-min))
       ,@body)))

;;; display -> value coercion

(ert-deftest test-pearl-grouping-display-to-value-maps-status ()
  "The display label \"status\" coerces to Linear's `workflowState'."
  (should (equal (pearl--grouping-display-to-value "status") "workflowState")))

(ert-deftest test-pearl-grouping-display-to-value-identity-dimensions ()
  "Project/assignee/priority coerce to their own Linear grouping value."
  (should (equal (pearl--grouping-display-to-value "project") "project"))
  (should (equal (pearl--grouping-display-to-value "assignee") "assignee"))
  (should (equal (pearl--grouping-display-to-value "priority") "priority")))

(ert-deftest test-pearl-grouping-display-to-value-none-is-nil ()
  "The display label \"none\" coerces to nil (ungroup)."
  (should (null (pearl--grouping-display-to-value "none"))))

(ert-deftest test-pearl-grouping-display-to-value-unknown-errors ()
  "An unknown display label signals a `user-error'."
  (should-error (pearl--grouping-display-to-value "sideways") :type 'user-error))

;;; validation

(ert-deftest test-pearl-check-grouping-valid ()
  "nil (none) and the four interactive grouping values pass."
  (should (pearl--check-grouping nil))
  (should (pearl--check-grouping "workflowState"))
  (should (pearl--check-grouping "project"))
  (should (pearl--check-grouping "priority")))

(ert-deftest test-pearl-check-grouping-cycle-rejected ()
  "`cycle' is deferred from interactive grouping (not in the drawer)."
  (should-error (pearl--check-grouping "cycle") :type 'user-error))

(ert-deftest test-pearl-check-grouping-unknown-rejected ()
  "An unknown grouping value signals a `user-error'."
  (should-error (pearl--check-grouping "bogus") :type 'user-error))

;;; source helper

(ert-deftest test-pearl-source-with-grouping-filter ()
  "A filter records the interactive grouping under :client-group."
  (let ((out (pearl--source-with-grouping '(:type filter :name "x") "workflowState")))
    (should (equal (plist-get out :client-group) "workflowState"))))

(ert-deftest test-pearl-source-with-grouping-view-keeps-server-group ()
  "A view records :client-group, leaving its server :group untouched."
  (let ((out (pearl--source-with-grouping
              '(:type view :name "v" :id "vid" :group "project")
              "assignee")))
    (should (equal (plist-get out :client-group) "assignee"))
    (should (equal (plist-get out :group) "project"))))

(ert-deftest test-pearl-source-with-grouping-none-clears ()
  "Grouping value nil (none) removes :client-group so the source falls back."
  (let ((out (pearl--source-with-grouping
              '(:type view :name "v" :id "vid" :group "project" :client-group "assignee")
              nil)))
    (should-not (plist-member out :client-group))
    (should (equal (plist-get out :group) "project"))))

;;; effective-grouping resolver

(ert-deftest test-pearl-effective-grouping-view-client-overrides-server ()
  "A view's :client-group overrides its server :group."
  (should (equal (pearl--effective-grouping
                  '(:type view :group "project" :client-group "assignee"))
                 "assignee")))

(ert-deftest test-pearl-effective-grouping-view-server-only ()
  "A view with no :client-group renders by its server :group."
  (should (equal (pearl--effective-grouping '(:type view :group "project"))
                 "project")))

(ert-deftest test-pearl-effective-grouping-view-neither-is-nil ()
  "A view with neither key has no effective grouping (flat)."
  (should (null (pearl--effective-grouping '(:type view :name "v")))))

(ert-deftest test-pearl-effective-grouping-filter-client ()
  "A filter renders by its :client-group."
  (should (equal (pearl--effective-grouping '(:type filter :client-group "workflowState"))
                 "workflowState")))

(ert-deftest test-pearl-effective-grouping-none-cleared-falls-to-server ()
  "After none clears :client-group, a view falls back to its server :group."
  (let ((src (pearl--source-with-grouping
              '(:type view :group "project" :client-group "assignee") nil)))
    (should (equal (pearl--effective-grouping src) "project"))))

;;; header persistence

(ert-deftest test-pearl-grouping-client-group-roundtrips-in-header ()
  "Writing a source with :client-group is read back by `pearl--read-active-source'."
  (test-pearl-grouping--in-org
      (concat
       "#+LINEAR-SOURCE: (:type filter :name \"x\" :filter (:open t))\n\n"
       "* x\n")
    (pearl--write-linear-source-header
     (pearl--source-with-grouping '(:type filter :name "x" :filter (:open t))
                                  "workflowState"))
    (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))))

;;; command core (phase 3)

(ert-deftest test-pearl-apply-grouping-groups-and-persists ()
  "Applying a grouping regroups the buffer and writes :client-group to the header."
  (test-pearl-grouping--in-org test-pearl-grouping--flat
    (cl-letf (((symbol-function 'pearl--restore-page-visibility) (lambda () nil)))
      (should (eq (pearl--apply-grouping
                   '(:type filter :name "F" :filter (:open t)) "workflowState")
                  'grouped)))
    (should (equal (plist-get (pearl--read-active-source) :client-group) "workflowState"))
    (should (= (test-pearl-grouping--issue-level "i1") 3))))

(ert-deftest test-pearl-apply-grouping-none-clears-and-flattens ()
  "Applying none flattens the buffer and leaves no :client-group in the header."
  (test-pearl-grouping--in-org test-pearl-grouping--flat
    (cl-letf (((symbol-function 'pearl--restore-page-visibility) (lambda () nil)))
      (pearl--apply-grouping
       '(:type view :name "v" :id "vid" :client-group "workflowState") "workflowState")
      (should (eq (pearl--apply-grouping (pearl--read-active-source) nil) 'grouped)))
    (should-not (plist-member (pearl--read-active-source) :client-group))
    (should (= (test-pearl-grouping--issue-level "i1") 2))))

(ert-deftest test-pearl-apply-grouping-refolds-on-success ()
  "A successful regroup re-folds the page."
  (test-pearl-grouping--in-org test-pearl-grouping--flat
    (let (folded)
      (cl-letf (((symbol-function 'pearl--restore-page-visibility)
                 (lambda () (setq folded t))))
        (pearl--apply-grouping '(:type filter :name "F" :filter (:open t)) "workflowState"))
      (should folded))))

(ert-deftest test-pearl-apply-grouping-no-issues-skips-fold-and-header ()
  "An issue-free buffer reports no-issues without folding or writing the header."
  (test-pearl-grouping--in-org
      "#+LINEAR-SOURCE: (:type filter :name \"F\" :filter nil)\n\n* F\n"
    (cl-letf (((symbol-function 'pearl--restore-page-visibility)
               (lambda () (error "should not re-fold a no-issues buffer"))))
      (should (eq (pearl--apply-grouping '(:type filter :name "F" :filter nil) "workflowState")
                  'no-issues)))
    (should-not (plist-get (pearl--read-active-source) :client-group))))

;;; render integration — consumers read pearl--effective-grouping (phase 4)

(defconst test-pearl-grouping--issues
  (list (list :id "i1" :identifier "SE-1" :title "Alpha"
              :state '(:name "In Progress") :project '(:name "Apollo") :priority 2)
        (list :id "i2" :identifier "SE-2" :title "Beta"
              :state '(:name "Todo") :project '(:name "Apollo") :priority 1))
  "Two normalized issues with distinct states, one shared project.")

(ert-deftest test-pearl-build-org-content-client-group-overrides-server ()
  "The full render groups by :client-group, overriding a view's server :group."
  (let ((out (pearl--build-org-content
              test-pearl-grouping--issues
              '(:type view :name "V" :id "vid" :group "project"
                :client-group "workflowState"))))
    (should (string-match-p "^\\*\\* In Progress$" out))
    (should (string-match-p "^\\*\\* Todo$" out))
    (should-not (string-match-p "^\\*\\* Apollo$" out))))

(ert-deftest test-pearl-build-org-content-server-group-when-no-client ()
  "With no :client-group, the full render still honors the view's server :group."
  (let ((out (pearl--build-org-content
              test-pearl-grouping--issues
              '(:type view :name "V" :id "vid" :group "project"))))
    (should (string-match-p "^\\*\\* Apollo$" out))
    (should-not (string-match-p "^\\*\\* In Progress$" out))))

;;; group ordering (board order, not first-appearance)

(ert-deftest test-pearl-order-groups-workflowstate-by-type-then-position ()
  "workflowState groups order by state type rank, then position within a type."
  (let ((groups (list (cons "In Progress" (list '(:state (:type "started" :position 3.0))))
                      (cons "Icebox" (list '(:state (:type "backlog" :position 1.0))))
                      (cons "Done" (list '(:state (:type "completed" :position 5.0))))
                      (cons "Inbox" (list '(:state (:type "backlog" :position 2.0)))))))
    (should (equal (mapcar #'car (pearl--order-groups "workflowState" groups))
                   '("Icebox" "Inbox" "In Progress" "Done")))))

(ert-deftest test-pearl-order-groups-priority-urgent-first-none-last ()
  "priority groups order Urgent..Low, then None last."
  (let ((groups (list (cons "None" (list '(:priority 0)))
                      (cons "High" (list '(:priority 2)))
                      (cons "Urgent" (list '(:priority 1)))
                      (cons "Low" (list '(:priority 4))))))
    (should (equal (mapcar #'car (pearl--order-groups "priority" groups))
                   '("Urgent" "High" "Low" "None")))))

(ert-deftest test-pearl-order-groups-other-dimension-alphabetical ()
  "A dimension with no board order (project) sorts alphabetically by label."
  (let ((groups (list (cons "Zeta" (list '(:project (:name "Zeta"))))
                      (cons "alpha" (list '(:project (:name "alpha")))))))
    (should (equal (mapcar #'car (pearl--order-groups "project" groups))
                   '("alpha" "Zeta")))))

(ert-deftest test-pearl-group-issues-orders-by-board-order ()
  "pearl--group-issues sections by board order even when input order differs."
  (let ((issues (list '(:id "a" :state (:name "In Progress" :type "started" :position 3.0))
                      '(:id "b" :state (:name "Icebox" :type "backlog" :position 1.0)))))
    (should (equal (mapcar #'car (pearl--group-issues issues "workflowState"))
                   '("Icebox" "In Progress")))))

(defconst test-pearl-grouping--positioned
  (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-STATE-TYPE: started\n:LINEAR-STATE-POSITION: 3.0\n:END:\nBody.\n"
   "** TODO SE-2: Beta\n:PROPERTIES:\n:LINEAR-ID: i2\n"
   ":LINEAR-STATE-NAME: Icebox\n:LINEAR-STATE-TYPE: backlog\n:LINEAR-STATE-POSITION: 1.0\n:END:\nBody.\n")
  "Flat buffer where first-appearance (In Progress, Icebox) differs from board
order (Icebox before In Progress).")

(ert-deftest test-pearl-regroup-orders-sections-by-board-order ()
  "Regrouping by status orders the sections by Linear's board order, not arrival."
  (test-pearl-grouping--in-org test-pearl-grouping--positioned
    (should (eq (pearl--regroup-issue-subtrees "workflowState") t))
    (should (equal (test-pearl-grouping--group-headings) '("Icebox" "In Progress")))))

(ert-deftest test-pearl-format-issue-renders-state-position ()
  "The issue drawer carries LINEAR-STATE-POSITION so an offline regroup can order."
  (let ((out (pearl--format-issue-as-org-entry
              '(:id "x" :identifier "SE-9" :title "T"
                :state (:name "S" :type "started" :position 2.5)))))
    (should (string-match-p "LINEAR-STATE-POSITION:[[:space:]]+2\\.5" out))))

(provide 'test-pearl-grouping)
;;; test-pearl-grouping.el ends here