Use lexical-binding in apropos.el and add tests

* lisp/apropos.el: Use lexical-binding and remove redundant
:group args.
(apropos-words-to-regexp, apropos): Tweak docstrings.
(apropos-value-internal): Replace '(if x (progn y))' with
'(when x y)'.
(apropos-format-plist): Add docstring and replace '(if x (progn y))'
with '(when x y)'.

* test/lisp/apropos-tests.el: New file with tests for apropos.el.

diff --git a/lisp/apropos.el b/lisp/apropos.el
index 7277319cd890bc4a7f4e1bb5be2458133ca1177c..e40f94ccb8c5fe94c3aec0226ea758d409997f56 100644 (file)
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -1,4 +1,4 @@
-;;; apropos.el --- apropos commands for users and programmers
+;;; apropos.el --- apropos commands for users and programmers  -*- lexical-binding: t -*-
 
 ;; Copyright (C) 1989, 1994-1995, 2001-2020 Free Software Foundation,
 ;; Inc.
@@ -82,49 +82,41 @@ commands also has an optional argument to request a more extensive search.
 
 Additionally, this option makes the function `apropos-library'
 include key-binding information in its output."
-  :group 'apropos
   :type 'boolean)
 
 (defface apropos-symbol
   '((t (:inherit bold)))
   "Face for the symbol name in Apropos output."
-  :group 'apropos
   :version "24.3")
 
 (defface apropos-keybinding
   '((t (:inherit underline)))
   "Face for lists of keybinding in Apropos output."
-  :group 'apropos
   :version "24.3")
 
 (defface apropos-property
   '((t (:inherit font-lock-builtin-face)))
   "Face for property name in Apropos output, or nil for none."
-  :group 'apropos
   :version "24.3")
 
 (defface apropos-function-button
   '((t (:inherit (font-lock-function-name-face button))))
   "Button face indicating a function, macro, or command in Apropos."
-  :group 'apropos
   :version "24.3")
 
 (defface apropos-variable-button
   '((t (:inherit (font-lock-variable-name-face button))))
   "Button face indicating a variable in Apropos."
-  :group 'apropos
   :version "24.3")
 
 (defface apropos-user-option-button
   '((t (:inherit (font-lock-variable-name-face button))))
   "Button face indicating a user option in Apropos."
-  :group 'apropos
   :version "24.4")
 
 (defface apropos-misc-button
   '((t (:inherit (font-lock-constant-face button))))
   "Button face indicating a miscellaneous object type in Apropos."
-  :group 'apropos
   :version "24.3")
 
 (defcustom apropos-match-face 'match
@@ -132,14 +124,12 @@ include key-binding information in its output."
 This applies when you look for matches in the documentation or variable value
 for the pattern; the part that matches gets displayed in this font."
   :type '(choice (const nil) face)
-  :group 'apropos
   :version "24.3")
 
 (defcustom apropos-sort-by-scores nil
   "Non-nil means sort matches by scores; best match is shown first.
 This applies to all `apropos' commands except `apropos-documentation'.
 If value is `verbose', the computed score is shown for each match."
-  :group 'apropos
   :type '(choice (const :tag "off" nil)
                 (const :tag "on" t)
                 (const :tag "show scores" verbose)))
@@ -148,7 +138,6 @@ If value is `verbose', the computed score is shown for each match."
   "Non-nil means sort matches by scores; best match is shown first.
 This applies to `apropos-documentation' only.
 If value is `verbose', the computed score is shown for each match."
-  :group 'apropos
   :type '(choice (const :tag "off" nil)
                 (const :tag "on" t)
                 (const :tag "show scores" verbose)))
