Improve cstr typeset normalization

* test/lisp/emacs-lisp/comp-cstr-tests.el
(comp-cstr-typespec-tests-alist): Add four tests.

* lisp/emacs-lisp/comp-cstr.el (comp--sym-lessp)
(comp--direct-supertype, comp--normalize-typeset0): New functions.
(comp-normalize-typeset): Rework to make use of
'comp--normalize-typeset0'.
(comp--direct-subtypes): New function.

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 7e3ca1f3baea3848858f417963eaf38396a87cc0..57ae39520c551f0f4ec8c213aa725c38d6e6705c 100644 (file)
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -262,12 +262,57 @@ Return them as multiple value."
 \f
 ;;; Type handling.
 
+(defun comp--sym-lessp (x y)
+  "Like `string-lessp' but for strings."
+  (string-lessp (symbol-name x)
+                (symbol-name y)))
+
+(defun comp--direct-supertype (type)
+  "Return the direct supertype of TYPE."
+  (cl-loop
+   named outer
+   for i in (comp-cstr-ctxt-typeof-types comp-ctxt)
+   do (cl-loop for (j y) on i
+                   when (eq j type)
+                     do (cl-return-from outer y))))
+
+(defun comp--normalize-typeset0 (typeset)
+  ;; For every type search its supertype. If all the subtypes of that
+  ;; supertype are presents remove all of them, add the identified
+  ;; supertype and restart.
+  (when typeset
+    (while (eq 'restart
+               (cl-loop
+                named main
+                for i in typeset
+                for sup = (comp--direct-supertype i)
+                for subs = (comp--direct-subtypes sup)
+                when (and sup
+                          (length> subs 1)
+                          (cl-every (lambda (x) (member x typeset)) subs))
+                  do (cl-loop for s in subs
+                              do (setq typeset (cl-delete s typeset))
+                              finally (progn (push sup typeset)
+                                           (cl-return-from main 'restart))))))
+    typeset))
+
 (defun comp-normalize-typeset (typeset)
   "Sort TYPESET and return it."
-  (cl-sort (cl-remove-duplicates typeset)
-           (lambda (x y)
-             (string-lessp (symbol-name x)
-                           (symbol-name y)))))
+  (cl-sort (comp--normalize-typeset0 (cl-remove-duplicates typeset)) #'comp--sym-lessp))
+
+(defun comp--direct-subtypes (type)
+  "Return all the direct subtypes of TYPE."
+  ;; TODO memoize.
+  (cl-sort
+   (cl-loop for j in (comp-cstr-ctxt-typeof-types comp-ctxt)
+            for res = (cl-loop for i in j
+                               with last = nil
+                               when (eq i type)
+                                 return last
+                               do (setq last i))
+            when res
+              collect res)
+   #'comp--sym-lessp))
 
 (defun comp-supertypes (type)
   "Return a list of pairs (supertype . hierarchy-level) for TYPE."

diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el
index 78d9bb49b983224a7d214f52a7dfde52f0ad9672..a4f282fcfef68fc5223dbd120541d2df10332834 100644 (file)
--- a/test/lisp/emacs-lisp/comp-cstr-tests.el
+++ b/test/lisp/emacs-lisp/comp-cstr-tests.el
@@ -217,7 +217,16 @@
       ;; 87
       ((and (or null integer) (not (or null integer))) . nil)
       ;; 88
-      ((and (or (member a b c)) (not (or (member a b)))) . (member c)))
+      ((and (or (member a b c)) (not (or (member a b)))) . (member c))
+      ;; 89
+      ((or cons symbol) . list)
+      ;; 90
+      ((or string char-table bool-vector vector) . array)
+      ;; 91
+      ((or string char-table bool-vector vector number) . (or array number))
+      ;; 92
+      ((or string char-table bool-vector vector cons symbol number) .
+       (or number sequence)))
     "Alist type specifier -> expected type specifier."))
 
 (defmacro comp-cstr-synthesize-tests ()