Skip to content

Commit

Permalink
Various improvements to racket-pdb-mode
Browse files Browse the repository at this point in the history 
Keep eating the dog food.
  • Loading branch information
@greghendershott
greghendershott committed Mar 25, 2023
1 parent 98191e1 commit 94ae5a4
Show file tree
Hide file tree
Showing 3 changed files with 133 additions and 84 deletions.
51 changes: 50 additions & 1 deletion racket-custom.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -119,7 +119,8 @@ Predefined choices include `racket-shell', `racket-term',
(defcustom racket-xp-after-change-refresh-delay 1
"Seconds to wait before refreshing `racket-xp-mode' annotations.
Set to nil to disable automatic refresh and manually use `racket-xp-annotate'."
Set to nil to disable automatic refresh and manually use
`racket-xp-annotate'."
:tag "Racket XP Mode After Change Refresh Delay"
:type '(choice (integer :tag "Seconds")
(const :tag "Off" nil))
Expand All @@ -146,6 +147,54 @@ an underline, which is a common convention."
:safe #'stringp
:group 'racket-xp)

;;; racket-pdb-mode

(defgroup racket-pdb nil
"`racket-pdb-mode' options"
:tag "PDB Mode"
:group 'racket)

(defcustom racket-pdb-after-change-refresh-delay 1
"Seconds to wait after changing a buffer, before `racket-pdb-analyze'.
Set to nil to disable automatic refresh and manually use
`racket-pdb-analyze'."
:tag "Racket PDB Mode After Change Refresh Delay"
:type '(choice (integer :tag "Seconds")
(const :tag "Off" nil))
:safe #'integerp
:group 'racket-pdb)

(defcustom racket-pdb-after-motion-refresh-delay 0.25
"Seconds to wait after moving, before querying and redrawing annotations.
After you move point, `racket-pdb-mode' queries pdb for only
annotations visible on screen, and after the response arrives,
draws them."
:tag "Racket PDB Mode After Motion Refresh Delay"
:type '(choice (integer :tag "Seconds"))
:safe #'integerp
:group 'racket-pdb)

(defcustom racket-pdb-mode-lighter
'(:eval (racket--pdb-mode-lighter))
"Mode line lighter for `racket-pdb-mode'.
Set to nil to disable the mode line completely."
:type 'sexp
:risky t
:group 'racket-pdb)

(defcustom racket-pdb-highlight-unused-regexp "^[^_]"
"Only give `racket-xp-unused-face' to unused bindings that match this regexp.
The default is to highlight identifiers that do not start with
an underline, which is a common convention."
:tag "Racket PDB Mode Do Not Highlight Unused Regexp"
:type 'regexp
:safe #'stringp
:group 'racket-pdp)

;;; REPL

(defgroup racket-repl nil
Expand Down
149 changes: 80 additions & 69 deletions racket-pdb.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -54,13 +54,6 @@
("C-c C-d" ,#'racket-pdb-documentation)
("C-c C-s" ,#'racket-describe-search))))

;; TODO: Make into a defcustom like the one for racket-xp-mode ?
(defvar-local racket-pdb-mode-lighter
'(:eval (racket--pdb-mode-lighter))
"Mode line lighter for `racket-pdb-mode'.
Set to nil to disable the mode line completely.")

;;;###autoload
(define-minor-mode racket-pdb-mode
"Like `racket-xp-mode' but using the pdb package, which must be installed.
Expand Down Expand Up @@ -136,7 +129,7 @@ most of which is relevant to this mode."
(when (timerp racket--pdb-point-motion-timer)
(cancel-timer racket--pdb-point-motion-timer))
(setq racket--pdb-point-motion-timer
(run-with-idle-timer 0.25
(run-with-idle-timer racket-pdb-after-motion-refresh-delay
nil ;no repeat
#'racket--pdb-motion-timer-handler
window
Expand All @@ -145,61 +138,82 @@ most of which is relevant to this mode."
end))))))

(defun racket--pdb-motion-timer-handler (window point start end)
(racket--cmd/async
nil
`(pdb-point-info
,(racket-file-name-front-to-back (racket--buffer-file-name))
,point
,start
,end)
(lambda (response)
;; When still same point/scroll when response arrives.
(with-current-buffer (window-buffer window)
(when (and (= point (window-point window))
(= start (window-start window))
(= end (window-end window)))
;; 1. Do racket-show of mouse-over.
(pcase (cdr (assq 'mouse-over response))
(`(,beg ,end ,text)
(racket-show text
(cond
((pos-visible-in-window-p end window)
end)
((pos-visible-in-window-p beg window)
beg)
((save-excursion
(goto-char (window-start window))
(forward-line -1)
(point))))))
(_ (racket-show "")))

;; 2. Add overlays to highlight defs and uses.
(let ((def (cdr (assq 'def-site response)))
(uses (cdr (assq 'use-sites response))))
(racket--remove-face-overlays-in-buffer racket-xp-def-face
racket-xp-use-face)
(when def
(racket--add-face-overlay (car def) (cdr def) racket-xp-def-face))
(dolist (use uses)
(racket--add-face-overlay (car use) (cdr use) racket-xp-use-face)))

;; 3. Add overlays to highight tail positions.
;; TODO.

;; 4. Doc link.
(set-window-parameter window
'racket-pdb-doc-link
(pcase (cdr (assq 'doc-link response))
(`(,_beg ,_end ,path+anchor) path+anchor)))

;; 5. Add overlays for unused requires and identifiers
(dolist (v (cdr (assq 'unused response)))
(racket--add-face-overlay (car v) (cdr v) racket-xp-unused-face)))))))
(with-current-buffer (window-buffer window)
(racket--cmd/async
nil
`(pdb-point-info ,(racket-file-name-front-to-back (racket--buffer-file-name))
,point
,start
,end)
(lambda (response)
(with-current-buffer (window-buffer window)
;; Still same point/start/end now that the response arrived?
(when (and (= point (window-point window))
(= start (window-start window))
(= end (window-end window)))
;; 1. Do racket-show of mouse-over.
(pcase (cdr (assq 'mouse-over response))
(`(,beg ,end ,text)
(racket-show text
(cond
((pos-visible-in-window-p end window)
end)
((pos-visible-in-window-p beg window)
beg)
((save-excursion
(goto-char (window-start window))
(forward-line -1)
(point))))))
(_ (racket-show "")))

;; 2. Add overlays to highlight defs and uses.
(let ((def (cdr (assq 'def-site response)))
(uses (cdr (assq 'use-sites response))))
(racket--remove-face-overlays-in-buffer racket-xp-def-face
racket-xp-use-face)
(when def
(racket--add-face-overlay (car def) (cdr def) racket-xp-def-face))
(dolist (use uses)
(racket--add-face-overlay (car use) (cdr use) racket-xp-use-face)))

;; 3. Add overlays to highight tail positions.
;; TODO.

;; 4. Doc link.
(set-window-parameter window
'racket-pdb-doc-link
(pcase (cdr (assq 'doc-link response))
(`(,_beg ,_end ,path+anchor) path+anchor)))

;; 5. Add overlays for unused requires and definitions
(dolist (v (cdr (assq 'unused-requires response)))
(racket--add-face-overlay (car v) (cdr v) racket-xp-unused-face))
(dolist (v (cdr (assq 'unused-bindings response)))
(pcase-let ((`(,beg . ,end) v))
(when (string-match-p racket-pdb-highlight-unused-regexp
(buffer-substring beg end))
(racket--add-face-overlay beg end racket-xp-unused-face))))))))))

(defun racket--pdb-show-after-motion ()
(let ((window (selected-window)))
(racket--pdb-motion-timer-handler window
(window-point window)
(window-start window)
(window-end window))))

;;; Errors

(defvar-local racket--pdb-errors (vector))
(defvar-local racket--pdb-errors-index 0)
(defvar-local racket--pdb-errors (vector)
"[(list beg end path str) ...], sorted by beg")
(defvar-local racket--pdb-errors-index -1)

(defun racket--pdb-reset-errors (errors)
(let ((errors (sort errors (lambda (a b) (< (car a) (car b))))))
(dolist (e errors)
(pcase-let ((`(,beg ,end . ,_) e))
(racket--add-face-overlay beg end racket-xp-error-face)))
(setq racket--pdb-errors (apply #'vector errors))
(setq racket--pdb-errors-index -1)))

(defun racket--pdb-next-error (&optional amt reset)
"Move AMT errors, if any.
Expand Down Expand Up @@ -257,12 +271,12 @@ for the annotations resulting from the user's later edits.")
(when (timerp racket--pdb-analyze-idle-timer)
(cancel-timer racket--pdb-analyze-idle-timer))
(racket--pdb-set-status 'outdated)
(when racket-xp-after-change-refresh-delay
(when racket-pdb-after-change-refresh-delay
(racket--pdb-start-idle-timer (current-buffer))))

(defun racket--pdb-start-idle-timer (buffer)
(setq racket--pdb-analyze-idle-timer
(run-with-idle-timer racket-xp-after-change-refresh-delay
(run-with-idle-timer racket-pdb-after-change-refresh-delay
nil ;no repeat
#'racket--pdb-on-idle-timer
buffer)))
Expand Down Expand Up @@ -309,12 +323,9 @@ This is ad hoc and forensic."
(`((completions . ,completions)
(errors . ,errors))
(setq racket--xp-binding-completions completions) ;racket-xp-complete.el
(dolist (e errors)
(pcase-let ((`(,beg ,end . ,_) e))
(racket--add-face-overlay beg end racket-xp-error-face)))
(setq racket--pdb-errors (apply #'vector errors))
(setq racket--pdb-errors-index 0)
(racket--pdb-set-status (if errors 'err 'ok)))))))))
(racket--pdb-reset-errors errors)
(racket--pdb-set-status (if errors 'err 'ok))
(racket--pdb-show-after-motion))))))))

;;; Rename

Expand Down Expand Up @@ -456,7 +467,7 @@ Uses pdb to query for sites among multiple files."
(line-number-at-pos)
(current-column)))
results))))))
results))
(reverse results)))

;;; describe

Expand Down
17 changes: 3 additions & 14 deletions racket/commands/pdb.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -47,20 +47,9 @@
'mouse-over
(match-lambda
[(list beg end texts)
(list beg end (and texts (mouse-over-set->result texts)))])))

(define (mouse-over-set->result v)
;; It is possible for syncheck:add-arrow to be called both
;; with require-arrow? true and false for the same binding.
;; See #639. In that case, assume it's actually imported and
;; remove "defined locally" from the set of annotations.
(let ([v (if (and (set-member? v "defined locally")
(for/or ([s (in-set v)])
(regexp-match? #"^imported from" s)))
(set-remove v "defined locally")
v)])
(string-join (sort (set->list v) string<=?)
"; ")))
(list beg end (string-join (sort (set->list texts) string<=?)
"; "))]
[#f #f])))

(define (pdb-use->def-command path-str pos)
;; The front end xref system wants line:col not [beg end) span. :(
Expand Down

0 comments on commit 94ae5a4

Please sign in to comment.