From 3e193edd68b1abd9483267ba09c6e5c0c59e6c23 Mon Sep 17 00:00:00 2001
From: Andrea Corallo <acorallo@gnu.org>
Date: Wed, 18 Oct 2023 16:14:45 +0200
Subject: [PATCH] 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.
---
 lisp/emacs-lisp/comp-cstr.el            | 53 +++++++++++++++++++++++--
 test/lisp/emacs-lisp/comp-cstr-tests.el | 11 ++++-
 2 files changed, 59 insertions(+), 5 deletions(-)

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 7e3ca1f3bae..57ae39520c5 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -262,12 +262,57 @@ Return them as multiple value."
 
 ;;; 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 78d9bb49b98..a4f282fcfef 100644
--- 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 ()
-- 
2.39.5