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

;; FIXME these fixtures (and tests) are now largely useless.  Due to
;; the author's ignorance regarding display properties, the "space"
;; specs of prefix props on different lines didn't initially leverage
;; a common variable (`erc-fill--wrap-value'), so the column twiddling
;; was more laborious.  See decades-old comment above
;; calc_pixel_width_or_height in in xdisp.c for examples.
;;
;; TODO maybe use erts files instead of own snapshots.

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

(defvar erc-fill-tests--buffers nil)

(defun erc-fill-tests--wrap-populate (test)
  (cl-letf (((symbol-function 'erc-stamp--current-time)
             (lambda () '(0 1))))
    (let ((proc (start-process "sleep" (current-buffer) "sleep" "1"))
          (erc-stamp--tz t)
          (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
              (while-let ((buf (pop erc-fill-tests--buffers)))
                (kill-buffer buf))
              (kill-buffer))))))))

(defun erc-fill-tests--wrap-check-props (speaker)
  ;; Prefix props are applied properly and faces are accounted
  ;; for when determining widths.
  (should (search-forward speaker 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 erc-fill--wrap-value)))
  (should (equal (get-text-property (pos-eol) 'wrap-prefix)
                 '(space :width erc-fill--wrap-value)))

  ;; 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 (- erc-fill--wrap-value (,w))))
             (= w (string-pixel-width speaker)))
            (`(space :width (- erc-fill--wrap-value ,w))
             (= w (length speaker))))))

(defun erc-fill-tests--wrap-check-prefixes ()
  (save-excursion
    (goto-char (point-min))
    (erc-fill-tests--wrap-check-props "*** ")
    (erc-fill-tests--wrap-check-props "<alice> ")
    ;; Ensure the loop is not visited twice due to the gap.
    (erc-fill-tests--wrap-check-props "<bob> ")))

;; Set this variable to t to generate new snapshots after carefully
;; reviewing the output of each.
(defvar erc-fill-tests--save-p nil)

