Skip to content

Commit

Permalink
Initial commit to use "pdb" when available for check-syntax
Browse files Browse the repository at this point in the history 
Although I am starting to dog-food this, not yet recommended for other
people to use. Many caveats:

- Still a bit janky.

- Still uses the status quo approach of fetching all data and
re-propertizing entire buffer. Instead want to explore a
"jit-font-lock driven" approach where we fetch data for and
re-propertize only slices of the buffer as they become visible and
therefore font-locked. Should help with large files.

- The back end unconditionally uses pdb if it can be dynamic-required.
Instead probably want a customization var up in Emacs to say never use
it.
  • Loading branch information
@greghendershott
greghendershott committed Mar 21, 2023
1 parent 947d980 commit f872cb1
Show file tree
Hide file tree
Showing 3 changed files with 204 additions and 26 deletions.
110 changes: 102 additions & 8 deletions racket-xp.el
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
;;; racket-xp.el -*- lexical-binding: t -*-

;; Copyright (c) 2013-2021 by Greg Hendershott.
;; Copyright (c) 2013-2023 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.

;; Author: Greg Hendershott
Expand Down Expand Up @@ -581,8 +581,22 @@ If point is instead on a definition, then go to its first use."
(racket-xp--forward-use -1))

(defun racket-xp-rename ()
"Rename a local definition and its uses in the current file."
"Rename the identifier at point.
When pdb is available and finds rename sites, does a multi-file rename.
Otherwise does a rename only within the current file."
(interactive)
(let ((files-and-sites (racket--cmd/await nil
`(pdb-rename-sites
,(racket-file-name-front-to-back
(racket--buffer-file-name))
,(point)))))
(if files-and-sites
(racket-xp-rename-global files-and-sites)
(racket-xp-rename-local))))

(defun racket-xp-rename-local ()
(pcase-let*
(;; Try to get a def prop and a use prop at point
(def-prop (get-text-property (point) 'racket-xp-def))
Expand Down Expand Up @@ -623,6 +637,41 @@ If point is instead on a definition, then go to its first use."
(goto-char (marker-position point-marker))
(racket-xp-annotate)))

(defun racket-xp-rename-global (files-and-sites)
(let* ((new-id (read-from-minibuffer (format "Rename sites in %s file(s) to: "
(length files-and-sites)))))
(dolist (file-and-sites files-and-sites)
(let ((file (car file-and-sites))
(sites (cdr file-and-sites)))
(with-current-buffer (save-selected-window (find-file file))
(let ((point-marker (let ((m (make-marker)))
(set-marker m (point) (current-buffer))))
(marker-pairs (mapcar (lambda (site)
(let ((beg (make-marker))
(end (make-marker)))
(set-marker beg (car site) (current-buffer))
(set-marker end (cdr site) (current-buffer))
(cons beg end)))
sites)))
;; Don't let our after-change hook run until all changes are
;; made, otherwise check-syntax will find a syntax error.
(let ((inhibit-modification-hooks t))
(dolist (marker-pair marker-pairs)
(let ((beg (marker-position (car marker-pair)))
(end (marker-position (cdr marker-pair))))
(delete-region beg end)
(goto-char beg)
(insert new-id))))
(goto-char (marker-position point-marker))
;; Save buffer, so that other, requiring files won't have
;; errors when they are re-annotated.
(save-buffer)))))
;; Now that all files are saved, re-annotate all their buffers.
(dolist (file-and-sites files-and-sites)
(let ((file (car file-and-sites)))
(with-current-buffer (save-selected-window (find-file file))
(when racket-xp-mode (racket-xp-annotate)))))))

(defun racket--xp-forward-prop (prop amt)
"Move point to the next or previous occurrence of PROP, if any.
If moved, return the new position, else nil."
Expand Down Expand Up @@ -789,7 +838,25 @@ evaluation errors that won't be found merely from expansion -- or
(`(,path ,line ,col)
(list (xref-make str
(xref-make-file-location
(racket-file-name-back-to-front path) line col)))))))
(racket-file-name-back-to-front path) line col))))))
(_
(pcase (racket--cmd/await nil
`(pdb-use->def
,(racket-file-name-front-to-back
(racket--buffer-file-name))
,(point)))
(`(,path ,beg ,_end)
;; TODO: Should we have pdb also store/return line:col
;; coordinates? Meanwhile a bad hack.
(save-selected-window
(find-file path) ;; BAD
(save-excursion
(goto-char beg)
(list (xref-make str
(xref-make-file-location
(racket-file-name-back-to-front path)
(line-number-at-pos)
(current-column))))))))))
(pcase (get-text-property 0 'racket-xp-use str)
(`(,beg ,end)
(list
Expand Down Expand Up @@ -998,6 +1065,12 @@ manually."
(`(unused-require ,beg ,end)
(put-text-property beg end 'help-echo "unused require")
(racket--add-overlay beg end racket-xp-unused-face))
(`(doc ,beg ,end ,path ,anchor)
(add-text-properties
beg end
(list 'racket-xp-doc
(list (racket-file-name-back-to-front path) anchor))))
;; old/classic check-syntax
(`(def/uses ,def-beg ,def-end ,req ,id ,uses)
(let ((def-beg (copy-marker def-beg t))
(def-end (copy-marker def-end t))
Expand Down Expand Up @@ -1034,11 +1107,32 @@ manually."
beg end
(list 'racket-xp-visit
(list (racket-file-name-back-to-front path) subs ids))))
(`(doc ,beg ,end ,path ,anchor)
(add-text-properties
beg end
(list 'racket-xp-doc
(list (racket-file-name-back-to-front path) anchor))))))))
;; new pdb-backed check-syntax
(`(def-site ,def-beg ,def-end ,import-p ,uses)
(let ((def-beg (copy-marker def-beg t))
(def-end (copy-marker def-end t))
(uses (mapcar (lambda (use)
(mapcar (lambda (pos)
(copy-marker pos t))
use))
uses)))
(put-text-property (marker-position def-beg)
(marker-position def-end)
'racket-xp-def
(list (if import-p 'import 'local) "" uses))))
(`(use-site ,use-beg ,use-end ,import-p ,def-beg ,def-end)
(let ((def-beg (copy-marker def-beg t))
(def-end (copy-marker def-end t))
(use-beg (copy-marker use-beg t))
(use-end (copy-marker use-end t)))
(put-text-property (marker-position use-beg)
(marker-position use-end)
'racket-xp-use (list def-beg def-end))
(when import-p
(put-text-property (marker-position use-beg)
(marker-position use-end)
'racket-xp-visit
t))))))))

(defun racket--xp-clear (&optional only-errors-p)
(with-silent-modifications
Expand Down
6 changes: 4 additions & 2 deletions racket/command-server.rkt
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Copyright (c) 2013-2023 by Greg Hendershott.
;; SPDX-License-Identifier: GPL-3.0-or-later

#lang racket/base
Expand All @@ -20,7 +20,7 @@
"util.rkt")

(lazy-require
["commands/check-syntax.rkt" (check-syntax)]
["commands/check-syntax.rkt" (check-syntax pdb-use->def-command pdb-rename-sites-command)]
["commands/describe.rkt" (describe type)]
["commands/find-module.rkt" (find-module)]
["commands/help.rkt" (doc)]
Expand Down Expand Up @@ -142,6 +142,8 @@
[`(requires/find ,str) (libs-exporting-documented str)]
[`(doc-index-names) (doc-index-names)]
[`(doc-index-lookup ,str) (doc-index-lookup str)]
[`(pdb-use->def ,path, pos) (pdb-use->def-command path pos)]
[`(pdb-rename-sites ,path ,pos) (pdb-rename-sites-command path pos)]

;; Commands that MIGHT need a REPL session for context (e.g. its
;; namespace), if their first "how" argument is 'namespace.
Expand Down
114 changes: 98 additions & 16 deletions racket/commands/check-syntax.rkt
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Copyright (c) 2013-2023 by Greg Hendershott.
;; SPDX-License-Identifier: GPL-3.0-or-later

#lang racket/base
Expand All @@ -16,7 +16,9 @@
"../syntax.rkt"
"../util.rkt")

(provide check-syntax)
(provide check-syntax
pdb-use->def-command
pdb-rename-sites-command)

(module+ test
(require rackunit))
Expand Down Expand Up @@ -65,6 +67,85 @@
(current-memory-use))
(hash-remove! ht path-str))))))))

