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.
This commit is contained in:
Simen Heggestøyl
parent
4819bea690
commit
45d42f8162
2 changed files with 154 additions and 31 deletions
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
133
test/lisp/apropos-tests.el
Normal file
133
test/lisp/apropos-tests.el
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Reference in a new issue