(defun erc-fill-tests--compare (name)
  (let* ((dir (expand-file-name "fill/snapshots/" (ert-resource-directory)))
         (expect-file (file-name-with-extension (expand-file-name name dir)
                                                "eld"))
         (erc--own-property-names
          (seq-difference `(erc-timestamp font-lock-face
                                          ,@erc--own-property-names)
                          '(display wrap-prefix line-prefix)
                          #'eq))
         (print-circle t)
         (print-escape-newlines t)
         (print-escape-nonascii t)
         (got (erc--remove-text-properties
               (buffer-substring (point-min) erc-insert-marker)))
         (repr (string-replace "erc-fill--wrap-value"
                               (number-to-string erc-fill--wrap-value)
                               (prin1-to-string got))))
    (with-current-buffer (generate-new-buffer name)
      (push name erc-fill-tests--buffers)
      (with-silent-modifications
        (insert (setq got (read repr))))
      (erc-mode))
    (if erc-fill-tests--save-p
        (with-temp-file expect-file
          (insert repr))
      (with-temp-buffer
        (insert-file-contents-literally expect-file)
        (should (equal got (read (current-buffer))))))))

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

  (erc-fill-tests--wrap-populate

   (lambda ()
     (set-window-buffer (selected-window) (current-buffer))
     (should (= erc-fill--wrap-value 27))
     (erc-fill-tests--wrap-check-prefixes)
     (erc-fill-tests--compare "monospace-01-start")

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

     (ert-info ("Shift left by five")
       (execute-kbd-macro (kbd "M-x erc-fill-wrap-nudge RET -----"))
       (should (= erc-fill--wrap-value 25))
       (erc-fill-tests--wrap-check-prefixes)
       (erc-fill-tests--compare "monospace-03-left"))

     (ert-info ("Reset")
       (execute-kbd-macro (kbd "M-x erc-fill-wrap-nudge RET 0"))
       (should (= erc-fill--wrap-value 27))
       (erc-fill-tests--wrap-check-prefixes)
       (erc-fill-tests--compare "monospace-04-reset")))))

(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 ()
       (should (= erc-fill--wrap-value 27))
       (erc-fill-tests--wrap-check-prefixes)
       (erc-fill--wrap-nudge 2)
       (should (= erc-fill--wrap-value 29))
       (erc-fill-tests--wrap-check-prefixes)
       (erc-fill--wrap-nudge -6)
       (should (= erc-fill--wrap-value 25))
       (erc-fill-tests--wrap-check-prefixes)
       (erc-fill--wrap-nudge 0)
       (should (= erc-fill--wrap-value 27))
       (erc-fill-tests--wrap-check-prefixes)

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

(ert-deftest erc-fill-wrap-visual-keys--body ()
  :tags '(:unstable)
  (erc-fill-tests--wrap-populate

   (lambda ()
     (set-window-buffer (selected-window) (current-buffer))
     (ert-info ("Value: non-input")
       (should (eq erc-fill--wrap-visual-keys 'non-input))
       (goto-char (point-min))
       (should (search-forward "that he hath" nil t))
       (execute-kbd-macro "\C-a")
       (should-not (looking-at (rx "<alice> ")))
       (execute-kbd-macro "\C-e")
       (should (search-backward "tedious fool" nil t))
       (should-not (looking-back "done to her\\."))
       (forward-char)
       (execute-kbd-macro "\C-e")
       (should (search-forward "done to her." nil t)))

     (ert-info ("Value: nil")
       (execute-kbd-macro "\C-ca")
       (should-not erc-fill--wrap-visual-keys)
       (goto-char (point-min))
       (should (search-forward "in debug mode" nil t))
       (execute-kbd-macro "\C-a")
       (should (looking-at (rx "*** ")))
       (execute-kbd-macro "\C-e")
       (should (eql ?\] (char-before (point)))))

     (ert-info ("Value: t")
       (execute-kbd-macro "\C-ca")
       (should (eq erc-fill--wrap-visual-keys t))
       (goto-char (point-min))
       (should (search-forward "that he hath" nil t))
       (execute-kbd-macro "\C-a")
       (should-not (looking-at (rx "<alice> ")))
       (should (search-backward "tedious fool" nil t))
       (execute-kbd-macro "\C-e")
       (should-not (looking-back (rx "done to her\\.")))
       (should (search-forward "done to her." nil t))
       (execute-kbd-macro "\C-a")
       (should-not (looking-at (rx "<alice> ")))))))

(ert-deftest erc-fill-wrap-visual-keys--prompt ()
  :tags '(:unstable)
  (erc-fill-tests--wrap-populate

   (lambda ()
     (set-window-buffer (selected-window) (current-buffer))
     (goto-char erc-input-marker)
     (insert "This buffer is for text that is not saved, and for Lisp "
             "evaluation.  To create a file, visit it with C-x C-f and "
             "enter text in its buffer.")

     (ert-info ("Value: non-input")
       (should (eq erc-fill--wrap-visual-keys 'non-input))
       (execute-kbd-macro "\C-a")
       (should (looking-at "This buffer"))
       (execute-kbd-macro "\C-e")
       (should (looking-back "its buffer\\."))
       (execute-kbd-macro "\C-a")
       (execute-kbd-macro "\C-k")
       (should (eobp)))

     (ert-info ("Value: nil") ; same
       (execute-kbd-macro "\C-ca")
       (should-not erc-fill--wrap-visual-keys)
       (execute-kbd-macro "\C-y")
       (should (looking-back "its buffer\\."))
       (execute-kbd-macro "\C-a")
       (should (looking-at "This buffer"))
       (execute-kbd-macro "\C-k")
       (should (eobp)))

     (ert-info ("Value: non-input")
       (execute-kbd-macro "\C-ca")
       (should (eq erc-fill--wrap-visual-keys t))
       (execute-kbd-macro "\C-y")
       (execute-kbd-macro "\C-a")
       (should-not (looking-at "This buffer"))
       (execute-kbd-macro "\C-p")
       (should-not (looking-back "its buffer\\."))
       (should (search-forward "its buffer." nil t))
       (should (search-backward "ERC> " nil t))
       (execute-kbd-macro "\C-a")))))

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