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

;; Copyright (C) 2019-2021 Free Software Foundation, Inc.

;; Author: Juanma Barranquero <lekktu@gmail.com>
;;         Eli Zaretskii <eliz@gnu.org>
;;         Stefan Kangas <stefankangas@gmail.com>
;; Keywords: help, internal

;; 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/>.

;;; Code:

(require 'ert)
(eval-when-compile (require 'cl-lib))
(require 'text-property-search) ; for `text-property-search-forward'

(ert-deftest help-split-fundoc-SECTION ()
  "Test new optional arg SECTION."
  (let* ((doc "Doc first line.\nDoc second line.")
         (usg "\n\n(fn ARG1 &optional ARG2)")
         (full (concat doc usg))
         (usage "(t ARG1 &optional ARG2)"))
    ;; Docstring has both usage and doc
    (should (equal (help-split-fundoc full t nil)    `(,usage . ,doc)))
    (should (equal (help-split-fundoc full t t)      `(,usage . ,doc)))
    (should (equal (help-split-fundoc full t 'usage)  usage))
    (should (equal (help-split-fundoc full t 'doc)    doc))
    ;; Docstring has no usage, only doc
    (should (equal (help-split-fundoc doc t nil)      nil))
    (should (equal (help-split-fundoc doc t t)       `(nil . ,doc)))
    (should (equal (help-split-fundoc doc t 'usage)  nil))
    (should (equal (help-split-fundoc doc t 'doc)    doc))
    ;; Docstring is only usage, no doc
    (should (equal (help-split-fundoc usg t nil)     `(,usage . nil)))
    (should (equal (help-split-fundoc usg t t)       `(,usage . nil)))
    (should (equal (help-split-fundoc usg t 'usage)  usage))
    (should (equal (help-split-fundoc usg t 'doc)    nil))
    ;; Docstring is null
    (should (equal (help-split-fundoc nil t nil)     nil))
    (should (equal (help-split-fundoc nil t t)       '(nil)))
    (should (equal (help-split-fundoc nil t 'usage)  nil))
    (should (equal (help-split-fundoc nil t 'doc)    nil))))

\f
;;; substitute-command-keys

(defmacro with-substitute-command-keys-test (&rest body)
  `(cl-flet* ((test
               (lambda (orig result)
                 (should (equal (substitute-command-keys orig)
                                result))))
              (test-re
               (lambda (orig regexp)
                 (should (string-match (concat "^" regexp "$")
                                       (substitute-command-keys orig))))))
     ,@body))

(ert-deftest help-tests-substitute-command-keys/no-change ()
  (with-substitute-command-keys-test
   (test "foo" "foo")
   (test "\\invalid-escape" "\\invalid-escape")))

(ert-deftest help-tests-substitute-command-keys/commands ()
  (with-substitute-command-keys-test
   (test "foo \\[goto-char]" "foo M-g c")
   (test "\\[next-line]" "C-n")
   (test "\\[next-line]\n\\[next-line]" "C-n\nC-n")
   (test "\\[next-line]\\[previous-line]" "C-nC-p")
   (test "\\[next-line]\\=\\[previous-line]" "C-n\\[previous-line]")
   ;; Allow any style of quotes, since the terminal might not support
   ;; UTF-8.  Same thing is done below.
   (test-re "\\[next-line]`foo'" "C-n[`'‘]foo['’]")
   (test "\\[emacs-version]" "M-x emacs-version")
   (test "\\[emacs-version]\\[next-line]" "M-x emacs-versionC-n")
   (test-re "\\[emacs-version]`foo'" "M-x emacs-version[`'‘]foo['’]")))

(ert-deftest help-tests-substitute-command-keys/keymaps ()
  (with-substitute-command-keys-test
   (test "\\{minibuffer-local-must-match-map}"
         "\
key             binding
---             -------

C-g		abort-minibuffers
TAB		minibuffer-complete
C-j		minibuffer-complete-and-exit
RET		minibuffer-complete-and-exit
ESC		Prefix Command
SPC		minibuffer-complete-word
?		minibuffer-completion-help
C-<tab>		file-cache-minibuffer-complete
<XF86Back>	previous-history-element
<XF86Forward>	next-history-element
<down>		next-line-or-history-element
<next>		next-history-element
<prior>		switch-to-completions
<up>		previous-line-or-history-element

M-v		switch-to-completions

M-<		minibuffer-beginning-of-buffer
M-n		next-history-element
M-p		previous-history-element
M-r		previous-matching-history-element
M-s		next-matching-history-element

")))

(ert-deftest help-tests-substitute-command-keys/keymap-change ()
  (with-substitute-command-keys-test
   (test "\\<minibuffer-local-must-match-map>\\[abort-recursive-edit]" "C-]")
   (test "\\<emacs-lisp-mode-map>\\[eval-defun]" "C-M-x")))

(defvar help-tests-remap-map
  (let ((map (make-keymap)))
    (define-key map (kbd "x") 'foo)
    (define-key map (kbd "y") 'bar)
    (define-key map [remap foo] 'bar)
    map))

(ert-deftest help-tests-substitute-command-keys/remap ()
  (should (equal (substitute-command-keys "\\<help-tests-remap-map>\\[foo]") "y"))
  (should (equal (substitute-command-keys "\\<help-tests-remap-map>\\[bar]") "y")))

(ert-deftest help-tests-substitute-command-keys/undefined-map ()
  (with-substitute-command-keys-test
   (test-re "\\{foobar-map}"
            "\nUses keymap [`'‘]foobar-map['’], which is not currently defined.\n")))

(ert-deftest help-tests-substitute-command-keys/quotes ()
 (with-substitute-command-keys-test
  (let ((text-quoting-style 'curve))
    (test "quotes ‘like this’" "quotes ‘like this’")
    (test "`x'" "‘x’")
    (test "`" "‘")
    (test "'" "’")
    (test "\\`" "\\‘"))
  (let ((text-quoting-style 'straight))
    (test "quotes `like this'" "quotes 'like this'")
    (test "`x'" "'x'")
    (test "`" "'")
    (test "'" "'")
    (test "\\`" "\\'"))
  (let ((text-quoting-style 'grave))
    (test "quotes `like this'" "quotes `like this'")
    (test "`x'" "`x'")
    (test "`" "`")
    (test "'" "'")
    (test "\\`" "\\`"))))

(ert-deftest help-tests-substitute-command-keys/literals ()
  (with-substitute-command-keys-test
   (test "foo \\=\\[goto-char]" "foo \\[goto-char]")
   (test "foo \\=\\=" "foo \\=")
   (test "\\=\\=" "\\=")
   (test "\\=\\[" "\\[")
   (let ((text-quoting-style 'curve))
     (test "\\=`x\\='" "`x'"))
   (let ((text-quoting-style 'straight))
     (test "\\=`x\\='" "`x'"))
   (let ((text-quoting-style 'grave))
     (test "\\=`x\\='" "`x'"))))

(ert-deftest help-tests-substitute-command-keys/no-change ()
  (with-substitute-command-keys-test
   (test "\\[foobar" "\\[foobar")
   (test "\\=" "\\=")))

(ert-deftest help-tests-substitute-command-keys/multibyte ()
  ;; Cannot use string= here, as that compares unibyte and multibyte
  ;; strings not equal.
  (should (compare-strings
           (substitute-command-keys "\200 \\[goto-char]") nil nil
           "\200 M-g c" nil nil)))

(ert-deftest help-tests-substitute-command-keys/apropos ()
  (save-window-excursion
    (apropos "foo")
    (switch-to-buffer "*Apropos*")
    (goto-char (point-min))
    (should (looking-at "Type RET on"))))

(defvar help-tests-major-mode-map
  (let ((map (make-keymap)))
    (define-key map "x" 'foo-original)
    (define-key map "1" 'foo-range)
    (define-key map "2" 'foo-range)
    (define-key map "3" 'foo-range)
    (define-key map "4" 'foo-range)
    (define-key map (kbd "C-e") 'foo-something)
    (define-key map '[F1] 'foo-function-key1)
    (define-key map "(" 'short-range)
    (define-key map ")" 'short-range)
    (define-key map "a" 'foo-other-range)
    (define-key map "b" 'foo-other-range)
    (define-key map "c" 'foo-other-range)
    map))

(define-derived-mode help-tests-major-mode nil
  "Major mode for testing shadowing.")

(defvar help-tests-minor-mode-map
  (let ((map (make-keymap)))
    (define-key map "x" 'foo-shadow)
    (define-key map (kbd "C-e") 'foo-shadow)
    map))

(define-minor-mode help-tests-minor-mode
  "Minor mode for testing shadowing.")

(ert-deftest help-tests-substitute-command-keys/add-key-face ()
  (should (equal (substitute-command-keys "\\[next-line]")
                 (propertize "C-n"
                             'face 'help-key-binding
                             'font-lock-face 'help-key-binding))))

(ert-deftest help-tests-substitute-command-keys/add-key-face-listing ()
  (with-temp-buffer
    (insert (substitute-command-keys "\\{help-tests-minor-mode-map}"))
    (goto-char (point-min))
    (text-property-search-forward 'face 'help-key-binding)
    (should (looking-at "C-e"))
    ;; Don't fontify trailing whitespace.
    (should-not (get-text-property (+ (point) 3) 'face))
    (text-property-search-forward 'face 'help-key-binding)
    (should (looking-at "x"))
    (should-not (get-text-property (+ (point) 1) 'face))))

(ert-deftest help-tests-substitute-command-keys/test-mode ()
  (with-substitute-command-keys-test
   (with-temp-buffer
     (help-tests-major-mode)
     (test "\\{help-tests-major-mode-map}"
           "\
key             binding
---             -------

( .. )		short-range
1 .. 4		foo-range
a .. c		foo-other-range

C-e		foo-something
x		foo-original
<F1>		foo-function-key1

"))))

(ert-deftest help-tests-substitute-command-keys/shadow ()
  (with-substitute-command-keys-test
   (with-temp-buffer
     (help-tests-major-mode)
     (help-tests-minor-mode)
     (test "\\{help-tests-major-mode-map}"
           "\
key             binding
---             -------

( .. )		short-range
1 .. 4		foo-range
a .. c		foo-other-range

C-e		foo-something
  (this binding is currently shadowed)
x		foo-original
  (this binding is currently shadowed)
<F1>		foo-function-key1

"))))

(ert-deftest help-tests-substitute-command-keys/command-remap ()
  (with-substitute-command-keys-test
   (let ((help-tests-major-mode-map (make-keymap))) ; Protect from changes.
    (with-temp-buffer
      (help-tests-major-mode)
      (define-key help-tests-major-mode-map [remap foo] 'bar)
      (test "\\{help-tests-major-mode-map}"
            "\
key             binding
---             -------

<remap>		Prefix Command

<remap> <foo>	bar

")))))

(ert-deftest help-tests-describe-map-tree/no-menu-t ()
  (with-temp-buffer
    (let ((standard-output (current-buffer))
          (map '(keymap . ((1 . foo)
                           (menu-bar keymap
                                     (foo menu-item "Foo" foo
                                          :enable mark-active
                                          :help "Help text"))))))
      (describe-map-tree map nil nil nil nil t nil nil nil)
      (should (equal (buffer-string) "key             binding
---             -------

C-a		foo

")))))

(ert-deftest help-tests-describe-map-tree/no-menu-nil ()
  (with-temp-buffer
    (let ((standard-output (current-buffer))
          (map '(keymap . ((1 . foo)
                           (menu-bar keymap
                                     (foo menu-item "Foo" foo
                                          :enable mark-active
                                          :help "Help text"))))))
      (describe-map-tree map nil nil nil nil nil nil nil nil)
      (should (equal (buffer-string) "key             binding
---             -------

C-a		foo
<menu-bar>	Prefix Command

<menu-bar> <foo>		foo

")))))

(ert-deftest help-tests-describe-map-tree/mention-shadow-t ()
  (with-temp-buffer
    (let ((standard-output (current-buffer))
          (map '(keymap . ((1 . foo)
                           (2 . bar))))
          (shadow-maps '((keymap . ((1 . baz))))))
      (describe-map-tree map t shadow-maps nil nil t nil nil t)
      (should (equal (buffer-string) "key             binding
---             -------

C-a		foo
  (this binding is currently shadowed)
C-b		bar

")))))

(ert-deftest help-tests-describe-map-tree/mention-shadow-nil ()
  (with-temp-buffer
    (let ((standard-output (current-buffer))
          (map '(keymap . ((1 . foo)
                           (2 . bar))))
          (shadow-maps '((keymap . ((1 . baz))))))
      (describe-map-tree map t shadow-maps nil nil t nil nil nil)
      (should (equal (buffer-string) "key             binding
---             -------

C-b		bar

")))))

(ert-deftest help-tests-describe-map-tree/partial-t ()
  (with-temp-buffer
    (let ((standard-output (current-buffer))
          (map '(keymap . ((1 . foo)
                           (2 . undefined)))))
      (describe-map-tree map t nil nil nil nil nil nil nil)
      (should (equal (buffer-string) "key             binding
---             -------

C-a		foo

")))))

(ert-deftest help-tests-describe-map-tree/partial-nil ()
  (with-temp-buffer
    (let ((standard-output (current-buffer))
          (map '(keymap . ((1 . foo)
                           (2 . undefined)))))
      (describe-map-tree map nil nil nil nil nil nil nil nil)
      (should (equal (buffer-string) "key             binding
---             -------

C-a		foo
C-b		undefined

")))))

(defvar help-tests--was-in-buffer nil)

(ert-deftest help-substitute-command-keys/menu-filter-in-correct-buffer ()
  "Evaluate menu-filter in the original buffer.  See Bug#39149."
  (unwind-protect
      (progn
        (define-key global-map (kbd "C-c C-l r")
          `(menu-item "2" identity
                      :filter ,(lambda (cmd)
                                 (setq help-tests--was-in-buffer
                                       (current-buffer))
                                 cmd)))
        (with-temp-buffer
          (substitute-command-keys "\\[identity]")
          (should (eq help-tests--was-in-buffer
                      (current-buffer)))))
    (setq help-tests--was-in-buffer nil)
    (define-key global-map (kbd "C-c C-l r") nil)
    (define-key global-map (kbd "C-c C-l") nil)))

(ert-deftest help-substitute-command-keys/preserves-text-properties ()
  "Check that we preserve text properties (Bug#17052)."
  (should (equal (substitute-command-keys
                  (propertize "foo \\[save-buffer]" 'face 'bold))
                 (propertize "foo C-x C-s" 'face 'bold))))

(provide 'help-tests)

;;; help-tests.el ends here