sly-stickers-tests.el (7727B)
1 ;; -*- lexical-binding: t; -*- 2 (require 'sly-stickers) 3 (require 'sly-tests "lib/sly-tests") 4 (require 'cl-lib) 5 (require 'ert-x) 6 7 (defvar sly-stickers--test-debug nil) 8 9 (defun sly-stickers--call-with-fixture (function forms sticker-prefixes) 10 (let ((file (make-temp-file "sly-stickers--fixture")) 11 (sly-flash-inhibit t) 12 ;; important HACK so this doesn't fail with the `sly-retro' 13 ;; contrib. 14 (sly-net-send-translator nil)) 15 (sly-eval-async '(cl:ignore-errors (cl:delete-package :slynk-stickers-fixture))) 16 (sly-sync-to-top-level 1) 17 (unwind-protect 18 (with-current-buffer 19 (find-file file) 20 (lisp-mode) 21 (insert (mapconcat #'pp-to-string 22 (append '((defpackage :slynk-stickers-fixture (:use :cl)) 23 (in-package :slynk-stickers-fixture)) 24 forms) 25 "\n")) 26 (write-file file) 27 (cl-loop for prefix in sticker-prefixes 28 do 29 (goto-char (point-max)) 30 (search-backward prefix) 31 (call-interactively 'sly-stickers-dwim)) 32 (funcall function) 33 (sly-sync-to-top-level 1)) 34 (if sly-stickers--test-debug 35 (sly-message "leaving file %s" file) 36 (let ((visitor (find-buffer-visiting file))) 37 (when visitor (kill-buffer visitor))) 38 (delete-file file)) 39 ))) 40 41 (cl-defmacro sly-stickers--with-fixture ((forms sticker-prefixes) &rest body) 42 (declare (indent defun) (debug (sexp &rest form))) 43 `(sly-stickers--call-with-fixture #'(lambda () ,@body) ,forms ,sticker-prefixes)) 44 45 (defun sly-stickers--topmost-sticker () 46 (car (sly-button--overlays-at (point)))) 47 48 (defun sly-stickers--base-face (sticker) 49 (let ((face (button-get sticker 'face))) 50 (if (atom face) 51 face 52 (plist-get face :inherit)))) 53 54 (defun sly-stickers--face-p (face) 55 (let* ((sticker (sly-stickers--topmost-sticker)) 56 (actual (sly-stickers--base-face sticker))) 57 (eq face actual))) 58 59 (define-sly-ert-test stickers-basic-navigation () 60 "Test that setting stickers and navigating to them works" 61 (sly-stickers--with-fixture ('((defun foo () (bar (baz))) 62 (defun quux () (coiso (cena)))) 63 '("(bar" "(baz" "(coiso")) 64 (goto-char (point-min)) 65 (ert-simulate-command '(sly-stickers-next-sticker 1)) 66 (save-excursion 67 (should (equal (read (current-buffer)) '(bar (baz))))) 68 (ert-simulate-command '(sly-stickers-next-sticker 1)) 69 (save-excursion 70 (should (equal (read (current-buffer)) '(baz)))) 71 (ert-simulate-command '(sly-stickers-next-sticker 1)) 72 (save-excursion 73 (should (equal (read (current-buffer)) '(coiso (cena))))) 74 (should (eq 'sly-stickers-placed-face 75 (sly-stickers--base-face (sly-stickers--topmost-sticker)))))) 76 77 (define-sly-ert-test stickers-should-stick () 78 "Test trying to compile the buffer and checking that stickers stuck" 79 (sly-stickers--with-fixture ('((defun foo () (bar (baz))) 80 (defun quux () (coiso (cena)))) 81 '("(bar" "(baz" "(coiso")) 82 (call-interactively 'sly-compile-defun) 83 (sly-sync-to-top-level 1) 84 (unless (sly-stickers--face-p 'sly-stickers-armed-face) 85 (ert-fail "Expected QUUX stickers to be armed")) 86 (ert-simulate-command '(sly-stickers-prev-sticker 1)) 87 (unless (sly-stickers--face-p 'sly-stickers-placed-face) 88 (ert-fail "Compiled just the QUUX defun, didn't expect FOO stickers to arm.")) 89 (call-interactively 'sly-compile-defun) 90 (sly-sync-to-top-level 1) 91 (unless (sly-stickers--face-p 'sly-stickers-armed-face) 92 (ert-fail "Expected innermost FOO sticker to be armed by now.")) 93 (ert-simulate-command '(sly-stickers-prev-sticker 1)) 94 (unless (sly-stickers--face-p 'sly-stickers-armed-face) 95 (ert-fail "Expected outermost FOO sticker to also be armed by now.")))) 96 97 (define-sly-ert-test stickers-when-invalid-dont-stick () 98 "Test trying to make invalid stickers stick" 99 (sly-stickers--with-fixture ('((defun foo () (bar (baz)))) 100 '("(bar" "(baz" "foo")) 101 (goto-char (point-min)) 102 (ert-simulate-command '(sly-stickers-next-sticker 1)) 103 (unless (sly-stickers--face-p 'sly-stickers-placed-face) 104 (ert-fail "Expected FOO sticker to be unarmed")) 105 (call-interactively 'sly-compile-defun) 106 (sly-sync-to-top-level 1) 107 (unless (sly-stickers--face-p 'sly-stickers-placed-face) 108 (ert-fail "Expected invalid FOO sticker to remain unarmed")) 109 (ert-simulate-command '(sly-stickers-next-sticker 1)) 110 (unless (sly-stickers--face-p 'sly-stickers-placed-face) 111 (ert-fail "Expected valid FOO sticker to remain unarmed")) 112 (ert-simulate-command '(sly-stickers-next-sticker 1)) 113 (unless (sly-stickers--face-p 'sly-stickers-placed-face) 114 (ert-fail "Expected valid FOO sticker to remain unarmed")))) 115 116 (define-sly-ert-test stickers-in-a-file 117 "Test compiling a file with some valid and invalid stickers." 118 (sly-stickers--with-fixture ('((defun foo () (bar (baz))) 119 (defun bar (x) (values (list x) 'bar)) 120 (defun baz () 42) 121 (defun xpto () (let ((coiso)) coiso))) 122 '("(bar" "(baz" "(coiso")) 123 124 (goto-char (point-min)) 125 (call-interactively 'sly-compile-and-load-file) 126 (sly-sync-to-top-level 1) 127 (ert-simulate-command '(sly-stickers-next-sticker 1)) 128 (unless (sly-stickers--face-p 'sly-stickers-armed-face) 129 (ert-fail "Expected BAR sticker to be armed")) 130 (ert-simulate-command '(sly-stickers-next-sticker 1)) 131 (unless (sly-stickers--face-p 'sly-stickers-armed-face) 132 (ert-fail "Expected BAZ sticker to be armed")) 133 (ert-simulate-command '(sly-stickers-next-sticker 1)) 134 (unless (sly-stickers--face-p 'sly-stickers-placed-face) 135 (ert-fail "Didn't expect COISO sticker to be armed")))) 136 137 (define-sly-ert-test stickers-record-stuff () 138 "Test actually checking stickers' values." 139 (sly-stickers--with-fixture ('((defun foo () (bar (baz))) 140 (defun bar (x) (values (list x) 'bar)) 141 (defun baz () 42)) 142 '("(bar" "(baz")) 143 144 (goto-char (point-min)) 145 (call-interactively 'sly-compile-and-load-file) 146 (sly-sync-to-top-level 1) 147 (ert-simulate-command '(sly-stickers-next-sticker 1)) 148 (unless (sly-stickers--face-p 'sly-stickers-armed-face) 149 (ert-fail "Expected BAR sticker to be armed by now")) 150 (sly-eval-async '(slynk-stickers-fixture::foo)) 151 (sly-sync-to-top-level 1) 152 (call-interactively 'sly-stickers-fetch) 153 (sly-sync-to-top-level 1) 154 (unless (sly-stickers--face-p 'sly-stickers-recordings-face) 155 (ert-fail "Expected BAR sticker to have some information")) 156 157 ;; This part still needs work 158 ;; 159 ;; (ert-simulate-command '(sly-stickers-next-sticker 1)) 160 ;; (ert-simulate-command '(sly-stickers-next-sticker 1)) 161 ;; (call-interactively 'sly-compile-defun) 162 ;; (sly-sync-to-top-level 1) 163 ;; (unless (sly-stickers--face-p 'sly-stickers-armed-face) 164 ;; (ert-fail "Expected QUUX sticker to be armed")) 165 ;; (sly-eval-async '(cl:ignore-errors (slynk-stickers-fixture::quux))) 166 ;; (call-interactively 'sly-stickers-fetch) 167 ;; (sly-sync-to-top-level 1) 168 ;; (unless (sly-stickers--face-p 'sly-stickers-exited-non-locally-face) 169 ;; (ert-fail "Expected QUXX sticker COISO to have exited non-locally")) 170 )) 171 172 (provide 'sly-stickers-tests)