1 ;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2015-2018 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
26 (eval-when-compile (require 'ert
)) ;Don't indirectly require cl-lib at run-time.
29 (fmakunbound 'cl--generic-1
)
30 (cl-defgeneric cl--generic-1
(x y
))
31 (cl-defgeneric (setf cl--generic-1
) (v y z
) "My generic doc.")
33 (ert-deftest cl-generic-test-00
()
34 (fmakunbound 'cl--generic-1
)
35 (cl-defgeneric cl--generic-1
(x y
))
36 (cl-defmethod cl--generic-1 ((x t
) y
) (cons x y
))
37 (should (equal (cl--generic-1 'a
'b
) '(a . b
))))
39 (ert-deftest cl-generic-test-01-eql
()
40 (fmakunbound 'cl--generic-1
)
41 (cl-defgeneric cl--generic-1
(x y
))
42 (cl-defmethod cl--generic-1 ((x t
) y
) (cons x y
))
43 (cl-defmethod cl--generic-1 ((_x (eql 4)) _y
)
44 (cons "quatre" (cl-call-next-method)))
45 (cl-defmethod cl--generic-1 ((_x (eql 5)) _y
)
46 (cons "cinq" (cl-call-next-method)))
47 (cl-defmethod cl--generic-1 ((_x (eql 6)) y
)
48 (cons "six" (cl-call-next-method 'a y
)))
49 (should (equal (cl--generic-1 'a nil
) '(a)))
50 (should (equal (cl--generic-1 4 nil
) '("quatre" 4)))
51 (should (equal (cl--generic-1 5 nil
) '("cinq" 5)))
52 (should (equal (cl--generic-1 6 nil
) '("six" a
))))
54 (cl-defstruct cl-generic-struct-parent a b
)
55 (cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent
)) c
)
56 (cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1
)) d
)
57 (cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent
)) e
)
59 (ert-deftest cl-generic-test-02-struct
()
60 (fmakunbound 'cl--generic-1
)
61 (cl-defgeneric cl--generic-1
(x y
) "My doc.")
62 (cl-defmethod cl--generic-1 ((x t
) y
) "Doc 1." (cons x y
))
63 (cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent
) y
)
64 "Doc 2." (cons "parent" (cl-call-next-method 'a y
)))
65 (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1
) _y
)
66 (cons "child1" (cl-call-next-method)))
67 (cl-defmethod cl--generic-1 :around
((_x t
) _y
)
68 (cons "around" (cl-call-next-method)))
69 (cl-defmethod cl--generic-1 :around
((_x cl-generic-struct-child11
) _y
)
70 (cons "child11" (cl-call-next-method)))
71 (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2
) _y
)
72 (cons "child2" (cl-call-next-method)))
73 (should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil
)
74 '("around" "child1" "parent" a
)))
75 (should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil
)
76 '("around""child2" "parent" a
)))
77 (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil
)
78 '("child11" "around""child1" "parent" a
))))
80 ;; I don't know how to put this inside an `ert-test'. This tests that `setf'
81 ;; can be used directly inside the body of the setf method.
82 (cl-defmethod (setf cl--generic-2
) (v (y integer
) z
)
83 (setf (cl--generic-2 (nth y z
) z
) v
))
85 (ert-deftest cl-generic-test-03-setf
()
86 (cl-defmethod (setf cl--generic-1
) (v (y t
) z
) (list v y z
))
87 (cl-defmethod (setf cl--generic-1
) (v (_y (eql 4)) z
) (list v
"four" z
))
88 (should (equal (setf (cl--generic-1 'a
'b
) 'v
) '(v a b
)))
89 (should (equal (setf (cl--generic-1 4 'b
) 'v
) '(v "four" b
)))
91 (should (equal (setf (cl--generic-1 (progn (push 1 x
) 'a
)
92 (progn (push 2 x
) 'b
))
93 (progn (push 3 x
) 'v
))
95 (should (equal x
'(3 2 1)))))
97 (ert-deftest cl-generic-test-04-overlapping-tagcodes
()
98 (fmakunbound 'cl--generic-1
)
99 (cl-defgeneric cl--generic-1
(x y
) "My doc.")
100 (cl-defmethod cl--generic-1 ((y t
) z
) (list y z
))
101 (cl-defmethod cl--generic-1 ((_y (eql 4)) _z
)
102 (cons "four" (cl-call-next-method)))
103 (cl-defmethod cl--generic-1 ((_y integer
) _z
)
104 (cons "integer" (cl-call-next-method)))
105 (cl-defmethod cl--generic-1 ((_y number
) _z
)
106 (cons "number" (cl-call-next-method)))
107 (should (equal (cl--generic-1 'a
'b
) '(a b
)))
108 (should (equal (cl--generic-1 1 'b
) '("integer" "number" 1 b
)))
109 (should (equal (cl--generic-1 4 'b
) '("four" "integer" "number" 4 b
))))
111 (ert-deftest cl-generic-test-05-alias
()
112 (fmakunbound 'cl--generic-1
)
113 (cl-defgeneric cl--generic-1
(x y
) "My doc.")
114 (defalias 'cl--generic-2
#'cl--generic-1
)
115 (cl-defmethod cl--generic-1 ((y t
) z
) (list y z
))
116 (cl-defmethod cl--generic-2 ((_y (eql 4)) _z
)
117 (cons "four" (cl-call-next-method)))
118 (should (equal (cl--generic-1 4 'b
) '("four" 4 b
))))
120 (ert-deftest cl-generic-test-06-multiple-dispatch
()
121 (fmakunbound 'cl--generic-1
)
122 (cl-defgeneric cl--generic-1
(x y
) "My doc.")
123 (cl-defmethod cl--generic-1 (x y
) (list x y
))
124 (cl-defmethod cl--generic-1 (_x (_y integer
))
125 (cons "y-int" (cl-call-next-method)))
126 (cl-defmethod cl--generic-1 ((_x integer
) _y
)
127 (cons "x-int" (cl-call-next-method)))
128 (cl-defmethod cl--generic-1 ((_x integer
) (_y integer
))
129 (cons "x&y-int" (cl-call-next-method)))
130 (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2))))
132 (ert-deftest cl-generic-test-07-apo
()
133 (fmakunbound 'cl--generic-1
)
134 (cl-defgeneric cl--generic-1
(x y
)
135 (:documentation
"My doc.") (:argument-precedence-order y x
))
136 (cl-defmethod cl--generic-1 (x y
) (list x y
))
137 (cl-defmethod cl--generic-1 (_x (_y integer
))
138 (cons "y-int" (cl-call-next-method)))
139 (cl-defmethod cl--generic-1 ((_x integer
) _y
)
140 (cons "x-int" (cl-call-next-method)))
141 (cl-defmethod cl--generic-1 ((_x integer
) (_y integer
))
142 (cons "x&y-int" (cl-call-next-method)))
143 (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2))))
145 (ert-deftest cl-generic-test-08-after
/before
()
147 (fmakunbound 'cl--generic-1
)
148 (cl-defgeneric cl--generic-1
(x y
))
149 (cl-defmethod cl--generic-1 ((_x t
) y
) (cons y log
))
150 (cl-defmethod cl--generic-1 ((_x (eql 4)) _y
)
151 (cons "quatre" (cl-call-next-method)))
152 (cl-defmethod cl--generic-1 :after
(x _y
)
153 (push (list :after x
) log
))
154 (cl-defmethod cl--generic-1 :before
(x _y
)
155 (push (list :before x
) log
))
156 (should (equal (cl--generic-1 4 6) '("quatre" 6 (:before
4))))
157 (should (equal log
'((:after
4) (:before
4))))))
159 (defun cl--generic-test-advice (&rest args
) (cons "advice" (apply args
)))
161 (ert-deftest cl-generic-test-09-advice
()
162 (fmakunbound 'cl--generic-1
)
163 (cl-defgeneric cl--generic-1
(x y
) "My doc.")
164 (cl-defmethod cl--generic-1 (x y
) (list x y
))
165 (advice-add 'cl--generic-1
:around
#'cl--generic-test-advice
)
166 (should (equal (cl--generic-1 4 5) '("advice" 4 5)))
167 (cl-defmethod cl--generic-1 ((_x integer
) _y
)
168 (cons "integer" (cl-call-next-method)))
169 (should (equal (cl--generic-1 4 5) '("advice" "integer" 4 5)))
170 (advice-remove 'cl--generic-1
#'cl--generic-test-advice
)
171 (should (equal (cl--generic-1 4 5) '("integer" 4 5))))
173 (ert-deftest cl-generic-test-10-weird
()
174 (fmakunbound 'cl--generic-1
)
175 (cl-defgeneric cl--generic-1
(x &rest r
) "My doc.")
176 (cl-defmethod cl--generic-1 (x &rest r
) (cons x r
))
177 ;; This kind of definition is not valid according to CLHS, but it does show
178 ;; up in EIEIO's tests for no-next-method, so we should either
179 ;; detect it and signal an error or do something meaningful with it.
180 (cl-defmethod cl--generic-1 (x (y integer
) &rest r
)
181 `("integer" ,y
,x
,@r
))
182 (should (equal (cl--generic-1 'a
'b
) '(a b
)))
183 (should (equal (cl--generic-1 1 2) '("integer" 2 1))))
185 (ert-deftest cl-generic-test-11-next-method-p
()
186 (fmakunbound 'cl--generic-1
)
187 (cl-defgeneric cl--generic-1
(x y
))
188 (cl-defmethod cl--generic-1 ((x t
) y
)
189 (list x y
(cl-next-method-p)))
190 (cl-defmethod cl--generic-1 ((_x (eql 4)) _y
)
191 (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method)))
192 (should (equal (cl--generic-1 4 5) '("quatre" t
4 5 nil
))))
194 (ert-deftest cl-generic-test-12-context
()
195 (fmakunbound 'cl--generic-1
)
196 (cl-defgeneric cl--generic-1
())
197 (cl-defmethod cl--generic-1 (&context
(overwrite-mode (eql t
)))
198 (list 'is-t
(cl-call-next-method)))
199 (cl-defmethod cl--generic-1 (&context
(overwrite-mode (eql nil
)))
200 (list 'is-nil
(cl-call-next-method)))
201 (cl-defmethod cl--generic-1 () 'any
)
202 (should (equal (list (let ((overwrite-mode t
)) (cl--generic-1))
203 (let ((overwrite-mode nil
)) (cl--generic-1))
204 (let ((overwrite-mode 1)) (cl--generic-1)))
205 '((is-t any
) (is-nil any
) any
))))
207 (ert-deftest cl-generic-test-13-head
()
208 (fmakunbound 'cl--generic-1
)
209 (cl-defgeneric cl--generic-1
(x y
))
210 (cl-defmethod cl--generic-1 ((x t
) y
) (cons x y
))
211 (cl-defmethod cl--generic-1 ((_x (head 4)) _y
)
212 (cons "quatre" (cl-call-next-method)))
213 (cl-defmethod cl--generic-1 ((_x (head 5)) _y
)
214 (cons "cinq" (cl-call-next-method)))
215 (cl-defmethod cl--generic-1 ((_x (head 6)) y
)
216 (cons "six" (cl-call-next-method 'a y
)))
217 (should (equal (cl--generic-1 'a nil
) '(a)))
218 (should (equal (cl--generic-1 '(4) nil
) '("quatre" (4))))
219 (should (equal (cl--generic-1 '(5) nil
) '("cinq" (5))))
220 (should (equal (cl--generic-1 '(6) nil
) '("six" a
))))
222 (cl-defgeneric cl-generic-tests--generic
(x))
223 (cl-defmethod cl-generic-tests--generic ((x string
))
224 (message "%s is a string" x
))
225 (cl-defmethod cl-generic-tests--generic ((x integer
))
226 (message "%s is a number" x
))
227 (cl-defgeneric cl-generic-tests--generic-without-methods
(x y
))
228 (defvar cl-generic-tests--this-file
229 (file-truename (or load-file-name buffer-file-name
)))
231 (ert-deftest cl-generic-tests--method-files--finds-methods
()
232 "`method-files' returns a list of files and methods for a generic function."
233 (let ((retval (cl--generic-method-files 'cl-generic-tests--generic
)))
234 (should (equal (length retval
) 2))
236 (should (equal (car x
) cl-generic-tests--this-file
))
237 (should (equal (cadr x
) 'cl-generic-tests--generic
)))
239 (should-not (equal (nth 0 retval
) (nth 1 retval
)))))
241 (ert-deftest cl-generic-tests--method-files--nonexistent-methods
()
242 "`method-files' returns nil if asked to find a method which doesn't exist."
243 (should-not (cl--generic-method-files 'cl-generic-tests--undefined-generic
))
244 (should-not (cl--generic-method-files 'cl-generic-tests--generic-without-methods
)))
246 (provide 'cl-generic-tests
)
247 ;;; cl-generic-tests.el ends here
