feat(analysis): add annotations for let and eieio slots

Fuco1 · Fuco1 · commit 5349ff3c9a0e · 2023-03-17T12:22:59.000+01:00
diff --git a/elsa-analyser.el b/elsa-analyser.el
@@ -116,21 +116,25 @@ The BINDING should have one of the following forms:
 - place   ; initial is nil
 - (place) ; initial is nil
 - (place initial-value)"
-  (cond
-   ((or (listp binding)
-        (elsa-form-list-p binding))
-    (-let [(var source) (elsa-form-sequence binding)]
-      (when source
-        (elsa--analyse-form source scope state))
-      (when (elsa-form-symbol-p var)
-        (if (not source)
+  (let* ((annotation (oref binding annotation))
+         (annotation-type (and annotation
+                               (elsa--make-type (nth 2 annotation)))))
+    (cond
+     ((or (listp binding)
+          (elsa-form-list-p binding))
+      (-let [(var source) (elsa-form-sequence binding)]
+        (when source
+          (elsa--analyse-form source scope state))
+        (when (elsa-form-symbol-p var)
+          (if (not source)
+              (elsa-variable
+               :name (oref var name) :type (elsa-type-nil))
             (elsa-variable
-             :name (oref var name) :type (elsa-type-nil))
-          (elsa-variable
-           :name (oref var name) :type (oref source type))))))
-   ((elsa-form-symbol-p binding)
-    (elsa-variable :name (oref binding name) :type (elsa-make-type nil)))
-   (t nil)))
+             :name (oref var name) :type (or annotation-type
+                                             (oref source type)))))))
+     ((elsa-form-symbol-p binding)
+      (elsa-variable :name (oref binding name) :type (elsa-type-nil)))
+     (t nil))))
 
 (defun elsa--analyse:let (form scope state)
   (let* ((new-vars nil)
@@ -1153,13 +1157,6 @@ SCOPE and STATE are the scope and state objects."
 
 FORM is a result of `elsa-read-form'."
   (oset form reachable (elsa-state-get-reachability state))
-  (when-let ((annotation (oref form annotation)))
-    (cond
-     ((eq (car annotation) 'var)
-      (when-let ((var (elsa-scope-get-var scope (cadr annotation))))
-        ;; update the type in the current scope
-        (oset var type (eval `(elsa-make-type ,@(nthcdr 3 annotation))))))))
-
   (cond
    ((elsa-form-float-p form) (elsa--analyse-float form scope state))
    ((elsa-form-integer-p form) (elsa--analyse-integer form scope state))
diff --git a/elsa-extension-eieio.el b/elsa-extension-eieio.el
@@ -140,12 +140,16 @@
               (mapcar
                (lambda (slot)
                  (let* ((slot-name (elsa-get-name slot))
+                        (slot-annotation (oref slot annotation))
                         (type-form (map-elt (elsa-cdr slot) :type))
                         (type-lisp (elsa-form-to-lisp type-form))
-                        (elsa-type (or (and type-lisp
-                                            (or (elsa--cl-type-to-elsa-type type-lisp)
-                                                (elsa-type-mixed)))
-                                       (elsa-type-mixed)))
+                        (elsa-type (or
+                                    (and slot-annotation
+                                         (elsa--make-type (nth 2 slot-annotation)))
+                                    (and type-lisp
+                                         (or (elsa--cl-type-to-elsa-type type-lisp)
+                                             (elsa-type-mixed)))
+                                    (elsa-type-mixed)))
                         (accessor (map-elt (elsa-cdr slot) :accessor))
                         (initarg (map-elt (elsa-cdr slot) :initarg)))
 
diff --git a/elsa-form.el b/elsa-form.el
@@ -73,4 +73,34 @@ This only makes sense for the sequence forms:
 (cl-defgeneric elsa-form-sequence-p (_this)
   nil)
 
+(defun elsa-form-find-parent (form pred)
+  "Find first parent of FORM satisfying predicate PRED."
+  (declare (indent 1))
+  (let ((parent form))
+    (while (and parent (not (funcall pred parent)))
+      (setq parent (and (slot-boundp parent 'parent)
+                        (oref parent parent))))
+    parent))
+
+(defun elsa-form-find-child (form pred)
+  "Find first child of FORM satisfying predicate PRED."
+  (declare (indent 1))
+  (catch 'found
+    (elsa-form-visit form
+      (lambda (child)
+        (when (funcall pred child)
+          (throw 'found child))))))
+
+(defun elsa-locate-dominating-form (form name)
+  "Starting at FORM, look up parent forms for form with NAME.
+
+NAME can be a symbol or list of symbols, in which case matching
+any symbol from the list will stop the search."
+  (elsa-form-find-parent
+   form
+   (lambda (parent)
+     (if (listp name)
+         (memq (elsa-get-name parent) name)
+       (eq (elsa-get-name parent) name)))))
+
 (provide 'elsa-form)
diff --git a/elsa-reader.el b/elsa-reader.el
@@ -607,6 +607,15 @@ STATE is Elsa local state."
         (elsa-state-add-defvar state
           (elsa-defvar :name (elsa-get-name (cadr (oref reader-form sequence)))
                        :type (eval `(elsa-make-type ,@(cddr comment-form))))))
+       ;; slot annotation in defclass
+       ((and (elsa-locate-dominating-form reader-form 'defclass)
+             (elsa-form-function-call-p reader-form (car comment-form)))
+        (oset reader-form annotation comment-form))
+       ;; annotations for let bindings
+       ((and (elsa-locate-dominating-form
+              reader-form '(let let* when-let when-let* if-let if-let*))
+             (elsa-form-function-call-p reader-form (car comment-form)))
+        (oset reader-form annotation comment-form))
        ((eq annotation-name 'var)
         (oset reader-form annotation comment-form))
        (t
@@ -681,37 +690,42 @@ for the analysis."
           ((functionp form) (elsa--read-function form state))
           (t (error "Invalid form")))))
     (elsa--set-line-and-column reader-form)
-    ;; check if there is a comment atached to this form
-    ;; TODO: this is really inefficient because it checks the same
-    ;; line multiple times.  We should only do this parsing for the
-    ;; first form on a line.
-    (save-excursion
-      (goto-char (oref reader-form start))
-      (forward-line -1)
-      (skip-chars-forward " \t\n\r")
-      (let ((line-end (line-end-position)))
-        (when (and (re-search-forward
-                    (rx "(" (+ (+? (or (syntax word) (syntax symbol))) (+ space)) ":: ")
-                    line-end t)
-                   (nth 4 (syntax-ppss)))
-          ;; we are inside a comment and inside a form starting with
-          ;; (elsa
-          (search-backward "(")
-          (let ((comment-form (read (current-buffer))))
-            ;; we must end on the same line, that way we can be sure
-            ;; the entire read form was inside a comment.
-            (when (<= (point) line-end)
-              ;; handle defun type declaration
-              (elsa--process-annotation reader-form comment-form state))))))
     reader-form))
 
 (defun elsa-read-form (state)
   "Read form at point."
   (while (forward-comment 1))
   (unless (eobp)
     (let* ((form (save-excursion
-                   (read (current-buffer)))))
-      (while (forward-comment 1))
-      (elsa--read-form form state))))
+                   (read (current-buffer))))
+           (elsa-form (progn
+                        (while (forward-comment 1))
+                        (elsa--read-form form state))))
+
+
+      ;; Process annotations attached to subforms in this top-level
+      ;; form.  We have to do it here after the entire form is read to
+      ;; be able to make use of parent/previous relations.
+      (elsa-form-visit elsa-form
+        (lambda (ef)
+          (save-excursion
+            (goto-char (oref ef start))
+            (forward-line -1)
+            (skip-chars-forward " \t\n\r")
+            (let ((line-end (line-end-position)))
+              (when (and (re-search-forward
+                          (rx "(" (+ (+? (or (syntax word) (syntax symbol))) (+ space)) ":: ")
+                          line-end t)
+                         (nth 4 (syntax-ppss)))
+                ;; we are inside a comment and inside a form starting with
+                ;; (elsa
+                (search-backward "(")
+                (let ((comment-form (read (current-buffer))))
+                  ;; we must end on the same line, that way we can be sure
+                  ;; the entire read form was inside a comment.
+                  (when (<= (point) line-end)
+                    ;; handle defun type declaration
+                    (elsa--process-annotation ef comment-form state))))))))
+      elsa-form)))
 
 (provide 'elsa-reader)
diff --git a/tests/test-analysis-form-let.el b/tests/test-analysis-form-let.el
@@ -0,0 +1,35 @@
+;; -*- lexical-binding: t -*-
+(require 'buttercup)
+
+(require 'elsa-test-helpers)
+(require 'elsa-analyser)
+
+(describe "Form analysis"
+
+  (describe "let"
+
+    (xdescribe "return type analysis")
+
+    (describe "introducing variables to scope"
+
+      (it "should update local scope with let-bound variables"
+        (let ((state (elsa-state)))
+          (spy-on 'elsa-scope-add-var :and-call-through)
+          (elsa-test-with-analysed-form "(let ((slot 1)))" form
+            :state state
+            (expect 'elsa-scope-add-var
+                    :to-have-been-called-with
+                    (spy-arg-matcher #'elsa-scope-p)
+                    (spy-arg-matcher
+                     (lambda (x)
+                       (and (elsa-variable-p x)
+                            (eq (oref x name) 'slot)
+                            (elsa-type-accept (elsa-type-int) (oref x type))))))))))
+
+    (describe "annotations"
+
+      (it "should set type of binding to type from annotation"
+        (elsa-test-with-analysed-form ";; (slot :: number)\n(let ((slot (mixed))) slot)"
+            form
+          (expect (elsa-nth 2 form)
+                  :to-accept-type (elsa-type-number)))))))
diff --git a/tests/test-elsa-extension-eieio.el b/tests/test-elsa-extension-eieio.el
@@ -108,4 +108,30 @@
         (it "should signal error if the slot type does not accept value"
           (elsa-test-with-analysed-form "|(progn (defclass a () ((name :type string))) (oset (a) name 2))" form
             :errors-var errors
-            (expect (car errors) :message-to-match "Property `name' can not accept type `(const 2)', has type `string'")))))))
+            (expect (car errors) :message-to-match "Property `name' can not accept type `(const 2)', has type `string'")))))
+
+    (describe "annotations"
+
+      (it "can annotate first slot if aligned with the surrounding list"
+        (elsa-test-with-analysed-form "(defclass foo ()\n ;; (slot :: number)\n ((slot)))" form
+          :state-var state
+          (expect (elsa-get-type (elsa-get-slot (elsa-state-get-defclass state 'foo) 'slot))
+                  :to-accept-type (elsa-type-number))))
+
+      (it "can annotate first slot if annotated under the surrounding list"
+        (elsa-test-with-analysed-form "(defclass foo ()\n (\n  ;; (slot :: number)\n  (slot)))" form
+          :state-var state
+          (expect (elsa-get-type (elsa-get-slot (elsa-state-get-defclass state 'foo) 'slot))
+                  :to-accept-type (elsa-type-number))))
+
+      (it "can annotate second slot"
+        (elsa-test-with-analysed-form "(defclass foo ()\n ((slot)\n  ;; (slot2 :: number)\n  (slot2)))" form
+          :state-var state
+          (expect (elsa-get-type (elsa-get-slot (elsa-state-get-defclass state 'foo) 'slot2))
+                  :to-accept-type (elsa-type-number))))
+
+      (it "overrides native slot type if provided"
+        (elsa-test-with-analysed-form "(defclass foo ()\n ;; (slot :: number)\n ((slot :type string)))" form
+          :state-var state
+          (expect (elsa-get-type (elsa-get-slot (elsa-state-get-defclass state 'foo) 'slot))
+                  :to-accept-type (elsa-type-number)))))))
