1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
;;; racket-scribble-anchor.el -*- lexical-binding: t -*-
;; Copyright (c) 2022-2025 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'cl-macs)
(require 'ring)
(require 'seq)
(require 'shr)
(require 'racket-back-end)
(require 'racket-describe)
(require 'racket-scribble)
(defun racket--company-doc-buffer (how str)
(pcase (racket--cmd/await (racket--repl-session-id)
`(describe ,(racket-how-front-to-back how) ,str))
(`(,(and path (pred stringp)) . ,anchor)
(let ((path (racket-file-name-back-to-front path))
(name "*racket-company-doc-buffer*"))
(when-let (buf (get-buffer name))
(when (buffer-live-p buf)
(kill-buffer buf)))
(with-current-buffer (get-buffer-create name)
(goto-char (point-min))
(racket--scribble-path+anchor-insert path anchor)
(goto-char (point-min))
(setq buffer-read-only t)
(current-buffer))))))
(defvar racket--path+anchor-ring (make-ring 16)
"A small MRU cache of the N most recent strings.
Each ring item is (cons (cons path anchor) str).")
(defun racket--path+anchor->string (path anchor)
"A wrapper for `racket--scribble-path+anchor-insert'.
Uses `racket--path+anchor-cache'."
(pcase (seq-some (lambda (item)
(and (equal (car item) (cons path anchor))
item))
(ring-elements racket--path+anchor-ring))
((and `(,_path+anchor . ,str) item)
;; Re-insert as newest.
(ring-remove+insert+extend racket--path+anchor-ring item)
str)
(_
(let* ((str (with-temp-buffer
(racket--scribble-path+anchor-insert path anchor)
(buffer-string)))
(item (cons (cons path anchor) str)))
;; Insert as newest; oldest discarded when ring full.
(ring-insert racket--path+anchor-ring item)
str))))
(defun racket--scribble-path+anchor-insert (path anchor)
(let* ((tramp-verbose 2) ;avoid excessive tramp messages
(dom (racket--html-file->dom path))
(dom (racket--elements-for-anchor dom anchor))
(dom (racket--massage-scribble-dom path
(file-name-directory path)
dom)))
(ignore tramp-verbose)
(save-excursion
(let ((shr-use-fonts nil)
(shr-external-rendering-functions `((span . ,#'racket-render-tag-span)))
(shr-width 76))
(shr-insert-document dom)))
(while (re-search-forward (string racket--scribble-temp-nbsp) nil t)
(replace-match " " t t))))
(defun racket--elements-for-anchor (dom anchor)
"Return the subset of DOM elements pertaining to ANCHOR."
(cl-flet
((bluebox-p (node)
(and
(and (eq 'div (dom-tag node))
(equal "SIntrapara" (dom-attr node 'class)))
(dom-search node
(lambda (node)
(and (eq 'table (dom-tag node))
(equal "boxed RBoxed" (dom-attr node 'class)))))))
(section-or-heading-p (node)
(memq (dom-tag node) '(section h1 h2 h3 h4 h5 h6))))
;; Note: This is not optimized, due to using `dom-search' and
;; `dom-parent'. It would be faster to hand-code a `dom-search'
;; that, while descending, remembers the ancestor bluebox and its
;; siblings.
(let* (;; Drill all the way down to the anchor element.
(a (car (dom-search dom
(lambda (node)
(and (eq 'a (dom-tag node))
(equal anchor (dom-attr node 'name)))))))
;; Nav back up to its ancestor `bluebox-p' element.
(bluebox (let ((n (dom-parent dom a)))
(while (and n (not (bluebox-p n)))
(setq n (dom-parent dom n)))
n))
;; Get all siblings at same level as bluebox.
(siblings (dom-parent dom bluebox))
(result nil))
;; Discard siblings before the bluebox.
(while (and siblings (not (eq (car siblings) bluebox)))
(setq siblings (cdr siblings)))
;; Accumulate the bluebox and subsequent siblings up to but not
;; including some other bluebox, section, or heading.
(when siblings
(push (car siblings) result)
(setq siblings (cdr siblings))
(while (and siblings (not (or (bluebox-p (car siblings))
(section-or-heading-p (car siblings)))))
(push (car siblings) result)
(setq siblings (cdr siblings))))
`(div () ,@ (reverse result)))))
(provide 'racket-scribble-anchor)
;; racket-scribble-anchor.el ends here
|
