branch: elpa/racket-mode
commit 9e0cd5db1b903d7f061a2f9dca7117cef3294c7d
Author: Greg Hendershott <g...@greghendershott.com>
Commit: Greg Hendershott <g...@greghendershott.com>
racket-describe: Surface "On this page" links via imenu
---
racket-company-doc.el | 57 ++++++++++++++++++------------------
racket-describe.el | 72 ++++++++++++++++++++++++++++++++++++++-------
racket-scribble.el | 81 ++++++++++++++++++++++++++++++---------------------
3 files changed, 138 insertions(+), 72 deletions(-)
diff --git a/racket-company-doc.el b/racket-company-doc.el
index 9df697deb2..cd5444ef46 100644
--- 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
index 0500597ea3..df2369e13b 100644
--- 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
index 782d8a37db..a572ca4c31 100644
--- 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 rendered in shr, undesired space.
+ (`(span ((class . "mywbr")) . ,_)
+ "")
+
;; Delete some things that produce unwanted blank lines and/or
;; indents.
(`(blockquote ((class . ,(or "SVInsetFlow" "SubFlow"))) . ,xs)
@@ -277,8 +289,8 @@ In some cases we resort to returning custom elements for
((and (pred stringp) s)
(subst-char-in-string #xA0 racket--scribble-temp-nbsp s))
((and (pred numberp) n) (string n))
- (`() "")
- (sym (racket--html-char-entity-symbol->string sym))))
+ ((and (pred symbolp) s) (racket--html-char-entity-symbol->string s))
+ (_ "")))
(defun racket--scribble-file->data-uri (image-file-name)
(concat
@@ -546,8 +558,9 @@ In some cases we resort to returning custom elements for
(defun racket--html-char-entity-symbol->string (sym)
"HTML entity symbols to strings.
From <https://github.com/GNOME/libxml2/blob/master/HTMLparser.c>."
- (string (or (cdr (assq sym racket--html-char-entities))
- ??)))
+ (if-let (ch (cdr (assq sym racket--html-char-entities)))
+ (string ch)
+ (format "&%s;" sym)))
(provide 'racket-scribble)
