lem-project · cxxxr · Aug 16, 2023 · Aug 14, 2023 · Aug 15, 2023 · Aug 15, 2023
diff --git a/extensions/lisp-mode/detective.lisp b/extensions/lisp-mode/detective.lisp
@@ -33,10 +33,8 @@
 (defmethod capture-reference ((position lem:point) (class (eql :misc-reference)))
   (let* ((line (str:split #\Space (line-string position)))
          (type (str:replace-all "(" "" (first line)))
-         (name (second line)))
+         (name (remove #\) (second line))))
     (make-instance 'lem/detective:misc-reference
                    :misc-custom-type type
                    :reference-name name
                    :reference-point position)))
-
-
diff --git a/extensions/lisp-mode/eval.lisp b/extensions/lisp-mode/eval.lisp
@@ -40,17 +40,21 @@
   (let ((id (overlay-eval-id overlay)))
     (lisp-eval-async `(micros/pretty-eval:remove-evaluated-values ,id))
     (delete-overlay overlay)
-    (delete-overlay (overlay-get overlay 'relation-overlay))
+    (when (overlay-get overlay 'relation-overlay)
+      (delete-overlay (overlay-get overlay 'relation-overlay)))
     (alexandria:removef (buffer-eval-result-overlays (overlay-buffer overlay))
                         overlay)))
 
 (defun find-overlays (start end &key including-after-point)
   (let ((buffer (point-buffer start)))
     (loop :for ov :in (buffer-eval-result-overlays buffer)
-          :unless (or (point<= end (overlay-start ov))
-                      (if including-after-point
-                          (point< (overlay-end ov) start)
-                          (point<= (overlay-end ov) start)))
+          :unless (if (point= (overlay-start ov)
+                              (overlay-end ov))
+                      (not (point<= start (overlay-start ov) end))
+                      (or (point<= end (overlay-start ov))
+                          (if including-after-point
+                              (point< (overlay-end ov) start)
+                              (point<= (overlay-end ov) start))))
           :collect ov)))
 
 (defun find-overlay (point)
@@ -82,21 +86,31 @@
                       (+ v 5))
         (format nil "#~X~X~X" r g b)))))
 
-(defun display-evaluated-message (start end message &optional is-error id)
+(defun display-evaluated-message
+    (start
+     end
+     message
+     &key is-error
+          id
+          attribute
+          (background-attribute
+           (make-attribute :background (compute-evaluated-background-color))))
   (let ((popup-overlay
           (make-overlay start
                         end
-                        (if is-error
-                            'eval-error-attribute
-                            'eval-value-attribute)
+                        (or attribute
+                            (if is-error
+                                'eval-error-attribute
+                                'eval-value-attribute))
                         :start-point-kind :left-inserting
                         :end-point-kind :right-inserting))
         (background-overlay
-          (make-overlay start
-                        end
-                        (make-attribute :background (compute-evaluated-background-color))
-                        :start-point-kind :left-inserting
-                        :end-point-kind :right-inserting))
+          (when background-attribute
+            (make-overlay start
+                          end
+                          background-attribute
+                          :start-point-kind :left-inserting
+                          :end-point-kind :right-inserting)))
         (buffer (point-buffer start)))
     (overlay-put popup-overlay 'relation-overlay background-overlay)
     (overlay-put popup-overlay :display-line-end t)
@@ -107,13 +121,16 @@
     (add-hook (variable-value 'before-change-functions :buffer buffer)
               'remove-touch-overlay)))
 
-(defun redisplay-evaluated-message (start end value)
+(defun redisplay-evaluated-message (start end value
+                                    &rest args
+                                    &key is-error attribute background-attribute)
+  (declare (ignore is-error attribute background-attribute))
   (remove-eval-result-overlay-between start end)
-  (display-evaluated-message start end value))
+  (apply #'display-evaluated-message start end value args))
 
 (defun display-spinner-message (spinner &optional message is-error id)
   (lem/loading-spinner:with-line-spinner-points (start end spinner)
-    (display-evaluated-message start end message is-error id)))
+    (display-evaluated-message start end message :is-error is-error :id id)))
 
 (defun spinner-eval-request-id (spinner)
   (lem/loading-spinner:spinner-value spinner 'eval-id))
@@ -134,7 +151,7 @@
         (alexandria:destructuring-ecase value
           ((:ok result)
            (destructuring-bind (&key value id) result
-               (lem/loading-spinner:stop-loading-spinner spinner)
+             (lem/loading-spinner:stop-loading-spinner spinner)
              (display-spinner-message spinner value nil id)))
           ((:abort condition)
            (lem/loading-spinner:stop-loading-spinner spinner)

diff --git a/extensions/lisp-mode/internal-package.lisp b/extensions/lisp-mode/internal-package.lisp
@@ -92,6 +92,7 @@
    :lisp-switch-to-repl-buffer
    :write-string-to-repl
    :copy-down-to-repl
+   :send-string-to-listener
    ;; apropos-mode.lisp
    :apropos-headline-attribute
    :*lisp-apropos-mode-keymap*

diff --git a/extensions/lisp-mode/lem-lisp-mode.asd b/extensions/lisp-mode/lem-lisp-mode.asd
@@ -42,6 +42,7 @@
                (:file "trace")
                (:file "class-browser")
                (:file "macroexpand")
+               (:file "test-runner")
                (:file "package")))
 
 (defsystem "lem-lisp-mode/v2"

diff --git a/extensions/lisp-mode/misc-commands.lisp b/extensions/lisp-mode/misc-commands.lisp
@@ -2,14 +2,6 @@
   (:use :cl :lem :lem-lisp-mode/internal))
 (in-package :lem-lisp-mode/misc-commands)
 
-(defun find-symbol-matchies (symbol-name)
-  (let ((symbols '()))
-    (do-all-symbols (s)
-      (when (and (string-equal s symbol-name) (fboundp s))
-        (pushnew s symbols)))
-    symbols))
-
-
 (defun find-utopian-route (point)
   (when (in-string-p point)
     (with-point ((start point)
@@ -102,8 +94,8 @@
          (reference (lem/detective::current-reference)))
     ;;TODO: Make a regex for the test posiblities
     (if (and (typep reference 'lem/detective:misc-reference)
-          (string-equal (lem/detective:misc-custom-type reference)
-                        "deftest"))
+             (string-equal (lem/detective:misc-custom-type reference)
+                           "deftest"))
         (%send-test-reference package reference)
         (message "Current reference is not a test."))))
 

diff --git a/extensions/lisp-mode/repl.lisp b/extensions/lisp-mode/repl.lisp
@@ -262,6 +262,12 @@
                                          string
                                          (string #\newline))))))
 
+(defun send-string-to-listener (string)
+  (lisp-switch-to-repl-buffer)
+  (buffer-end (current-point))
+  (insert-string (current-point) string)
+  (lem/listener-mode:listener-return))
+
 (define-command start-lisp-repl (&optional (use-this-window nil)) ("P")
   (check-connection)
   (flet ((switch (buffer split-window-p)

diff --git a/extensions/lisp-mode/test-runner.lisp b/extensions/lisp-mode/test-runner.lisp
@@ -0,0 +1,97 @@
+(defpackage :lem-lisp-mode/test-runner
+  (:use :cl
+        :lem
+        :lem-lisp-mode/internal))
+(in-package :lem-lisp-mode/test-runner)
+
+(define-attribute success-test-attribute
+  (t :foreground "green"))
+
+(define-attribute failure-test-attribute
+  (t :foreground "red"))
+
+(defstruct definition
+  package-name
+  name
+  point)
+
+(defun deftest-reference-p (reference)
+  ;;TODO: Make a regex for the test posiblities
+  (and (typep reference 'lem/detective:misc-reference)
+       (string-equal (lem/detective:misc-custom-type reference)
+                     "deftest")))
+
+(defun get-package-from-current-reference (buffer)
+  (buffer-package buffer))
+
+(defun make-definition-from-reference (reference buffer)
+  (make-definition :package-name (get-package-from-current-reference buffer)
+                   :name (lem/detective:reference-name reference)
+                   :point (lem/detective:reference-point reference)))
+
+(defun get-test-definition-at (point)
+  (lem/detective::check-change :force t)
+  (let ((reference (lem/detective::current-reference :point point)))
+    (when (deftest-reference-p reference)
+      (make-definition-from-reference reference (point-buffer point)))))
+
+(defun get-buffer-test-definitions (buffer)
+  (lem/detective::check-change :force t)
+  (loop :for reference :in (gethash "misc" (lem/detective:buffer-references buffer))
+        :when (deftest-reference-p reference)
+        :collect (make-definition-from-reference reference buffer)))
+
+(defun result-text (successp)
+  (if successp "Success" "Failure"))
+
+(defun display-test-result (definition &key successp (text (result-text successp)))
+  (with-point ((start (definition-point definition))
+               (end (definition-point definition)))
+    (line-start start)
+    (line-end end)
+    (lem-lisp-mode/eval:redisplay-evaluated-message
+     start
+     end
+     text
+     :attribute (if successp
+                    'success-test-attribute
+                    'failure-test-attribute))))
+
+(defun start-running-spinner (definition)
+  (with-point ((point (definition-point definition)))
+    (lem/loading-spinner:start-loading-spinner :line
+                                               :point point
+                                               :loading-message "Testing")))
+
+(defun run-test (definitions)
+  (destructuring-bind (definition &rest rest-definitions)
+      (uiop:ensure-list definitions)
+    (let ((spinner (start-running-spinner definition)))
+      (with-remote-eval (`(micros/test-runner:run-test
+                           ,(definition-name definition)
+                           ,(definition-package-name definition)))
+        (lambda (value)
+          (alexandria:destructuring-ecase value
+            ((:ok successp)
+             (display-test-result definition :successp successp))
+            ((:abort value)
+             (show-message value)
+             (display-test-result definition :successp nil :text value)))
+          (lem/loading-spinner:stop-loading-spinner spinner)
+          (when rest-definitions
+            (run-test rest-definitions)))))))
+
+(define-command lisp-test-runner-run-current () ()
+  (let ((test-definition (get-test-definition-at (current-point))))
+    (unless test-definition
+      (editor-error "Current reference is not a test."))
+    (run-test test-definition)))
+
+(define-command lisp-test-runner-run-buffer () ()
+  (let ((test-definitions (get-buffer-test-definitions (current-buffer))))
+    (unless test-definitions
+      (editor-error "No test found in this buffer."))
+    (run-test test-definitions)))
+
+;; TODO:
+;; - interrupt tests
diff --git a/submodules/micros b/submodules/micros
+7 −0		contrib/micros-test-runner.lisp
+1 −0		micros.asd
+2 −1		micros.lisp