Sous-modules pour test-unitaire.

environnement.lisp

@@ -144,10 +144,10 @@ l'environnement top-level."
                          ("TOP-LEVEL" (X . 24) (Z . 73))))
   '(("TOP-LEVEL" (X . 24) (Z . 73))))
 (deftest environnement
-  (add-top-level-binding (copy-seq '(("TEST" (X . 42)) ("TOP-LEVEL" (Y . 56))))
+  (add-top-level-binding (copy-tree '(("TEST" (X . 42)) ("TOP-LEVEL" (Y . 56))))
                          'Z 78)
   '(("TEST" (X . 42)) ("TOP-LEVEL" (Z . 78) (Y . 56))))
 (deftest environnement
-  (set-top-level-binding (copy-seq '(("LEVEL2" (X . 42)) ("TOP-LEVEL" (Y . 56))))
+  (set-top-level-binding (copy-tree '(("LEVEL2" (X . 42)) ("TOP-LEVEL" (Y . 56))))
                          'Y "42")
   '(("LEVEL2" (X . 42)) ("TOP-LEVEL" (Y . "42"))))

test-unitaire.lisp

@@ -1,22 +1,57 @@
-;; TODO : exploser tout ça en plein de petites fonctions, c'est trop gros...
+;; all-tests             : <module-struct>
-;; Mutation cons.
+;; <module-struct>       : (<alist-of-submodules> executed-bit variables tests)
-(defvar all-tests nil "Liste de tous les tests")
+;; <alist-of-submodules> : ((nom-module . <module-struct>) (nom-module2 . <module>) ...)
+(defvar all-tests (list nil nil nil nil) "Liste de tous les tests")
 
-;(defmacro eval-in-env (expr env)
+(defun test-get-module (module &optional (from all-tests))
-;  `(eval-in-env-2 ',expr ,env))
+  (unless (listp module) (setq module (list module)))
-;
+  (if (endp module)
-;(defun eval-in-env-2 (qexpr env)
+      from
-;  '(eval `(let ,env ,qexpr)))
+      (let ((association (assoc (car module) (car from))))
+        (unless association
+          (let ((new-assoc (list (car module) nil nil nil nil)))
+            (push new-assoc (car from))
+            (setq association new-assoc)))
+        (test-get-module (cdr module) (cdr association)))))
+
+(defun test-get-submodules (module) (first  (test-get-module module)))
+(defun test-get-executed   (module) (second (test-get-module module)))
+(defun test-get-variables  (module) (third  (test-get-module module)))
+(defun test-get-tests      (module) (fourth (test-get-module module)))
+
+(defun test-set-executed (from &optional (value t))
+  (setf (second from) value))
+
+(defun test-clear-all-executed (&optional (from all-tests))
+  (setf (second from) nil)
+  (mapcar #'test-clear-all-executed
+		  (mapcar #'cdr (first from))))
+
+(defun test-add-variable (module variable)
+  (push variable (third (test-get-module module)))
+  t)
+
+(defun test-add-test (module test)
+  (push test (fourth (test-get-module module)))
+  t)
+
+(defun test-remove-module (module)
+  (if (null module)
+      (setf all-tests (list nil nil nil nil))
+      (let ((from (test-get-module (butlast module))))
+        (setf (first from)
+              (delete (last module)
+                      (first from)
+                      :key #'car)))))
 
 (defun booleq (a b)
   (if a b (not b)))
 
 (defmacro deftest (module test expected &optional (compare #'equal))
-  `(progn
+  `(test-add-test
-     (if (not (assoc ',module all-tests))
+    ',module
-         (setf all-tests (cons (list ',module nil nil) all-tests)))
+    (lambda ()
-     (push (lambda ()
+      (let* ((vars (test-get-variables ',module))
-             (let* ((vars (second (assoc ',module all-tests)))
              (_test ',test)
              (_expected ',expected)
              (_compare ,compare)
@@ -39,56 +74,69 @@
               (format t "~&              got        : ~w~&" res)
               (format t "~&              expected   : ~w~&" exp)
               (format t "~&              comparison : ~w~&" _compare)
-                     nil))))
+              nil))))))
-           (third (assoc ',module all-tests)))
-     t))
 
 (defmacro deftestvar (module name value)
-  `(progn
+  `(test-add-variable ',module
-     (if (not (assoc ',module all-tests))
+                      (list ',name (list 'copy-tree ',value))))
-         (setf all-tests (cons (list ',module nil nil) all-tests)))
+
-     (push (list ',name (list 'copy-seq ',value))
+(defun run-tests-submodules (module-name submodules)
-           (second (assoc ',module all-tests)))
+  (if (endp submodules)
-     t))
+      t
+      (and (real-run-tests (append module-name (list (caar submodules))) (cdar submodules))
+           (run-tests-submodules module-name (cdr submodules)))))
+
+(defvar run-tests-counter 0)
+(defun real-run-tests (module-name from)
+  (if (second from)
+      (progn
+        (format t "~&~%-~{ ~a~}~&    [Déjà vu]~&" (or module-name '("all-tests")))
+        t)
+      (progn
+        (format t "~&~%>~{ ~a~}~&" (or module-name '("all-tests")))
+        (setf (second from) t) ;; marquer comme exécuté.
+        (let ((nb-fail (count-if-not #'funcall (reverse (fourth from)))))
+          (if (= nb-fail 0)
+              (progn
+                (incf run-tests-counter (length (fourth from)))
+                (run-tests-submodules module-name (reverse (first from))))
+              (format t "Module ~w failed ~w tests. Stopping.~&" module-name nb-fail))))))
 
 (defmacro run-tests (&rest modules)
-  (if (or (not modules)
+  (when (null modules) (setq modules '(nil)))
-          (eq (car modules) t))
+  (setq modules (substitute nil t modules))
-      `(real-run-tests all-tests)
+  (setq run-tests-counter 0)
-      `(real-run-tests (remove-if-not (lambda (x)
+  `(progn
-                                        (member (car x) ',modules))
+	 (test-clear-all-executed)
-                                      all-tests))))
+	 (if (every #'real-run-tests
-
+                ',(mapcar (lambda (x) (if (listp x) x (list x))) modules)
-;; OMFG that's not lisp, that's english o_O
+                ',(mapcar #'test-get-module modules))
-(defun real-run-tests (modules)
+         (progn (format t "~a tests passed sucessfully." run-tests-counter)
-  (loop
+                t)
-     for (module vars tests) in (reverse modules)
+         nil)))
-     for nb-fail = (loop
-                      initially (format t "~&Module ~w :~&" module)
-                      for test
-                      in (reverse tests)
-                      count (not (funcall test)))
-     when (> nb-fail 0)
-       do (format t "Module ~w failed ~w tests. Stopping.~&" module nb-fail)
-       and return nil
-     finally (return t)))
-
-(defun erase-tests-1 (module)
-  (if module
-      (let ((association (assoc module all-tests)))
-        (when association
-          (setf (cdr association) (list nil nil))))
-      (setf all-tests nil)))
 
 (defmacro erase-tests (&optional module)
-  `(erase-tests-1 ',module))
+  (unless (listp module) (setq module (list module)))
+  `(test-remove-module ',module))
 
-;(deftest moda nil nil)
+;;; Exemples d'utilisation.
-;(deftest moda (eq 42 42) t)
+
-;(deftest modb (eq 'a 'a) t)
+;; (erase-tests (a sub-1))
-;(deftest modb (eq 'a 'b) nil)
+;; (erase-tests b)
-;(deftest modb (eq 'a 'c) t)
+;; (erase-tests)
-;(deftest modb 1 1)
+
-;(deftest modc (+ 1 2) (+ 2 1))
+;; (deftestvar a foo 'bar)
-;(deftestvar modc x 1)
+;; (deftest a nil nil)
-;(deftest modc (+ x 2) (+ 2 1))
+;; (deftest a (eq 42 42) t)
+;; (deftest (a) (eq 'bar 'bar) t)
+;; (deftest (a) (eq 'baz 'quux) nil)
+;; (deftest (a sub-1) (eq 'x 'y) nil)
+;; (deftest (a sub-1) (eq 'x 'x) t)
+;; (deftest (a sub-2) (eq 'x 'x) t)
+;; (deftest (b sub-1) (eq 'y 'y) t)
+;; (deftest c (eq 'foo 'foo) t)
+
+;; (run-tests (a sub-1) b t)
+;; (run-tests ())
+;; (run-tests t)
+;; (run-tests)

util.lisp

@@ -9,6 +9,7 @@
 ;; (remove-if-not predicate list) filtre la liste en fonction de predicate.
 ;; (incf x) incrémente x, (decf x) décrémente x.
 ;; (loop ......) lire la doc...
+;; (subst new old tree) remplace old par new dans tree.
 
 (defmacro aset (k v alist)
   `(let ((my-k ,k)