SymTree — Build and search nested hash tables of symbols (Emacs package)

;;; symtree.el --- Build and search nested hash tables of symbols -*- lexical-binding: t -*-
;;; Commentary:
;;;; For all the details, please do see the README
;;; Code:
;;;; Libraries
;;;; Package metadata
;;;; Customizable variables
;;;; Other variables
;;;; Functions
;;;;; Query and report
;;;;;; Demos
;;;;;; Query prefixes
;;;;; Create symbol trees
;;;;;; Select input interactively and create output trees
;;;;;; Nested hash table from hash table of symbols defined by packages
;;;;;;; Merge hash tables
;;;;;;; Read hash table
;;;;;; Org tree from nested hash table
;;;;;; Tokenize
;;;;; See README
;;;; Wrapping up
;;; symtree.el ends here

;;; symtree.el --- Build and search nested hash tables of symbols -*- lexical-binding: t -*-

;; SPDX-FileCopyrightText: © flandrew <https://flandrew.srht.site/listful>

;;---------------------------------------------------------------------------
;; Author:    flandrew
;; Created:   2024-10-30
;; Updated:   2025-08-08
;; Keywords:  lisp
;; Homepage:  <https://flandrew.srht.site/listful/software.html>
;;---------------------------------------------------------------------------
;; Package-Version:  0.2.0
;; Package-Requires: ((emacs "26.1") (xht "1.0.5") (dash "2.15") (s "1.12"))
;;---------------------------------------------------------------------------

;; SPDX-License-Identifier: GPL-3.0-or-later

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this file. If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; From packages and their symbols to nested hash tables of tokenized symbols.
;;
;;;; For all the details, please do see the README
;;
;; Open it easily with:
;;   (find-file-read-only "README.org")   <--- C-x C-e here¹
;;
;; or from any buffer:
;;   M-x symtree-see-readme
;;
;; or read it online:
;;   <https://flandrew.srht.site/listful/sw-emacs-symtree.html>
;;
;; ¹ or the key that ‘eval-last-sexp’ is bound to, if not C-x C-e.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;; Code:
;;;; Libraries

