a0ef78e97b
can get "stale" and cause DrRacket to deadlock (this commit just sets up some stuff to make one fix possible, but that fix doesn't seem to be working, so the actual fix is disabled (see comment in commit))
80 lines
2.9 KiB
Racket
80 lines
2.9 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/place
|
|
"../../private/eval-helpers.rkt"
|
|
"traversals.rkt"
|
|
"local-member-names.rkt"
|
|
"intf.rkt"
|
|
"xref.rkt")
|
|
|
|
(provide go)
|
|
|
|
(define obj%
|
|
(class (annotations-mixin object%)
|
|
(init-field src orig-cust)
|
|
(define trace '())
|
|
|
|
(define-values (remote local) (place-channel))
|
|
(define table (make-hash))
|
|
|
|
;; the hope is that changing the custodian like this
|
|
;; shouldn't leak these threads, but it does seem to
|
|
;; so for now we don't use it
|
|
(parameterize (#;[current-custodian orig-cust])
|
|
(thread
|
|
(λ ()
|
|
(with-handlers ((exn:fail? (λ (x) (eprintf "online-comp.rkt: thread failed ~a\n" (exn-message x)))))
|
|
(let loop ()
|
|
(define id/name (place-channel-get local))
|
|
(define id (list-ref id/name 0))
|
|
(define name (list-ref id/name 1))
|
|
(define res ((hash-ref table id) name))
|
|
(place-channel-put local res))))))
|
|
|
|
(define/override (syncheck:find-source-object stx)
|
|
(and (equal? src (syntax-source stx))
|
|
src))
|
|
(define-syntax-rule
|
|
(log name)
|
|
(define/override (name . args)
|
|
(set! trace (cons (cons 'name args) trace))))
|
|
|
|
; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up
|
|
(log syncheck:add-mouse-over-status)
|
|
(log syncheck:add-arrow)
|
|
(log syncheck:add-tail-arrow)
|
|
(log syncheck:add-background-color)
|
|
(log syncheck:add-require-open-menu)
|
|
(log syncheck:add-docs-menu)
|
|
(log syncheck:add-jump-to-definition)
|
|
(define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?)
|
|
(define id (hash-count table))
|
|
(hash-set! table id dup-name?)
|
|
(set! trace (cons (list 'syncheck:add-rename-menu id-as-sym to-be-renamed/poss remote id)
|
|
trace)))
|
|
|
|
(define/public (get-trace) (reverse trace))
|
|
(super-new)))
|
|
|
|
(define (go expanded path the-source orig-cust)
|
|
(with-handlers ((exn:fail? (λ (x)
|
|
(printf "~a\n" (exn-message x))
|
|
(printf "---\n")
|
|
(for ([x (in-list
|
|
(continuation-mark-set->context
|
|
(exn-continuation-marks
|
|
x)))])
|
|
(printf " ~s\n" x))
|
|
(printf "===\n")
|
|
(raise x))))
|
|
(define obj (new obj%
|
|
[src the-source]
|
|
[orig-cust orig-cust]))
|
|
(define-values (expanded-expression expansion-completed)
|
|
(make-traversal (current-namespace)
|
|
(get-init-dir path)))
|
|
(parameterize ([current-annotations obj])
|
|
(expanded-expression expanded)
|
|
(expansion-completed))
|
|
(send obj get-trace)))
|