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

;;; test-pearl-conflict.el --- Tests for interactive conflict resolution -*- 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 the conflict-resolution foundation: the no-data-loss stash
;; (`pearl--stash-conflict-text'), the smerge conflict-string builder
;; (`pearl--conflict-smerge-string'), and the resolution prompt
;; (`pearl--read-conflict-resolution', cancel-by-default).

;;; Code:

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

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

(defun test-pearl-conflict--marker ()
  "Return a marker at the first issue heading in the current buffer."
  (goto-char (point-min))
  (re-search-forward "^\\*\\*\\* ")
  (beginning-of-line)
  (point-marker))

;;; --stash-conflict-text

(ert-deftest test-pearl-stash-conflict-text-to-kill-ring-and-buffer ()
  "Stashing puts the text on the kill ring and into the backup buffer."
  (let ((kill-ring nil))
    (when (get-buffer "*pearl-conflict-backup*")
      (kill-buffer "*pearl-conflict-backup*"))
    (pearl--stash-conflict-text "ENG-1 description" "My local edit.")
    (should (string= "My local edit." (current-kill 0)))
    (with-current-buffer "*pearl-conflict-backup*"
      (let ((s (buffer-string)))
        (should (string-match-p "ENG-1 description" s))
        (should (string-match-p "My local edit\\." s))))))

(ert-deftest test-pearl-stash-conflict-text-appends-not-overwrites ()
  "A second stash appends below the first, preserving earlier backups."
  (let ((kill-ring nil))
    (when (get-buffer "*pearl-conflict-backup*")
      (kill-buffer "*pearl-conflict-backup*"))
    (pearl--stash-conflict-text "ENG-1 description" "First edit.")
    (pearl--stash-conflict-text "ENG-2 title" "Second edit.")
    (with-current-buffer "*pearl-conflict-backup*"
      (let ((s (buffer-string)))
        (should (string-match-p "First edit\\." s))
        (should (string-match-p "Second edit\\." s))))))

(ert-deftest test-pearl-stash-conflict-text-empty-is-noop ()
  "Stashing empty text touches neither the kill ring nor the backup buffer."
  (let ((kill-ring nil))
    (when (get-buffer "*pearl-conflict-backup*")
      (kill-buffer "*pearl-conflict-backup*"))
    (pearl--stash-conflict-text "ENG-1 description" "")
    (should (null kill-ring))
    (should-not (get-buffer "*pearl-conflict-backup*"))))

;;; --conflict-smerge-string

(ert-deftest test-pearl-conflict-smerge-string-has-markers-in-order ()
  "The smerge string carries the three markers with local before remote."
  (let ((s (pearl--conflict-smerge-string "LOCAL TEXT" "REMOTE TEXT")))
    (should (string-match-p "^<<<<<<<" s))
    (should (string-match-p "^=======" s))
    (should (string-match-p "^>>>>>>>" s))
    (let ((lt (string-match "LOCAL TEXT" s))
          (sep (string-match "^=======" s))
          (rt (string-match "REMOTE TEXT" s)))
      (should (< lt sep))
      (should (< sep rt)))))

(ert-deftest test-pearl-conflict-smerge-string-newline-terminates-sections ()
  "Sections whose text lacks a trailing newline still get one before a marker."
  (let ((s (pearl--conflict-smerge-string "no-newline-local" "no-newline-remote")))
    ;; The separator and closing markers must each start their own line.
    (should (string-match-p "no-newline-local\n=======" s))
    (should (string-match-p "no-newline-remote\n>>>>>>>" s))))

;;; --read-conflict-resolution

(ert-deftest test-pearl-read-conflict-resolution-maps-choices ()
  "Each prompt label maps to its resolution symbol."
  (dolist (case '(("use local" . use-local)
                  ("use remote" . use-remote)
                  ("rewrite" . rewrite)
                  ("cancel" . cancel)))
    (cl-letf (((symbol-function 'completing-read)
               (lambda (_prompt collection &rest _)
                 ;; Return the first offered label containing the case keyword.
                 (seq-find (lambda (c) (string-match-p (car case) c)) collection))))
      (should (eq (cdr case) (pearl--read-conflict-resolution "ENG-1 description"))))))

(ert-deftest test-pearl-read-conflict-resolution-defaults-to-cancel ()
  "Selecting the default (a bare RET) resolves to `cancel'."
  (cl-letf (((symbol-function 'completing-read)
             (lambda (_prompt _collection &rest args)
               ;; Emulate RET-on-default: completing-read returns the DEF arg.
               ;; args = (predicate require-match initial-input hist def ...),
               ;; so DEF is the 5th element, index 4.
               (nth 4 args))))
    (should (eq 'cancel (pearl--read-conflict-resolution "ENG-1 description")))))

;;; --set-entry-body-at-point

(ert-deftest test-pearl-set-entry-body-replaces-body-keeps-drawer ()
  "Setting the body replaces the text after the drawer and preserves the drawer."
  (test-pearl-conflict--in-org
      "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: x\n:END:\nOld body.\n"
    (re-search-forward "Title")
    (pearl--set-entry-body-at-point "New body line.")
    (goto-char (point-min))
    (should (re-search-forward "New body line\\." nil t))
    (goto-char (point-min))
    (should-not (re-search-forward "Old body\\." nil t))
    (should (string= "a" (org-entry-get nil "LINEAR-ID")))))

(ert-deftest test-pearl-set-entry-body-stops-before-child-heading ()
  "Setting the body does not disturb a child Comments subtree."
  (test-pearl-conflict--in-org
      (concat "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nOld body.\n"
              "**** Comments\n***** Me — t\nmine\n")
    (re-search-forward "Title")
    (pearl--set-entry-body-at-point "New body.")
    (goto-char (point-min))
    (should (re-search-forward "New body\\." nil t))
    (should (re-search-forward "Comments" nil t))
    (should (re-search-forward "mine" nil t))))

;;; --resolve-conflict

(ert-deftest test-pearl-resolve-conflict-cancel-does-nothing ()
  "Cancel applies nothing, pushes nothing, and leaves the provenance hash."
  (test-pearl-conflict--in-org
      "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: H0\n:END:\nbody\n"
    (let ((applied nil) (pushed nil) (marker (test-pearl-conflict--marker)))
      (cl-letf (((symbol-function 'pearl--read-conflict-resolution) (lambda (_) 'cancel)))
        (pearl--resolve-conflict
         "ENG-1 description" "local" "remote" marker "LINEAR-DESC-SHA256"
         (lambda (_md) (setq applied t))
         (lambda (_md cb) (setq pushed t) (funcall cb t)))
        (should-not applied)
        (should-not pushed)
        (should (string= "H0" (org-entry-get marker "LINEAR-DESC-SHA256")))))))

(ert-deftest test-pearl-resolve-conflict-use-local-pushes-and-advances ()
  "Use-local pushes the local text and advances the hash to it on success."
  (test-pearl-conflict--in-org
      "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: H0\n:END:\nbody\n"
    (let ((pushed-md nil) (applied nil) (marker (test-pearl-conflict--marker)))
      (cl-letf (((symbol-function 'pearl--read-conflict-resolution) (lambda (_) 'use-local)))
        (pearl--resolve-conflict
         "ENG-1 description" "local text" "remote text" marker "LINEAR-DESC-SHA256"
         (lambda (_md) (setq applied t))
         (lambda (md cb) (setq pushed-md md) (funcall cb t)))
        (should (string= "local text" pushed-md))
        (should-not applied)
        (should (string= (secure-hash 'sha256 "local text")
                         (org-entry-get marker "LINEAR-DESC-SHA256")))))))

(ert-deftest test-pearl-resolve-conflict-use-remote-stashes-applies-no-push ()
  "Use-remote stashes local, writes remote, advances the hash, and never pushes."
  (let ((kill-ring nil))
    (test-pearl-conflict--in-org
        "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: H0\n:END:\nbody\n"
      (let ((applied-md nil) (pushed nil) (marker (test-pearl-conflict--marker)))
        (cl-letf (((symbol-function 'pearl--read-conflict-resolution) (lambda (_) 'use-remote)))
          (pearl--resolve-conflict
           "ENG-1 description" "local text" "remote text" marker "LINEAR-DESC-SHA256"
           (lambda (md) (setq applied-md md))
           (lambda (_md cb) (setq pushed t) (funcall cb t)))
          (should (string= "remote text" applied-md))
          (should-not pushed)
          (should (string= (secure-hash 'sha256 "remote text")
                           (org-entry-get marker "LINEAR-DESC-SHA256")))
          ;; the local edit was stashed, not lost
          (should (string= "local text" (current-kill 0))))))))

(ert-deftest test-pearl-resolve-conflict-rewrite-applies-and-pushes ()
  "Rewrite stashes local, then on the smerge finish applies and pushes the merge."
  (let ((kill-ring nil))
    (test-pearl-conflict--in-org
        "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: H0\n:END:\nbody\n"
      (let ((applied nil) (pushed nil) (marker (test-pearl-conflict--marker)))
        (cl-letf (((symbol-function 'pearl--read-conflict-resolution) (lambda (_) 'rewrite))
                  ;; Emulate the user resolving the buffer and committing.
                  ((symbol-function 'pearl--resolve-conflict-in-smerge)
                   (lambda (_label _local _remote on-finish)
                     (funcall on-finish "merged text"))))
          (pearl--resolve-conflict
           "ENG-1 description" "local text" "remote text" marker "LINEAR-DESC-SHA256"
           (lambda (md) (setq applied md))
           (lambda (md cb) (setq pushed md) (funcall cb t)))
          (should (string= "local text" (current-kill 0)))
          (should (string= "merged text" applied))
          (should (string= "merged text" pushed))
          (should (string= (secure-hash 'sha256 "merged text")
                           (org-entry-get marker "LINEAR-DESC-SHA256"))))))))

;;; --conflict-has-markers-p

(ert-deftest test-pearl-conflict-has-markers-p ()
  "Unresolved marker text reports markers; resolved text does not."
  (should (pearl--conflict-has-markers-p
           (pearl--conflict-smerge-string "mine" "theirs")))
  (should-not (pearl--conflict-has-markers-p "just the merged line\n")))

;;; --resolve-conflict-in-smerge (buffer setup)

(ert-deftest test-pearl-resolve-conflict-in-smerge-sets-up-buffer ()
  "Opening the smerge buffer fills it with both sides and arms the callback."
  (let ((buf-name "*pearl-merge: ENG-1 description*"))
    (when (get-buffer buf-name) (kill-buffer buf-name))
    (cl-letf (((symbol-function 'pop-to-buffer) #'ignore))
      (pearl--resolve-conflict-in-smerge
       "ENG-1 description" "my local" "the remote" (lambda (_) nil)))
    (let ((buf (get-buffer buf-name)))
      (should buf)
      (with-current-buffer buf
        (should (string-match-p "my local" (buffer-string)))
        (should (string-match-p "the remote" (buffer-string)))
        (should (bound-and-true-p smerge-mode))
        (should (functionp pearl--conflict-on-finish)))
      (kill-buffer buf))))

;;; --conflict-commit / --conflict-abort

(ert-deftest test-pearl-conflict-commit-refuses-with-markers ()
  "Committing with markers still present errors and never calls the callback."
  (let ((called nil) (buf-name "*pearl-merge: ENG-1 description*"))
    (when (get-buffer buf-name) (kill-buffer buf-name))
    (cl-letf (((symbol-function 'pop-to-buffer) #'ignore))
      (pearl--resolve-conflict-in-smerge
       "ENG-1 description" "mine" "theirs" (lambda (_) (setq called t))))
    (with-current-buffer buf-name
      (should-error (pearl--conflict-commit) :type 'user-error))
    (should-not called)
    (when (get-buffer buf-name) (kill-buffer buf-name))))

(ert-deftest test-pearl-conflict-commit-resolved-calls-callback-and-kills ()
  "With markers resolved, commit hands the text to the callback and kills the buffer."
  (let ((got nil) (buf-name "*pearl-merge: ENG-1 description*"))
    (when (get-buffer buf-name) (kill-buffer buf-name))
    (cl-letf (((symbol-function 'pop-to-buffer) #'ignore))
      (pearl--resolve-conflict-in-smerge
       "ENG-1 description" "mine" "theirs" (lambda (txt) (setq got txt))))
    (with-current-buffer buf-name
      (erase-buffer)
      (insert "the reconciled text\n")
      (pearl--conflict-commit))
    (should (string= "the reconciled text\n" got))
    (should-not (get-buffer buf-name))))

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