@@ -352,7 +341,7 @@ before finding a label."
 
 \f
 (defun apropos-words-to-regexp (words wild)
-  "Make regexp matching any two of the words in WORDS.
+  "Return a regexp matching any two of the words in WORDS.
 WILD should be a subexpression matching wildcards between matches."
   (setq words (delete-dups (copy-sequence words)))
   (if (null (cdr words))
@@ -644,7 +633,7 @@ search for matches for any two (or more) of those words.
 With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil,
 consider all symbols (if they match PATTERN).
 
-Returns list of symbols and documentation found."
+Return list of symbols and documentation found."
   (interactive (list (apropos-read-pattern "symbol")
                     current-prefix-arg))
   (setq apropos--current (list #'apropos pattern do-all))
@@ -921,16 +910,14 @@ Returns list of symbols and documentation found."
 
 \f
 (defun apropos-value-internal (predicate symbol function)
-  (if (funcall predicate symbol)
-      (progn
-       (setq symbol (prin1-to-string (funcall function symbol)))
-       (if (string-match apropos-regexp symbol)
-           (progn
-             (if apropos-match-face
-                 (put-text-property (match-beginning 0) (match-end 0)
-                                    'face apropos-match-face
-                                    symbol))
-             symbol)))))
+  (when (funcall predicate symbol)
+    (setq symbol (prin1-to-string (funcall function symbol)))
+    (when (string-match apropos-regexp symbol)
+      (if apropos-match-face
+          (put-text-property (match-beginning 0) (match-end 0)
+                             'face apropos-match-face
+                             symbol))
+      symbol)))
 
 (defun apropos-documentation-internal (doc)
   (cond
@@ -952,6 +939,10 @@ Returns list of symbols and documentation found."
       doc))))
 
 (defun apropos-format-plist (pl sep &optional compare)
+  "Return a string representation of the plist PL.
+Paired elements are separated by the string SEP.  Only include
+properties matching the current `apropos-regexp' when COMPARE is
+non-nil."
   (setq pl (symbol-plist pl))
   (let (p p-out)
     (while pl
@@ -960,13 +951,12 @@ Returns list of symbols and documentation found."
          (put-text-property 0 (length (symbol-name (car pl)))
                             'face 'apropos-property p)
        (setq p nil))
-      (if p
-         (progn
-           (and compare apropos-match-face
-                (put-text-property (match-beginning 0) (match-end 0)
-                                   'face apropos-match-face
-                                   p))
-           (setq p-out (concat p-out (if p-out sep) p))))
+      (when p
+        (and compare apropos-match-face
+             (put-text-property (match-beginning 0) (match-end 0)
+                                'face apropos-match-face
+                                p))
+        (setq p-out (concat p-out (if p-out sep) p)))
       (setq pl (nthcdr 2 pl)))
     p-out))
 

diff --git a/test/lisp/apropos-tests.el b/test/lisp/apropos-tests.el
new file mode 100644 (file)
index 0000000..4c5522d
--- /dev/null
+++ b/test/lisp/apropos-tests.el
@@ -0,0 +1,133 @@
+;;; apropos-tests.el --- Tests for apropos.el  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; Author: Simen Heggestøyl <simenheg@gmail.com>
+;; Keywords:
+
+;; 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 'apropos)
+(require 'ert)
+
+(ert-deftest apropos-tests-words-to-regexp-1 ()
+  (let ((re (apropos-words-to-regexp '("foo" "bar") "baz")))
+    (should (string-match-p re "foobazbar"))
+    (should (string-match-p re "barbazfoo"))
+    (should-not (string-match-p re "foo-bar"))
+    (should-not (string-match-p re "foobazbazbar"))))
+
+(ert-deftest apropos-tests-words-to-regexp-2 ()
+  (let ((re (apropos-words-to-regexp '("foo" "bar" "baz") "-")))
+    (should-not (string-match-p re "foo"))
+    (should-not (string-match-p re "foobar"))
+    (should (string-match-p re "foo-bar"))
+    (should (string-match-p re "foo-baz"))))
+
+(ert-deftest apropos-tests-parse-pattern-1 ()
+  (apropos-parse-pattern '("foo"))
+  (should (string-match-p apropos-regexp "foo"))
+  (should (string-match-p apropos-regexp "foo-bar"))
+  (should (string-match-p apropos-regexp "bar-foo"))
+  (should (string-match-p apropos-regexp "foo-foo"))
+  (should-not (string-match-p apropos-regexp "bar")))
+
+(ert-deftest apropos-tests-parse-pattern-2 ()
+  (apropos-parse-pattern '("foo" "bar"))
+  (should (string-match-p apropos-regexp "foo-bar"))
+  (should (string-match-p apropos-regexp "bar-foo"))
+  (should-not (string-match-p apropos-regexp "foo"))
+  (should-not (string-match-p apropos-regexp "bar"))
+  (should-not (string-match-p apropos-regexp "baz"))
+  (should-not (string-match-p apropos-regexp "foo-foo"))
+  (should-not (string-match-p apropos-regexp "bar-bar")))
+
+(ert-deftest apropos-tests-parse-pattern-3 ()
+  (apropos-parse-pattern '("foo" "bar" "baz"))
+  (should (string-match-p apropos-regexp "foo-bar"))
+  (should (string-match-p apropos-regexp "foo-baz"))
+  (should (string-match-p apropos-regexp "bar-foo"))
+  (should (string-match-p apropos-regexp "bar-baz"))
+  (should (string-match-p apropos-regexp "baz-foo"))
+  (should (string-match-p apropos-regexp "baz-bar"))
+  (should-not (string-match-p apropos-regexp "foo"))
+  (should-not (string-match-p apropos-regexp "bar"))
+  (should-not (string-match-p apropos-regexp "baz"))
+  (should-not (string-match-p apropos-regexp "foo-foo"))
+  (should-not (string-match-p apropos-regexp "bar-bar"))
+  (should-not (string-match-p apropos-regexp "baz-baz")))
+
+(ert-deftest apropos-tests-parse-pattern-single-regexp ()
+  (apropos-parse-pattern "foo+bar")
+  (should-not (string-match-p apropos-regexp "fobar"))
+  (should (string-match-p apropos-regexp "foobar"))
+  (should (string-match-p apropos-regexp "fooobar")))
+
+(ert-deftest apropos-tests-parse-pattern-synonyms ()
+  (let ((apropos-synonyms '(("find" "open" "edit"))))
+    (apropos-parse-pattern '("open"))
+    (should (string-match-p apropos-regexp "find-file"))
+    (should (string-match-p apropos-regexp "open-file"))
+    (should (string-match-p apropos-regexp "edit-file"))))
+
+(ert-deftest apropos-tests-calc-scores ()
+  (let ((str "Return apropos score for string STR."))
+    (should (equal (apropos-calc-scores str '("apr")) '(7)))
+    (should (equal (apropos-calc-scores str '("apr" "str")) '(25 7)))
+    (should (equal (apropos-calc-scores str '("appr" "str")) '(25)))
+    (should-not (apropos-calc-scores str '("appr" "strr")))))
+
+(ert-deftest apropos-tests-score-str ()
+  (apropos-parse-pattern '("foo" "bar"))
+  (should (< (apropos-score-str "baz")
+             (apropos-score-str "foo baz")
+             (apropos-score-str "foo bar baz"))))
+
+(ert-deftest apropos-tests-score-doc ()
+  (apropos-parse-pattern '("foo" "bar"))
+  (should (< (apropos-score-doc "baz")
+             (apropos-score-doc "foo baz")
+             (apropos-score-doc "foo bar baz"))))
+
+(ert-deftest apropos-tests-score-symbol ()
+  (apropos-parse-pattern '("foo" "bar"))
+  (should (< (apropos-score-symbol 'baz)
+             (apropos-score-symbol 'foo-baz)
+             (apropos-score-symbol 'foo-bar-baz))))
+
+(ert-deftest apropos-tests-true-hit ()
+  (should-not (apropos-true-hit "foo" '("foo" "bar")))
+  (should (apropos-true-hit "foo bar" '("foo" "bar")))
+  (should (apropos-true-hit "foo bar baz" '("foo" "bar"))))
+
+(ert-deftest apropos-tests-format-plist ()
+  (setplist 'foo '(a 1 b (2 3) c nil))
+  (apropos-parse-pattern '("b"))
+  (should (equal (apropos-format-plist 'foo ", ")
+                 "a 1, b (2 3), c nil"))
+  (should (equal (apropos-format-plist 'foo ", " t)
+                 "b (2 3)"))
+  (apropos-parse-pattern '("d"))
+  (should-not (apropos-format-plist 'foo ", " t)))
+
+(provide 'apropos-tests)
+;;; apropos-tests.el ends here