diff --git a/racket-company-doc.el b/racket-company-doc.el index 9df697de..cd5444ef 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 0500597e..df2369e1 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 5bce1a6b..031bd6dc 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. @@ -38,7 +64,7 @@ the effect of being non-breaking.") (let* ((tramp-verbose 2) ;avoid excessive messages (base (file-name-directory path)) (dom (racket--html-file->dom path)) - (body (racket--scribble-body dom)) + (body (dom-child-by-tag dom 'body)) (body (racket--massage-scribble-dom path base body))) `(html () (head () (base ((href . ,base)))) @@ -49,26 +75,6 @@ the effect of being non-breaking.") (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 +257,11 @@ In some cases we resort to returning custom elements for (`(span ((style . "font-style: italic")) . ,xs) `(i () ,@(mapcar #'racket--walk-dom xs))) + ;; 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)