Skip to content

Commit

Permalink
racket-describe: Surface "On this page" links via imenu
Browse files Browse the repository at this point in the history
  • Loading branch information
@greghendershott
greghendershott committed Sep 7, 2024
1 parent b26b3a3 commit 450a7e5
Show file tree
Hide file tree
Showing 3 changed files with 136 additions and 71 deletions.
57 changes: 29 additions & 28 deletions racket-company-doc.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,7 @@

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

(require 'cl-macs)
(require 'seq)
(require 'shr)
(require 'racket-back-end)
Expand All @@ -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)
Expand All @@ -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)

Expand Down
72 changes: 62 additions & 10 deletions racket-describe.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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)
Expand Down Expand Up @@ -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

Expand Down
78 changes: 45 additions & 33 deletions racket-scribble.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand All @@ -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)
Expand Down Expand Up @@ -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)
Expand All @@ -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
Expand Down Expand Up @@ -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)

Expand Down

0 comments on commit 450a7e5

Please sign in to comment.