;;; pdb checked syntax (if available)

(define-values (pdb-check-syntax?
analyze-path
get-errors
get-annotations
get-completion-candidates
use->def
rename-sites)
(with-handlers ([exn:fail?
(λ (e)
(log-racket-mode-info "Using classic check-syntax:\n~a"
(exn-message e))
(values #f
void
void
void
void
void
void))])
(values #t
(dynamic-require 'pdb 'analyze-path)
(dynamic-require 'pdb 'get-errors)
(dynamic-require 'pdb 'get-annotations)
(dynamic-require 'pdb 'get-completion-candidates)
(dynamic-require 'pdb 'use->def)
(dynamic-require 'pdb 'rename-sites))))

(define (do-check-syntax path-str code-str)
((if pdb-check-syntax? do-pdb-check-syntax do-old-check-syntax)
path-str
code-str))

(define (do-pdb-check-syntax path-str code-str)
(define path (string->path path-str))
(with-time/log (format "analyze-path ~v" path-str)
(analyze-path path #:code code-str))
(define errors
(for/list ([e (in-list (get-errors path))])
(match-define (list beg end pstr msg) e)
(list 'error pstr beg end msg)))
(define annotations
(with-time/log "annotations"
(for/list ([a (in-list (get-annotations path))])
(match a
[(list 'mouse-over beg end s)
(list 'info beg end (car (mouse-over-set->result s)))]
[(list* 'doc-link more)
(list* 'doc more)]
[v v]))))
(define completions
(with-time/log "completions"
(sort (map symbol->string
(set->list (get-completion-candidates path)))
string<=?)))
(define imenu null) ;; TODO?
(if (null? errors)
(list 'check-syntax-ok
(cons 'completions completions)
(cons 'imenu imenu)
(cons 'annotations annotations))
(list 'check-syntax-errors
(cons 'errors errors)
(cons 'annotations annotations))))

(define (pdb-use->def-command path-str pos)
;; The front end xref system wants line:col not [beg end) span. :(
;; Maybe pdb should change to store those, also, for arrow ends?
;; Meanwhile the front end finds the line:col using find-file
;; and goto-char.
(and pdb-check-syntax?
(use->def (string->path path-str) pos)))

(define (pdb-rename-sites-command path-str pos)
(and pdb-check-syntax?
(rename-sites (string->path path-str) pos)))

;;; old/class check-syntax

;; Note: Instead of using the `show-content` wrapper, we give already
;; fully expanded syntax directly to `make-traversal`. Why? Expansion
;; can be slow. 1. We need exp stx for other purposes here. Dumb to
Expand All @@ -78,7 +159,7 @@
;; string->expanded-syntax uses a "call-with" "continuation style": it
;; sets parameters when calling the continuation function.]

(define (do-check-syntax path-str code-str)
(define (do-old-check-syntax path-str code-str)
(define path (string->path path-str))
(parameterize ([current-annotations (new annotations-collector%
[src path]
Expand Down Expand Up @@ -299,19 +380,6 @@
(for/list ([(beg/end vs) (in-dict im)])
(match-define (cons beg end) beg/end)
(list* sym (add1 beg) (add1 end) (proc vs))))
(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)])
(list ;im->list expects a list
(string-join (sort (set->list v) string<=?)
"; "))))
;; Append all and sort by `beg` position
(sort (append
defs/uses
Expand All @@ -337,6 +405,20 @@

(super-new)))

(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)])
(list ;im->list expects a list
(string-join (sort (set->list v) string<=?)
"; "))))

;; Typed Racket can report multiple errors. The protocol: it calls
;; error-display-handler for each one. There is a final, actual
;; exn:fail:syntax raised, but it's not useful for us: Although its
Expand Down

0 comments on commit f872cb1

Please sign in to comment.