master 3e193edd68b 1/2: Improve cstr typeset normalization

[Andrea Corallo]

branch: master
commit 3e193edd68b1abd9483267ba09c6e5c0c59e6c23
Author: Andrea Corallo <acorallo@gnu.org>
Commit: Andrea Corallo <acorallo@gnu.org>

    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 ()