racket-describe: Surface "On this page" links via imenu

greghendershott · greghendershott · commit 82d75e7ab819 · 2024-09-06T14:13:43.000-04:00
diff --git a/racket-company-doc.el b/racket-company-doc.el
@@ -8,6 +8,7 @@
 
 ;; SPDX-License-Identifier: GPL-3.0-or-later
 
+(require 'cl-macs)
 (require 'seq)
 (require 'shr)
 (require 'racket-back-end)
@@ -34,11 +35,8 @@
   (with-temp-message (format "Getting and formatting documentation %s %s ..."
                              path anchor)
     (let* ((tramp-verbose 2)            ;avoid excessive messages
-           (dom   (racket--html-file->dom path))
-           (body  (racket--scribble-body dom))
-           (elems (racket--company-elements-for-anchor body anchor))
-           (dom   `(div () ,@elems))
-           (dom   (racket--walk-dom dom)))
+           (dom (racket--scribble-path->shr-dom path))
+           (dom (racket--company-elements-for-anchor dom anchor)))
       (ignore tramp-verbose)
       (save-excursion
         (let ((shr-use-fonts nil)
@@ -48,29 +46,32 @@
       (while (re-search-forward (string racket--scribble-temp-nbsp) nil t)
         (replace-match " " t t)))))
 
-(defun racket--company-elements-for-anchor (xs anchor)
-  "Return the subset of XS dom elements pertaining to ANCHOR."
-  (while (and xs (not (racket--anchored-element (car xs) anchor)))
-    (setq xs (cdr xs)))
-  (and xs
-       (let ((result nil))
-         (push (car xs) result)
-         (setq xs (cdr xs))
-         (while (and xs (not (or (racket--heading-element (car xs))
-                                 (racket--anchored-element (car xs)))))
-           (push (car xs) result)
-           (setq xs (cdr xs)))
-         (reverse result))))
-
-(defun racket--heading-element (x)
-  (and (listp x)
-       (memq (car x) '(h1 h2 h3 h4 h5 h6))))
-
-(defun racket--anchored-element (x &optional name)
-  (pcase x
-    (`(a ((name . ,a)) . ,_) (or (not name) (equal name a)))
-    (`(,_tag ,_as . ,es) (seq-some (lambda (v) (racket--anchored-element v name))
-                                   es))))
+(defun racket--company-elements-for-anchor (dom anchor)
+  "Return the subset of DOM elements pertaining to ANCHOR."
+  (cl-labels
+      ((heading-p (x)
+         (memq (dom-tag x) '(h1 h2 h3 h4 h5 h6)))
+       (anchor-p (x name)
+         (if (and (eq 'racket-anchor (dom-tag x))
+                  (or (not name) (equal name (dom-attr x 'name))))
+             t
+           (seq-some (lambda (v) (anchor-p v name))
+                     (dom-non-text-children x)))))
+    ;; Consider immediate children of the "main" div.
+    (let ((result nil)
+          (xs (dom-children (car (dom-by-class dom "main\\'")))))
+      ;; Discard elements before the one containing a matching anchor.
+      (while (and xs (not (anchor-p (car xs) anchor)))
+        (setq xs (cdr xs)))
+      ;; Accumulate result up to another anchor or a heading.
+      (when xs
+        (push (car xs) result)
+        (setq xs (cdr xs))
+        (while (and xs (not (or (heading-p (car xs))
+                                (anchor-p (car xs) nil))))
+          (push (car xs) result)
+          (setq xs (cdr xs))))
+      (racket--walk-dom `(div () ,@(reverse result))))))
 
 (provide 'racket-company-doc)
 
diff --git a/racket-describe.el b/racket-describe.el
@@ -151,7 +151,8 @@ anchor. If numberp, move to that position."
              (racket-ext-link   . ,#'racket-render-tag-racket-ext-link)
              (racket-anchor     . ,#'racket-render-tag-racket-anchor)
              (racket-nav        . ,#'racket-render-tag-racket-nav))))
-      (shr-insert-document dom))
+      (shr-insert-document
+       (racket--describe-handle-toc-nodes dom)))
     ;; See doc string for `racket--scribble-temp-nbsp'.
     (goto-char (point-min))
     (while (re-search-forward (string racket--scribble-temp-nbsp) nil t)
@@ -177,19 +178,62 @@ text. We want point left where `racket-search-describe' can use
     ((numberp goto)
      goto)
     ((stringp goto)
-     (or (let ((i nil)) ;silence byte-compiler warning...
-           i            ;...on all versions of emacs
-           (cl-loop for i being the intervals
-                    if (equal (get-text-property (car i) 'racket-anchor)
-                              goto)
-                    return (cl-loop for j from (car i) to (point-max)
-                                    if (not (get-text-property j 'racket-anchor))
-                                    return j)))
+     (or (racket--describe-anchor->position goto)
          (point-min)))
     (t (point-min))))
   (setq racket--describe-here
         (cons (car racket--describe-here) (point))))
 
+(defun racket--describe-anchor->position (anchor)
+  (let ((i nil)) ;silence byte-compiler warning...
+    i            ;...on all versions of emacs
+    (cl-loop for i being the intervals
+             if (equal (get-text-property (car i) 'racket-anchor)
+                       anchor)
+             return (cl-loop for j from (car i) to (point-max)
+                             if (not (get-text-property j 'racket-anchor))
+                             return j))))
+
+(defvar-local racket--describe-on-this-page nil)
+
+(defun racket--describe-handle-toc-nodes (dom)
+  "Handle nodes that render as a \"left nav panel\" in a web browser.
+
+These aren't effective in a shr buffer, due to window width and
+lack of independent scrolling columns. Instead:
+
+- \"tocview\": Just delete it. User can nav up to see.
+
+- \"tocsub\" a.k.a. \"On this page:\": Useful, but present via
+  `imenu'.
+
+Both are children of a \"tocscet\" div."
+  (setq-local
+   racket--describe-on-this-page
+   (let* ((tocsublist-table (car (dom-by-class dom "tocsublist")))
+          (trs (dom-children tocsublist-table)))
+     (seq-map (lambda (tr)
+                (let* ((td (car (dom-children tr)))
+                       (num (car (dom-by-class td "tocsublinknumber")))
+                       (link (dom-child-by-tag td 'racket-doc-link))
+                       (label (concat (dom-texts num "")
+                                      (dom-texts link "")))
+                       (label (subst-char-in-string racket--scribble-temp-nbsp
+                                                    32
+                                                    label))
+                       (anchor (dom-attr link 'anchor)))
+                  (cons label anchor)))
+              trs)))
+  (pcase (dom-by-class dom "tocset")
+    (`(,node . ,_) (dom-remove-node dom node)))
+  dom)
+
+(defun racket--describe-imenu-create-index ()
+  (seq-map (lambda (v)
+             (cons (car v)
+                   (racket--describe-anchor->position (cdr v))))
+           racket--describe-on-this-page))
+
 (defconst racket--shr-faces
   '(("RktSym"                . font-lock-keyword-face)
     ("RktVal"                . font-lock-constant-face)
@@ -474,7 +518,15 @@ browser program -- are given `racket-describe-ext-link-face'.
 \\{racket-describe-mode-map}"
   (setq show-trailing-whitespace nil)
   (setq-local revert-buffer-function #'racket-describe-mode-revert-buffer)
-  (buffer-disable-undo))
+  (buffer-disable-undo)
+  ;; imenu
+  (setq-local imenu-create-index-function
+              #'racket--describe-imenu-create-index)
+  (when (boundp 'imenu-auto-rescan)
+    (setq-local imenu-auto-rescan t))
+  (when (boundp 'imenu-max-items)
+    (setq-local imenu-max-items 999))
+  (imenu-add-to-menubar "On this page"))
 
 ;;; Search and disambiguation using local docs
 
diff --git a/racket-scribble.el b/racket-scribble.el
@@ -8,12 +8,38 @@
 
 ;; SPDX-License-Identifier: GPL-3.0-or-later
 
+(require 'dom)
 (require 'seq)
 (require 'shr)
 (require 'subr-x)
 (require 'url-util)
 (require 'tramp)
 
+(eval-when-compile
+  (unless (fboundp 'dom-remove-node)    ;added circa Emacs 27
+    (defun dom-remove-node (dom node)
+      "Remove NODE from DOM."
+      ;; If we're removing the top level node, just return nil.
+      (dolist (child (dom-children dom))
+        (cond
+         ((eq node child)
+          (delq node dom))
+         ((not (stringp child))
+          (dom-remove-node child node))))))
+
+  (unless (fboundp 'dom-search)         ;added circa Emacs 27
+    (defun dom-search (dom predicate)
+      "Return elements in DOM where PREDICATE is non-nil.
+PREDICATE is called with the node as its only parameter."
+      (let ((matches (cl-loop for child in (dom-children dom)
+			      for matches = (and (not (stringp child))
+					         (dom-search child predicate))
+			      when matches
+			      append matches)))
+        (if (funcall predicate dom)
+	    (cons dom matches)
+          matches)))))
+
 (defconst racket--scribble-temp-nbsp #x2020
   "Character we substitute for #xA0 non-breaking-space.
 
@@ -33,42 +59,23 @@ This will ensure that the non-breaking-space chars actually have
 the effect of being non-breaking.")
 
 (defun racket--scribble-path->shr-dom (path)
-  (with-temp-message (format "Getting and formatting documentation %s..."
-                             path)
-    (let* ((tramp-verbose 2) ;avoid excessive messages
-           (base (file-name-directory path))
-           (dom  (racket--html-file->dom path))
-           (body (racket--scribble-body dom))
-           (body (racket--massage-scribble-dom path base body)))
-      `(html ()
-             (head () (base ((href . ,base))))
-             ,body))))
+  (let* ((tramp-verbose 2) ;avoid excessive messages
+         (base (file-name-directory path))
+         (dom  (with-temp-message (format "Getting %s..." path)
+                 (racket--html-file->dom path)))
+         (body (with-temp-message (format "Adjusting %s..." path)
+                 (racket--massage-scribble-dom path
+                                               base
+                                               (dom-child-by-tag dom 'body)))))
+    `(html ()
+           (head () (base ((href . ,base))))
+           ,body)))
 
 (defun racket--html-file->dom (path)
   (with-temp-buffer
     (insert-file-contents-literally path)
     (libxml-parse-html-region (point-min) (point-max))))
 
-(defun racket--scribble-body (dom)
-  "Return a body with the interesting elements in DOM.
-
-With a normal Racket documentation page produced by Scribble,
-these are only elements from the maincolumn/main div -- not the
-tocset sibling.
-
-With other doc pages, e.g. from r5rs, these are simply all the
-body elements."
-  (pcase (seq-some (lambda (v)
-                     (pcase v (`(body . ,_) v)))
-                   dom)
-    (`(body ,_
-            (div ((class . "tocset")) . ,_)
-            (div ((class . "maincolumn"))
-                 (div ((class . "main")) . ,xs))
-            . ,_)
-     `(body () ,@xs))
-    (body body)))
-
 ;; Dynamically bound (like Racket parameters).
 (defvar racket--scribble-file nil)
 (defvar racket--scribble-base nil)
@@ -251,6 +258,11 @@ In some cases we resort to returning custom elements for
     (`(span ((style . "font-style: italic")) . ,xs)
      `(i () ,@(mapcar #'racket--walk-dom xs)))
 
+    ;; <span class="mywbr"> </span> added in e.g. "tocsub" for
+    ;; "case/equal". As render in shr, undesired space.
+    (`(span ((class . "mywbr")) ,_)
+     "")
+
     ;; Delete some things that produce unwanted blank lines and/or
     ;; indents.
     (`(blockquote ((class . ,(or "SVInsetFlow" "SubFlow"))) . ,xs)
@@ -547,7 +559,7 @@ In some cases we resort to returning custom elements for
   "HTML entity symbols to strings.
 From <https://github.com/GNOME/libxml2/blob/master/HTMLparser.c>."
   (string (or (cdr (assq sym racket--html-char-entities))
-              ??)))
+              (format "%s" sym))))
 
 (provide 'racket-scribble)
 
