From 45d42f81621743a96f209102464432ef2f230b0f Mon Sep 17 00:00:00 2001 From: =?utf8?q?Simen=20Heggest=C3=B8yl?= Date: Sat, 18 Apr 2020 18:36:49 +0200 Subject: [PATCH] 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. --- lisp/apropos.el | 52 ++++++--------- test/lisp/apropos-tests.el | 133 +++++++++++++++++++++++++++++++++++++ 2 files changed, 154 insertions(+), 31 deletions(-) create mode 100644 test/lisp/apropos-tests.el diff --git a/lisp/apropos.el b/lisp/apropos.el index 7277319cd89..e40f94ccb8c 100644 --- 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." (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." (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 index 00000000000..4c5522d14c2 --- /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 +;; 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 . + +;;; 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 -- 2.39.2