sly-autodoc-tests.el (8066B)
1 ;; -*- lexical-binding: t; -*- 2 (require 'sly-autodoc) 3 (require 'sly-tests "lib/sly-tests") 4 (require 'cl-lib) 5 6 (defun sly-autodoc-to-string () 7 "Retrieve and return autodoc for form at point." 8 (let ((autodoc (car (sly-eval 9 `(slynk:autodoc 10 ',(sly-autodoc--parse-context) 11 :print-right-margin 12 ,(window-width (minibuffer-window))))))) 13 (if (eq autodoc :not-available) 14 :not-available 15 (sly-autodoc--canonicalize-whitespace autodoc)))) 16 17 (defun sly-check-autodoc-at-point (arglist) 18 (sly-test-expect (format "Autodoc in `%s' (at %d) is as expected" 19 (buffer-string) (point)) 20 arglist 21 (sly-autodoc-to-string))) 22 23 (defmacro define-autodoc-tests (&rest specs) 24 `(progn 25 ,@(cl-loop 26 for (buffer-sexpr wished-arglist . options) 27 in specs 28 for fails-for = (plist-get options :fails-for) 29 for skip-trailing-test-p = (plist-get options :skip-trailing-test-p) 30 for i from 1 31 when (featurep 'ert) 32 collect `(define-sly-ert-test ,(intern (format "autodoc-tests-%d" i)) 33 () 34 ,(format "Check autodoc works ok for %s" buffer-sexpr) 35 ,@(if fails-for 36 `(:expected-result 37 '(satisfies 38 (lambda (result) 39 (ert-test-result-type-p 40 result 41 (if (member (sly-lisp-implementation-name) 42 ',fails-for) 43 :failed 44 :passed)))))) 45 (sly-sync-to-top-level 0.3) 46 (sly-check-top-level) 47 (with-temp-buffer 48 (setq sly-buffer-package "COMMON-LISP-USER") 49 (lisp-mode) 50 (insert ,buffer-sexpr) 51 (search-backward "*HERE*") 52 (delete-region (match-beginning 0) (match-end 0)) 53 (should (equal ,wished-arglist 54 (sly-autodoc-to-string))) 55 (unless ,skip-trailing-test-p 56 (insert ")") (backward-char) 57 (should (equal ,wished-arglist 58 (sly-autodoc-to-string))))) 59 (sly-sync-to-top-level 0.3))))) 60 61 (define-autodoc-tests 62 ;; Test basics 63 ("(slynk::emacs-connected*HERE*" "(emacs-connected)") 64 ("(slynk::emacs-connected *HERE*" "(emacs-connected)") 65 ("(slynk::create-socket*HERE*" 66 "(create-socket host port &key backlog)") 67 ("(slynk::create-socket *HERE*" 68 "(create-socket ===> host <=== port &key backlog)") 69 ("(slynk::create-socket foo *HERE*" 70 "(create-socket host ===> port <=== &key backlog)") 71 72 ;; Test that autodoc differentiates between exported and 73 ;; unexported symbols. 74 ("(slynk:create-socket*HERE*" :not-available) 75 76 ;; Test if cursor is on non-existing required parameter 77 ("(slynk::create-socket foo bar *HERE*" 78 "(create-socket host port &key backlog)") 79 80 ;; Test cursor in front of opening parenthesis 81 ("(slynk::with-struct *HERE*(foo. x y) *struct* body1)" 82 "(with-struct (conc-name &rest names) obj &body body)" 83 :skip-trailing-test-p t) 84 85 ;; Test variable content display 86 ("(progn slynk::default-server-port*HERE*" 87 "DEFAULT-SERVER-PORT => 4005") 88 89 ;; Test that "variable content display" is not triggered for 90 ;; trivial constants. 91 ("(slynk::create-socket t*HERE*" 92 "(create-socket ===> host <=== port &key backlog)") 93 ("(slynk::create-socket :foo*HERE*" 94 "(create-socket ===> host <=== port &key backlog)") 95 96 ;; Test with syntactic sugar 97 ("#'(lambda () (slynk::create-socket*HERE*" 98 "(create-socket host port &key backlog)") 99 ("`(lambda () ,(slynk::create-socket*HERE*" 100 "(create-socket host port &key backlog)") 101 ("(remove-if #'(lambda () (slynk::create-socket*HERE*" 102 "(create-socket host port &key backlog)") 103 ("`(remove-if #'(lambda () ,@(slynk::create-socket*HERE*" 104 "(create-socket host port &key backlog)") 105 106 ;; Test &optional 107 ("(slynk::symbol-status foo *HERE*" 108 "(symbol-status symbol &optional\ 109 ===> (package (symbol-package symbol)) <===)" :fails-for ("allegro" "ccl")) 110 111 ;; Test context-sensitive autodoc (DEFMETHOD) 112 ("(defmethod slynk::arglist-dispatch (*HERE*" 113 "(defmethod arglist-dispatch\ 114 (===> operator <=== arguments) &body body)") 115 ("(defmethod slynk::arglist-dispatch :before (*HERE*" 116 "(defmethod arglist-dispatch :before\ 117 (===> operator <=== arguments) &body body)") 118 119 ;; Test context-sensitive autodoc (APPLY) 120 ("(apply 'slynk::eval-for-emacs*HERE*" 121 "(apply 'eval-for-emacs &optional form buffer-package id &rest args)") 122 ("(apply #'slynk::eval-for-emacs*HERE*" 123 "(apply #'eval-for-emacs &optional form buffer-package id &rest args)" :fails-for ("ccl")) 124 ("(apply 'slynk::eval-for-emacs foo *HERE*" 125 "(apply 'eval-for-emacs &optional form\ 126 ===> buffer-package <=== id &rest args)") 127 ("(apply #'slynk::eval-for-emacs foo *HERE*" 128 "(apply #'eval-for-emacs &optional form\ 129 ===> buffer-package <=== id &rest args)" :fails-for ("ccl")) 130 131 ;; Test context-sensitive autodoc (ERROR, CERROR) 132 ("(error 'simple-condition*HERE*" 133 "(error 'simple-condition &rest arguments\ 134 &key format-arguments format-control)" :fails-for ("ccl")) 135 ("(cerror \"Foo\" 'simple-condition*HERE*" 136 "(cerror \"Foo\" 'simple-condition\ 137 &rest arguments &key format-arguments format-control)" 138 :fails-for ("ccl")) 139 140 ;; Test &KEY and nested arglists 141 ("(slynk::with-retry-restart (:msg *HERE*" 142 "(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)" 143 :fails-for ("allegro")) 144 ("(slynk::with-retry-restart (:msg *HERE*(foo" 145 "(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)" 146 :skip-trailing-test-p t 147 :fails-for ("allegro")) 148 ("(slynk::start-server \"/tmp/foo\" :dont-close *HERE*" 149 "(start-server port-file &key (style slynk:*communication-style*)\ 150 ===> (dont-close slynk:*dont-close*) <===)" 151 :fails-for ("allegro" "ccl")) 152 153 ;; Test declarations and type specifiers 154 ("(declare (string *HERE*" 155 "(declare (string &rest ===> variables <===))" 156 :fails-for ("allegro") :fails-for ("ccl")) 157 ("(declare ((string *HERE*" 158 "(declare ((string &optional ===> size <===) &rest variables))") 159 ("(declare (type (string *HERE*" 160 "(declare (type (string &optional ===> size <===) &rest variables))") 161 162 ;; Test local functions 163 ("(flet ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)") 164 ("(macrolet ((foo (x y) `(+ ,x ,y))) (foo *HERE*" "(foo ===> x <=== y)") 165 ("(labels ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)") 166 ("(labels ((foo (x y) (+ x y)) 167 (bar (y) (foo *HERE*" 168 "(foo ===> x <=== y)" :fails-for ("cmucl" "sbcl" "allegro" "ccl"))) 169 170 (def-sly-test autodoc-space 171 (input-keys expected-message) 172 "Emulate the inserting something followed by the space key 173 event and verify that the right thing appears in the echo 174 area (after a short delay)." 175 '(("( s l y n k : : o p e r a t o r - a r g l i s t SPC" 176 "(operator-arglist name package)")) 177 (when noninteractive 178 (sly-skip-test "Can't use unread-command-events in batch mode")) 179 (let* ((keys (eval `(kbd ,input-keys))) 180 (tag (cons nil nil)) 181 (timerfun (lambda (tag) (throw tag nil))) 182 (timer (run-with-timer 1 nil timerfun tag))) 183 (with-temp-buffer 184 (lisp-mode) 185 (unwind-protect 186 (catch tag 187 (message nil) 188 (select-window (display-buffer (current-buffer) t)) 189 (setq unread-command-events (listify-key-sequence keys)) 190 (accept-process-output) 191 (recursive-edit)) 192 (setq unread-command-events nil) 193 (cancel-timer timer)) 194 (sly-test-expect "Message after SPC" 195 expected-message (current-message)) 196 (accept-process-output nil (* eldoc-idle-delay 2)) 197 (sly-test-expect "Message after edloc delay" 198 expected-message (current-message))))) 199 200 (provide 'sly-autodoc-tests)