;;; erc-fill-tests.el --- Tests for erc-fill  -*- lexical-binding:t -*-

;; Copyright (C) 2023 Free Software Foundation, Inc.

;; 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:

;;; Code:
(require 'ert-x)
(require 'erc-fill)

(defun erc-fill-tests--wrap-populate (test)
  (let ((proc (start-process "sleep" (current-buffer) "sleep" "1"))
        (id (erc-networks--id-create 'foonet))
        (erc-insert-modify-hook '(erc-fill erc-add-timestamp))
        (erc-server-users (make-hash-table :test 'equal))
        (erc-fill-function 'erc-fill-wrap)
        (pre-command-hook pre-command-hook)
        (erc-modules '(fill stamp))
        (msg "Hello World")
        (inhibit-message noninteractive)
        erc-insert-post-hook
        extended-command-history
        erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
    (when (bound-and-true-p erc-button-mode)
      (push 'erc-button-add-buttons erc-insert-modify-hook))
    (erc-mode)
    (setq erc-server-process proc erc-networks--id id)
    (set-process-query-on-exit-flag erc-server-process nil)

    (with-current-buffer (get-buffer-create "#chan")
      (erc-mode)
      (erc-munge-invisibility-spec)
      (setq erc-server-process proc
            erc-networks--id id
            erc-channel-users (make-hash-table :test 'equal)
            erc--target (erc--target-from-string "#chan")
            erc-default-recipients (list "#chan"))
      (erc--initialize-markers (point) nil)

      (erc-update-channel-member
       "#chan" "alice" "alice" t nil nil nil nil nil "fake" "~u" nil nil t)

      (erc-update-channel-member
       "#chan" "bob" "bob" t nil nil nil nil nil "fake" "~u" nil nil t)

      (setq msg "This server is in debug mode and is logging all user I/O.\
 If you do not wish for everything you send to be readable\
 by the server owner(s), please disconnect.")
      (erc-display-message nil 'notice (current-buffer) msg)

      (setq msg "bob: come, you are a tedious fool: to the purpose.\
 What was done to Elbow's wife, that he hath cause to complain of?\
 Come me to what was done to her.")
      (erc-display-message nil nil (current-buffer)
                           (erc-format-privmessage "alice" msg nil t))

      ;; Introduce an artificial gap in properties `line-prefix' and
      ;; `wrap-prefix' and later ensure they're not incremented twice.
      (save-excursion
        (forward-line -1)
        (search-forward "? ")
        (remove-text-properties (1- (point)) (point)
                                '(line-prefix t wrap-prefix t)))

      (setq msg "alice: Either your unparagoned mistress is dead,\
 or she's outprized by a trifle.")
      (erc-display-message nil nil (current-buffer)
                           (erc-format-privmessage "bob" msg nil t))

      (let ((original-window-buffer (window-buffer (selected-window))))
        (set-window-buffer (selected-window) (current-buffer))
        ;; Defend against non-local exits from `ert-skip'
        (unwind-protect
            (funcall test)
          (set-window-buffer (selected-window) original-window-buffer)
          (when noninteractive
            (kill-buffer)))))))

(defun erc-fill-tests--wrap-check-nudge (expected-width)
  (save-excursion
    (goto-char (point-min))
    (should (search-forward "*** This server" nil t))
    (should (get-text-property (pos-bol) 'line-prefix))
    (should (get-text-property (pos-eol) 'line-prefix))
    (should (equal (get-text-property (pos-bol) 'wrap-prefix)
                   `(space :width ,expected-width)))
    (should (equal (get-text-property (pos-eol) 'wrap-prefix)
                   `(space :width ,expected-width)))

    ;; Prefix props are applied properly and faces are accounted
    ;; for when determining widths.
    (should (search-forward "<a" nil t))
    (should (get-text-property (pos-bol) 'line-prefix))
    (should (get-text-property (pos-eol) 'line-prefix))
    (should (equal (get-text-property (pos-bol) 'wrap-prefix)
                   `(space :width ,expected-width)))
    (should (equal (get-text-property (pos-eol) 'wrap-prefix)
                   `(space :width ,expected-width)))

    ;; The last elt in the `:width' value is a singleton (NUM) when
    ;; figuring pixels.  Otherwise, it's just NUM. See EXPR in the
    ;; prod rules table under (info "(elisp) Pixel Specification").
    (should (pcase (get-text-property (point) 'line-prefix)
              ((and (guard (fboundp 'string-pixel-width))
                    `(space :width (- ,n (,w))))
               (and (= n expected-width)
                    (= w (string-pixel-width "<alice> "))))
              (`(space :width (- ,n ,w))
               (and (= n expected-width)
                    (= w (length "<alice> "))))))

    ;; Ensure the loop is not visited twice due to the gap.
    (should (search-forward "<b" nil t))
    (should (get-text-property (pos-bol) 'line-prefix))
    (should (get-text-property (pos-eol) 'line-prefix))
    (should (equal (get-text-property (pos-bol) 'wrap-prefix)
                   `(space :width ,expected-width)))
    (should (equal (get-text-property (pos-eol) 'wrap-prefix)
                   `(space :width ,expected-width)))
    (should (pcase (get-text-property (point) 'line-prefix)
              ((and (guard (fboundp 'string-pixel-width))
                    `(space :width (- ,n (,w))))
               (and (= n expected-width)
                    (= w (string-pixel-width "<bob> "))))
              (`(space :width (- ,n ,w))
               (and (= n expected-width)
                    (= w (length "<bob> "))))))))

(ert-deftest erc-fill-wrap--monospace ()
  :tags '(:unstable)

  (erc-fill-tests--wrap-populate

   (lambda ()
     (set-window-buffer (selected-window) (current-buffer))
     (erc-fill-tests--wrap-check-nudge 27)

     (ert-info ("Shift right by one")
       (ert-with-message-capture messages
         (execute-kbd-macro (kbd "M-x erc-fill-wrap-nudge RET +"))
         (should (string-match (rx "for further adjustment") messages)))
       (erc-fill-tests--wrap-check-nudge 29))

     (ert-info ("Shift left by five")
       (execute-kbd-macro (kbd "M-x erc-fill-wrap-nudge RET -----"))
       (erc-fill-tests--wrap-check-nudge 25))

     (ert-info ("Reset")
       (execute-kbd-macro (kbd "M-x erc-fill-wrap-nudge RET 0"))
       (erc-fill-tests--wrap-check-nudge 27)))))

(ert-deftest erc-fill-wrap--variable-pitch ()
  :tags '(:unstable)
  (unless (and (fboundp 'string-pixel-width)
               (not noninteractive)
               (display-graphic-p))
    (ert-skip "Test needs interactive graphical Emacs"))

  (with-selected-frame (make-frame '((name . "other")))
    (set-face-attribute 'default (selected-frame)
                        :family "Sans Serif"
                        :foundry 'unspecified
                        :font 'unspecified)

    (erc-fill-tests--wrap-populate
     (lambda ()
       (erc-fill-tests--wrap-check-nudge 27)
       (erc-fill--wrap-nudge 2)
       (erc-fill-tests--wrap-check-nudge 29)
       (erc-fill--wrap-nudge -6)
       (erc-fill-tests--wrap-check-nudge 25)
       (erc-fill--wrap-nudge 0)
       (erc-fill-tests--wrap-check-nudge 27)

       ;; FIXME get rid of this "void variable `erc--results-ewoc'"
       ;; error, which seems related to operating in a non-default
       ;; frame.
       ;;
       ;; As a kludge, checking if point made it to the prompt can
       ;; serve as visual confirmation that the test passed.
       (goto-char (point-max))))))

;;; erc-fill-tests.el ends here