(require 's)
(require 'org)
(require 'xht)       ; <---also by the author of this package
(require 'dash)
(require 'lisp-mnt)  ; ‘lm-summary’, ‘lm-homepage’, ‘lm-version’, ‘lm-header’


;;;; Package metadata

(defvar symtree--name "SymTree")

(defvar symtree--dot-el
  (format "%s.el" (file-name-sans-extension (eval-and-compile
                                              (or load-file-name
                                                  buffer-file-name)))))
(defvar symtree--readme-org
  (expand-file-name "README.org" (file-name-directory symtree--dot-el)))

(defvar symtree--summary  (lm-summary   symtree--dot-el))
(defvar symtree--homepage (lm-homepage  symtree--dot-el))
(defvar symtree--version  (lm-with-file symtree--dot-el
                            (or (lm-header "package-version")
                                (lm-version))))


;;;; Customizable variables

(defgroup symtree nil
  (format "%s." symtree--summary)
  :group 'lisp
  :link  '(emacs-library-link :tag "Lisp file" "symtree.el")
  :link  `(file-link :tag "README.org" ,symtree--readme-org)
  :link  `(url-link  :tag "Homepage"   ,symtree--homepage))

(defcustom symtree-default-in "demo"
  "Default file basename for tests."
  :package-version '(symtree "0.1.0")
  :type 'string)

(defcustom symtree-min-for-htbl 50
  "Minimum number of keys to default to :htbl output."
  :package-version '(symtree "0.1.0")
  :type 'integer)


;;;; Other variables

(defvar symtree-sep-rx "[^a-zA-Z0-9@]+"
  "Regexp of separator.")


;;;; Functions
;;;;; Query and report
;;;;;; Demos

(defun symtree-query-pre-demo (prefix)
  "Return list of packages having PREFIX.
For the meaning of PREFIX, see ‘symtree-query-pre’.
The table comes from out/%s-tree.el, where %s is ‘symtree-default-in’."
  (symtree--demoify #'symtree-query-pre prefix))

(defun symtree-query-pre-inits-demo (prefix)
  "Return alist of packages having inits of PREFIX.
For the meaning of PREFIX, see ‘symtree-query-pre’.
The table comes from out/%s-tree.el, where %s is ‘symtree-default-in’."
  (symtree--demoify #'symtree-query-pre-inits prefix))

(defun symtree--demoify (fun &rest rest)
  "Make demo of FUN and REST using default tree."
  (let ((htree-file (format "out/%s-tree.el" symtree-default-in)))
    (apply fun htree-file rest)))

;;;;;; Query prefixes

(defun symtree-query-pre (horhf prefix)
  "Return list of packages having PREFIX.
HORHF is either a hash table or a file containing one.

A package has PREFIX if it defines any symbol that has PREFIX.

- If ‘symtree-sep-rx’ matches PREFIX's end, then the symbol has PREFIX
  if the symbol starts with PREFIX.

- If ‘symtree-sep-rx’ does not match PREFIX's end, then the symbol has
  PREFIX either if it's equal to PREFIX, or if it starts with PREFIX
  followed by something that matches ‘symtree-sep-rx’."
  (let* ((htree (symtree--read-h horhf))
         (token (symtree-tokenize prefix))
         (htble (symtree--query-last-h token htree)))
    (symtree--query-leaves htble)))

(defun symtree-query-pre-inits (horhf prefix)
  "Return alist of packages having inits of PREFIX.
HORHF is either a hash table or a file containing one.

For the meaning of inits, see ‘symtree--pre-inits’.
For the meaning of PREFIX, see ‘symtree-query-pre’.

Then ‘symtree-query-pre’ is run over HORHF on each of the inits,
and the results are returned as an alist."
  (let* ((htree (symtree--read-h horhf))
         (inits (symtree--pre-inits prefix)))
    (--map `(,it . ,(symtree-query-pre htree it)) inits)))

(defun symtree--pre-inits (prefix)
  "Return inits of PREFIX.
The inits of PREFIX is a list containing all the prefixes of
PREFIX. For example, the inits of PREFIX ‘s-exp-foo--’ are:
  (s s- s-exp s-exp- s-exp-foo s-exp-foo- s-exp-foo--)
but with each item as a string."
  (->> prefix  h-as-string  symtree-tokenize  -inits  cdr
       (-map #'string-join)))

(defun symtree--query-last-h (token horhf)
  "Get last hash table value from TOKEN and HORHF.
HORHF is either a hash table or a file containing one."
  (let* ((htree (symtree--read-h horhf))
         (res htree))
    (while (and token res)
      (setq res (h-get res (pop token))))
    (or res (h*))))

(defun symtree--query-leaves (horhf)
  "Given hash table HORHF, return flat uniq sorted list of leaves.
HORHF is either a hash table or a file containing one."
  (let* ((htree (symtree--read-h horhf))
         (leaves ()))
    (h--each htree
      (push (if (h? value)
                (symtree--query-leaves value)
              value)
            leaves))
    (->> leaves  -flatten  -uniq
         (-sort (-on #'string< #'h-as-string)))))


;;;;; Create symbol trees
;;;;;; Select input interactively and create output trees

;;;###autoload
(defun symtree-select (&optional h-file input-type pre)
  "Read H-FILE, convert it, write trees, then show org tree.
Convert to both nested hash table and org tree.
For the meaning of INPUT-TYPE, see ‘symtree-h-make’.
PRE is an optional prefix, to write only this branch to .org."
  (interactive)
  (when h-file
    (unless (file-readable-p h-file)
      (error "Not readable: %s" h-file)))
  (let* ((dir (file-name-directory symtree--dot-el))
         (in  (expand-file-name "in/"  dir))
         (out (expand-file-name "out/" dir))
         (dem (format "%s.el" symtree-default-in))
         (org) (htbl))
    (unless h-file
      (setq h-file (read-file-name "Select input file: " in dem t)))
    (setq htbl (h-read-h h-file))
    (unless (memq (h-as-symbol input-type) '(ps sp))
      (let* ((itg (h-as-string (symtree--guess-input-type htbl)))
             (pro (format "Select input-type (best guess = %s): " itg)))
        (setq input-type (h-as-symbol (completing-read
                                       pro '(ps sp) nil t itg)))))
    (unless pre
      (let ((p (read-from-minibuffer
                "Type a prefix to filter, or RET to not filter: "
                "[DON'T FILTER]")))
        (unless (string= p "[DON'T FILTER]")
          (setq pre p))))
    (setq out (expand-file-name
               (format "%s-tree.el" (file-name-base h-file)) out)
          org (s-replace-regexp "el$" "org" out))
    (symtree-h-write input-type htbl out)
    (symtree-org-tree-write out org pre)
    (find-file-read-only org)))

(defun symtree--guess-input-type (horhf)
  "Given HORHF, guess input-type.
For the meaning of INPUT-TYPE, see ‘symtree-h-make’.
HORHF is either a hash table or a file containing one."
  (let* ((symh (symtree--read-h horhf))
         (size (h-size symh))
         (upto (if (> size 10) 10 size))
         (vals ())
         (cnt  0))
    (catch 'break
      (h--each symh
        (if (< upto cnt)
            (throw 'break nil)
          (setq vals (append value vals)
                cnt  (1+ cnt)))))
    ;; pack→syms: will have large value lists
    ;; sym→packs: value lists will be mostly of size 1
    (if (>= (length vals) (* upto 2)) 'ps 'sp)))


;;;;;; Nested hash table from hash table of symbols defined by packages

(defun symtree-h-write (input-type horhf htree-file &optional h-fmt)
  "Given INPUT-TYPE and HORHF, write HTREE-FILE.
For the meaning of INPUT-TYPE, see ‘symtree-h-make’.

HORHF is either a hash table or a file containing one.

H-FMT is the hash table format to use for writing the file.

When H-FMT is nil, if HORHF has more than ‘symtree-min-for-htbl’ keys,
default to :htbl. Otherwise, use :h*.

Better use native :htbl format #s(…) for the output when input is large,
as it's read much faster.

Note that :htbl is short for :htbl-pp, which implies pretty-print, so
line breaks are applied. If compact is preferred, pass :htbl-cm instead.
However, this will be an enormous single line, which might freeze for
many users, and is therefore discouraged."
  (let* ((sym-h (symtree--read-h horhf))
         (res-h (symtree-h-make input-type sym-h)))
    (unless h-fmt
      (setq h-fmt (if (> (h-size sym-h) symtree-min-for-htbl) :htbl :h*)))
    (h-write-ht-like! htree-file h-fmt res-h)))

(defun symtree-h-make (input-type horhf)
  "Given INPUT-TYPE and HORHF, output consolidated nested hash table.

INPUT-TYPE must be either \\='ps or \\='sp.
- If \\='ps, use ‘symtree-h-make-from-packsyms-h’.
- If \\='sp, use ‘symtree-h-make-from-sympacks-h’.

HORHF is either a hash table or a file containing one."
  (pcase input-type
    ('ps (symtree-h-make-from-packsyms-h horhf))
    ('sp (symtree-h-make-from-sympacks-h horhf))
    (_   (error "‘symtree-h-make’: input-type must be 'ps or 'sp"))))

(defun symtree-h-make-from-packsyms-h (horhf)
  "Given HORHF, output consolidated nested hash table.
HORHF is either a hash table or a file containing one.

HORHF's every KEY is a package, and its VALUE is a list of symbols of a
certain kind (e.g. functions) defined by the package. The keys and list
elements may be passed as either strings or symbols."
  (let ((sym-h (symtree--read-h horhf))
        (res-h (h-new))
        (token))
    (h--each sym-h
      (setq key (h-as-symbol key))
      (--each value
        (setq token (symtree-tokenize it))
        (apply #'h-put*! `(,res-h ,@token :@ (,key)))))
    res-h))

(defun symtree-h-make-from-sympacks-h (horhf)
  "Given HORHF, output consolidated nested hash table.
HORHF is either a hash table or a file containing one.

HORHF's every KEY is a symbol of a certain kind (e.g. functions), and
its VALUE is a list of packages that define that symbol. The keys and
list elements may be passed as either strings or symbols.

Typically, and ideally, only one package will show up in each value's
list — otherwise a collision is likely to be going on."
  (let ((sym-h (symtree--read-h horhf))
        (res-h (h-new))
        (token))
    (h--each sym-h
      (setq token (symtree-tokenize key)
            value (mapcar #'h-as-symbol value))
      (apply #'h-put*! `(,res-h ,@token :@ ,value)))
    res-h))


;;;;;;; Merge hash tables

;; This can be useful to consolidate either the inputs or the outputs of
;; ‘symtree-h-write’. Tables can then be easily updated with diffs.

(defun symtree-merge-tables (file-to &rest files-from)
  "Merge hash tables in FILES-FROM, writing FILE-TO.

FILES-FROM can be any number of files or directories. When it's a
directory, all files inside it are recursively collected and used.

Each file is then read, expecting a hash table inside. An error is
thrown when an input file has no hash table or is unreadable.

All hash tables are then merged and the end result is written as
FILE-TO, without confirmation.

If result is simple (dimension = 1), write output in (h*…) format.
Otherwise assume nested, and output #s(hash-table…) native format.

Files in FILES-FROM may be gzip'd."
  (unless (file-writable-p file-to)
    (error "Not writable: %s" file-to))
  (let* ((from  (-flatten (mapcar #'symtree--files-recursively files-from)))
         (res-h (->> from (mapcar #'h-read-h) (apply #'h-mix*)))
         (h-fmt (if (h-1d? res-h) :h* :htbl)))
    (h-write-ht-like! file-to h-fmt res-h)))

(defun symtree--files-recursively (obj)
  "If OBJ is a file, return it; if dir, recurse and return list.
When OBJ or any of the recursively listed files is unreadable,
signal error."
  (unless (file-readable-p obj)
    (error "Not readable: %s" obj))
  (let ((files (cond ((file-regular-p obj) obj)
                     ((file-directory-p obj)
                      (directory-files-recursively obj "." nil t t))
                     (:otherwise (error "Could not process %s" obj)))))
    (and-let* (((listp files))
               (unrdbl (-filter (-not #'file-readable-p) files))
               ((error "Not readable: %S" unrdbl))))
    files))


;;;;;;; Read hash table

(defun symtree--read-h (horhf)
  "Read HORHF: a hash table or a file containing one."
  (if (h? horhf) horhf (h-read-h horhf)))


;;;;;; Org tree from nested hash table

(defun symtree-org-tree-write (horhf otree-file &optional pre header level)
  "Write complete org tree from nested hash table in HORHF.
By complete we mean a single top node contains everything else.
HORHF is either a hash table or a file containing one.
OTREE-FILE is the file to write to.
HEADER is a header string, and defaults to [all].
PRE is an optional prefix, to show only this branch.
LEVEL is the level of the top node, and defaults to 1."
  (let ((orgstr (symtree--org-tree-1 horhf pre header level)))
    (with-temp-buffer
      (insert orgstr)
      (write-region (point-min) (point-max) otree-file))))

(defun symtree-org-tree-buffer (horhf &optional pre header level)
  "Show buffer with complete org tree from nested hash table in HORHF.
By complete we mean a single top node contains everything else.
HORHF is either a hash table or a file containing one.
HEADER is a header string, and defaults to [all].
PRE is an optional prefix, to show only this branch.
LEVEL is the level of the top node, and defaults to 1."
  (let ((orgstr (symtree--org-tree-1 horhf pre header level))
        (newbuf (get-buffer-create "*symtree*")))
    (with-current-buffer newbuf
      (erase-buffer)
      (insert orgstr)
      (org-mode))
    (switch-to-buffer newbuf)))

(defun symtree--org-tree-1 (horhf &optional pre header level)
  "Return complete org tree string from nested hash table in HORHF.
By complete we mean a single top node contains everything else.
HORHF is either a hash table or a file containing one.
HEADER is a header string, and defaults to [all].
PRE is an optional prefix, to show only this branch.
LEVEL is the level of the top node, and defaults to 1."
  (unless level
    (setq level 1))
  (let* ((htree  (symtree--read-h horhf))
         (orgstr (symtree--org-str-from-htree htree pre (1+ level))))
    (symtree--org-str-complete orgstr header)))

(defun symtree--org-str-complete (orgstr &optional header)
  "Output a complete org tree string from STR.
By complete we mean a single top node contains everything else.
HEADER is a header string, and defaults to [all].
ORGSTR is the output of ‘symtree--org-str-from-htree’.
Level is autodetected by the first line of STR."
  (unless header
    (setq header "[all]"))
  (let* ((stars (s-repeat 20 "*"))
         (level (->> orgstr  (s-shared-start stars)  length  1-))
         (stars (s-repeat level "*")))
    (format "%s %s\n%s" stars header orgstr)))

(defun symtree--org-str-from-htree (horhf &optional pre level)
  "Output an org tree string from nested hash table HORHF.
HORHF is either a hash table or a file containing one.
PRE is an optional prefix, to show only this branch.
LEVEL is the start level, which defaults to 2."
  (unless level
    (setq level 2))
  (let ((htree (symtree--read-h horhf)))
    (when pre
      (let* ((token (symtree-tokenize pre))
             (query (symtree--query-last-h token htree)))
        ;; Insert the tokenized prefix before
        (setq htree (apply #'h-reduce-r (-snoc token query)))))
    (with-output-to-string
      (h--each htree
        (princ (format "%s %s\n"
                       (s-repeat level "*")
                       (if (h? value) key value)))
        (when (h? value)
          (princ (symtree--org-str-from-htree value nil (1+ level))))))))


;;;;;; Tokenize

(defun symtree-tokenize (obj)
  "Tokenize object OBJ. Use ‘symtree-tokenize-around’."
  (symtree-tokenize-around obj))

(defun symtree-tokenize-around (obj)
  "Tokenize object OBJ, splitting before and after each separator.
This makes it much more flexible for querying."
  (let ((str (format "%s" obj)))
    (with-temp-buffer
      (insert str)
      (unless (bobp)       ; bobp only when obj is either '## or ""
        (backward-char 1)) ; we don't want a "" tail if obj ends in sep
      (while (not (bobp))
        (and (or (looking-at   symtree-sep-rx t)
                 (looking-back symtree-sep-rx (1- (point))))
             (open-line 1))
        (backward-char 1))
      (when (looking-at symtree-sep-rx t)
        (open-line 1))     ; we want a "" head if obj starts with sep
      (s-lines (buffer-string)))))
;; Note: there're certainly ways to do this more efficiently using
;; ‘string-match’, but this can be optimized later if really needed.


;;;;; See README

;;;###autoload
(defun symtree-see-readme (&optional heading narrow)
  "Open symtree's README.org file.
Search for the file in symtree.el's directory.

If found, open it read-only.

If optional argument HEADING is passed, try to navigate to the
heading after opening it. HEADING should be a string.

If optional argument NARROW is non-nil, narrow to that heading.
This argument has no effect if HEADING is nil or not found."
  (interactive)
  (let ((readme symtree--readme-org))
    (if (file-exists-p readme)
        (let ((pr (make-progress-reporter
                   (format "Opening %s ... "
                           (abbreviate-file-name readme)))))
          (find-file-read-only readme)
          (when heading
            (symtree--goto-org-heading heading narrow))
          (progress-reporter-done pr))
      (message "Couldn't find %s's README.org" symtree--name))))

;;;###autoload
(defun symtree-see-news ()
  "See the News in symtree's README.org file."
  (interactive)
  (symtree-see-readme "News" 'narrow)
  (symtree--display-org-subtree))

(defun symtree--display-org-subtree ()
  "Selectively display org subtree."
  (let ((cmds '( outline-hide-subtree outline-show-children
                 outline-next-heading outline-show-branches)))
    (and (equal (mapcar #'fboundp cmds) '(t t t t))
         (mapc #'funcall cmds))))

(defun symtree--goto-org-heading (heading &optional narrow)
  "Navigate to org HEADING and optionally NARROW to it."
  (let* ((hrx (format "^[*]+ %s" heading))
         (pos (save-match-data
                (save-excursion
                  (save-restriction
                    (widen)  (goto-char (point-max))
                    (re-search-backward hrx nil t 1))))))
    (when pos
      (widen)  (goto-char pos)
      (if (and narrow (fboundp 'org-narrow-to-subtree))
          (org-narrow-to-subtree)
        (recenter-top-bottom 1))
      (when (fboundp 'outline-show-subtree)
        (outline-show-subtree))
      (when (fboundp 'org-flag-drawer)
        (save-excursion
          (forward-line 1)
          (org-flag-drawer t))))))


;;;; Wrapping up

(provide 'symtree)

;; Local Variables:
;; coding:                     utf-8
;; indent-tabs-mode:           nil
;; sentence-end-double-space:  nil
;; outline-regexp:             ";;;;* "
;; End:

;;; symtree.el ends here