From b06916cb218b133a4ebc9d7fa87b370fc2c2ed02 Mon Sep 17 00:00:00 2001
From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Mon, 4 Mar 2024 13:24:34 -0500
Subject: syncdoc-type-hierarchy.el: Adjust to changes in `cl-preloaded.el`

* admin/syncdoc-type-hierarchy.el (syncdoc-lispref-dir):
Use `macroexp-file-name`.
(syncdoc-hierarchy): New var.
(syncdoc-insert-dot-content, syncdoc-make-type-table): Use it.
(syncdoc-update-type-hierarchy): Don't crash if `dot` is absent.
---
 admin/syncdoc-type-hierarchy.el | 83 ++++++++++++++++++++++++++++++-----------
 1 file changed, 61 insertions(+), 22 deletions(-)

(limited to 'admin')

diff --git a/admin/syncdoc-type-hierarchy.el b/admin/syncdoc-type-hierarchy.el
index b3dfe63406a..cb4df63a312 100644
--- a/admin/syncdoc-type-hierarchy.el
+++ b/admin/syncdoc-type-hierarchy.el
@@ -24,8 +24,8 @@
 
 ;; This file is used to keep the type hierarchy representation present
 ;; in the elisp manual in sync with the current type hierarchy.  This
-;; is specified in `cl--type-hierarchy' in cl-preloaded.el, so each
-;; time `cl--type-hierarchy' is modified
+;; is specified in `cl--direct-supertypes-of-type' in cl-preloaded.el, so each
+;; time `cl--direct-supertypes-of-type' is modified
 ;; `syncdoc-update-type-hierarchy' must be run before the
 ;; documentation is regenerated.
 
@@ -37,17 +37,49 @@
 (require 'cl-lib)
 (require 'org-table)
 
-(defconst syncdoc-lispref-dir (concat (file-name-directory
-                                       (or load-file-name
-                                           buffer-file-name))
-                                      "../doc/lispref/"))
+(defconst syncdoc-lispref-dir
+  (expand-file-name "../doc/lispref/"
+                    (file-name-directory
+                     (or (macroexp-file-name)
+                         buffer-file-name))))
+
+(defconst syncdoc-hierarchy
+  (let ((ht (copy-hash-table cl--direct-supertypes-of-type)))
+    ;; Include info about "representative" other structure types,
+    ;; to illustrate how they fit.
+    (mapc #'require '(kmacro eieio-base elisp-mode frameset transient))
+    (let ((extra-types '(advice kmacro cl-structure-object cl-structure-class
+                         eieio-default-superclass eieio-named transient-infix
+                         xref-elisp-location frameset-register))
+          (seen ()))
+      (while extra-types
+        (let* ((type (pop extra-types))
+               (class (get type 'cl--class))
+               (parents (cl--class-parents class)))
+          (unless (member type seen)
+            (push type seen)
+            (push (type-of class) extra-types)
+            (puthash type (cond
+                           (parents
+                            (let ((ps (mapcar #'cl--class-name parents)))
+                              (setq extra-types (append ps extra-types))
+                              ps))
+                           ;; EIEIO's parents don't mention the default.
+                           ((and (eq (type-of class) 'eieio--class)
+                                 (not (eq type 'eieio-default-superclass)))
+                            '(eieio-default-superclass))
+                           ;; OClosures can still be lists :-(
+                           ((eq 'oclosure type) '(t))
+                           (t '(atom)))
+                     ht)))))
+    ht))
 
 (defun syncdoc-insert-dot-content (rankdir)
   (maphash (lambda (child parents)
               (cl-loop for parent in parents
                        do (insert " \"" (symbol-name child) "\" -> \""
                                   (symbol-name parent) "\";\n")))
-           cl--direct-supertypes-of-type)
+           syncdoc-hierarchy)
   (sort-lines nil (point-min) (point-max))
 
   (goto-char (point-min))
@@ -58,18 +90,24 @@
 (defun syncdoc-make-type-table (file)
   (with-temp-file file
     (insert "|Type| Derived Types|\n|-\n")
-    (cl-loop for (type . children) in cl--type-hierarchy
-             do (insert "|" (symbol-name type) " |")
-             do (cl-loop with x = 0
-                         for child in children
-                         for child-len = (length (symbol-name child))
-                         when (> (+ x child-len 2) 60)
-                         do (progn
-                              (insert "|\n||")
-                              (setq x 0))
-                         do (insert (symbol-name child) " ")
-                         do (cl-incf x (1+ child-len)) )
-             do (insert "\n"))
+    (let ((subtypes ()))
+      ;; First collect info from the "builtin" types.
+      (maphash (lambda (type parents)
+                 (dolist (parent parents)
+                   (push type (alist-get parent subtypes))))
+               syncdoc-hierarchy)
+      (cl-loop for (type . children) in (reverse subtypes)
+               do (insert "|" (symbol-name type) " |")
+               do (cl-loop with x = 0
+                           for child in (reverse children)
+                           for child-len = (length (symbol-name child))
+                           when (> (+ x child-len 2) 60)
+                           do (progn
+                                (insert "|\n||")
+                                (setq x 0))
+                           do (insert (symbol-name child) " ")
+                           do (cl-incf x (1+ child-len)) )
+               do (insert "\n")))
     (org-table-align)))
 
 (defun syncdoc-update-type-hierarchy ()
@@ -77,9 +115,10 @@
   (interactive)
   (with-temp-buffer
     (syncdoc-insert-dot-content "LR")
-    (call-process-region nil nil "dot" t (current-buffer) nil "-Tjpg" "-o"
-                         (expand-file-name "type_hierarchy.jpg"
-                                           syncdoc-lispref-dir)))
+    (with-demoted-errors "%S"           ;In case "dot" is not found!
+      (call-process-region nil nil "dot" t (current-buffer) nil "-Tjpg" "-o"
+                           (expand-file-name "type_hierarchy.jpg"
+                                             syncdoc-lispref-dir))))
   (syncdoc-make-type-table (expand-file-name "type_hierarchy.txt"
                                              syncdoc-lispref-dir)))
 
-- 
cgit v1.2.3