admin/syncdoc-type-hierarchy.el

   1 ;;;  syncdoc-type-hierarchy.el--- -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
   4
   5 ;; Author: Andrea Corallo <acorallo@gnu.org>
   6 ;; Keywords: documentation
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This file is used to keep the type hierarchy representation present
  26 ;; in the elisp manual in sync with the current type hierarchy.  This
  27 ;; is specified in `cl--direct-supertypes-of-type' in cl-preloaded.el, so each
  28 ;; time `cl--direct-supertypes-of-type' is modified
  29 ;; `syncdoc-update-type-hierarchy' must be run before the
  30 ;; documentation is regenerated.
  31
  32 ;; We do not call this directly from make docs in order not to add a
  33 ;; dependency on the tool "dot".
  34
  35 ;;; Code:
  36
  37 (require 'cl-lib)
  38 (require 'org)
  39
  40 (defconst syncdoc-file (or (macroexp-file-name) buffer-file-name))
  41
  42 (defconst syncdoc-emacs-repo-dir
  43   (expand-file-name "../" (file-name-directory syncdoc-file)))
  44
  45 (defconst syncdoc-lispref-dir
  46   (expand-file-name "doc/lispref/" syncdoc-emacs-repo-dir))
  47
  48 (defconst syncdoc-all-types
  49   (let (res)
  50     (mapatoms (lambda (type)
  51                 (when (cl-find-class type)
  52                   (push type res)))
  53               obarray)
  54     (nreverse
  55      (merge-ordered-lists
  56       (sort
  57        (mapcar (lambda (type) (cl--class-allparents (cl-find-class type)))
  58                res)
  59        (lambda (ts1 ts2) (> (length ts1) (length ts2)))))))
  60   "List of all types.")
  61
  62 (defconst syncdoc-hierarchy
  63   (progn
  64     ;; Require it here so we don't load it before `syncdoc-all-types' is
  65     ;; computed.
  66     (cl-loop
  67      with h = (make-hash-table :test #'eq)
  68      for type in syncdoc-all-types
  69      do (puthash type (mapcar #'cl--class-name
  70                        (cl--class-parents (cl-find-class type)))
  71          h)
  72      finally return h)))
  73
  74 (defun syncdoc-insert-dot-content (rankdir)
  75   (maphash (lambda (child parents)
  76               (cl-loop for parent in parents
  77                        do (insert " \"" (symbol-name child) "\" -> \""
  78                                   (symbol-name parent) "\";\n")))
  79            syncdoc-hierarchy)
  80   (sort-lines nil (point-min) (point-max))
  81
  82   (goto-char (point-min))
  83   (insert "digraph {\n rankdir=\"" rankdir "\";\n")
  84   (goto-char (point-max))
  85   (insert "}\n"))
  86
  87 (defun syncdoc-make-type-table (file)
  88   (with-temp-file file
  89     (insert "|Type| Derived Types|\n|-\n")
  90     (let ((subtypes ()))
  91       ;; First collect info from the "builtin" types.
  92       (maphash (lambda (type parents)
  93                  (dolist (parent parents)
  94                    (push type (alist-get parent subtypes))))
  95                syncdoc-hierarchy)
  96       (sort subtypes
  97             (lambda (x1 x2)
  98               (< (length (memq (car x2) syncdoc-all-types))
  99                  (length (memq (car x1) syncdoc-all-types)))))
 100       (cl-loop for (type . children) in (reverse subtypes)
 101                do (insert "|" (symbol-name type) " |")
 102                do (cl-loop with x = 0
 103                            for child in children
 104                            for child-len = (length (symbol-name child))
 105                            when (> (+ x child-len 2) 60)
 106                            do (progn
 107                                 (insert "|\n||")
 108                                 (setq x 0))
 109                            do (insert (symbol-name child) " ")
 110                            do (cl-incf x (1+ child-len)) )
 111                do (insert "\n")))
 112     (require 'org-table)
 113     (declare-function 'org-table-align "org")
 114     (org-table-align)))
 115
 116 (defun syncdoc-update-type-hierarchy0 ()
 117   "Update the type hierarchy representation used by the elisp manual."
 118   (with-temp-buffer
 119     (syncdoc-insert-dot-content "LR")
 120     (with-demoted-errors "%S"           ;In case "dot" is not found!
 121       (call-process-region nil nil "dot" t (current-buffer) nil "-Tjpg" "-o"
 122                            (expand-file-name "elisp_type_hierarchy.jpg"
 123                                              syncdoc-lispref-dir))))
 124   (syncdoc-make-type-table (expand-file-name "elisp_type_hierarchy.txt"
 125                                              syncdoc-lispref-dir)))
 126
 127 (defun syncdoc-update-type-hierarchy ()
 128   "Update the type hierarchy representation used by the elisp manual."
 129   (interactive)
 130   (call-process (expand-file-name "src/emacs" syncdoc-emacs-repo-dir)
 131                 nil t t "-Q" "--batch" "-l" syncdoc-file
 132                 "-f" "syncdoc-update-type-hierarchy0"))
 133
 134 ;;; syncdoc-type-hierarchy.el ends here