diff --git a/collects/drracket/private/syncheck/intf.rkt b/collects/drracket/private/syncheck/intf.rkt index 7c4cc0b744..f544cc87ca 100644 --- a/collects/drracket/private/syncheck/intf.rkt +++ b/collects/drracket/private/syncheck/intf.rkt @@ -1,7 +1,5 @@ #lang racket/base (require racket/class - racket/promise - setup/xref "local-member-names.rkt") (define syncheck-annotations<%> @@ -33,17 +31,6 @@ ;; parameters to all of the functions (define current-annotations (make-parameter #f)) -(define xref (if (getenv "PLTDRXREFDELAY") - (begin - (printf "PLTDRXREFDELAY: using plain delay\n") - (delay (begin - (printf "PLTDRXREFDELAY: loading xref\n") - (begin0 - (load-collections-xref) - (printf "PLTDRXREFDELAY: loaded xref\n"))))) - (delay/idle (load-collections-xref)))) -(define (get-xref) (force xref)) - (define annotations-mixin (mixin () (syncheck-annotations<%>) (define/public (syncheck:find-source-object stx) #f) @@ -64,5 +51,4 @@ (provide syncheck-text<%> syncheck-annotations<%> current-annotations - annotations-mixin - get-xref) + annotations-mixin) diff --git a/collects/drracket/private/syncheck/online-comp.rkt b/collects/drracket/private/syncheck/online-comp.rkt index 79bacca887..41e7c84fa6 100644 --- a/collects/drracket/private/syncheck/online-comp.rkt +++ b/collects/drracket/private/syncheck/online-comp.rkt @@ -4,6 +4,7 @@ "traversals.rkt" "local-member-names.rkt" "intf.rkt" + "xref.rkt" framework/preferences) (preferences:set-default 'framework:white-on-black? #f boolean?) @@ -52,10 +53,9 @@ (define/public (get-trace) (reverse trace)) (super-new))) -(void (get-xref)) ;; do this now so that it doesn't get killed during a call to 'go' - (define (go expanded path the-source) - (with-handlers ((exn:fail? (λ (x) + (time + (with-handlers ((exn:fail? (λ (x) (printf "~a\n" (exn-message x)) (printf "---\n") (for ([x (in-list @@ -75,4 +75,4 @@ (parameterize ([current-annotations obj]) (expanded-expression expanded) (expansion-completed)) - (send obj get-trace))) + (send obj get-trace)))) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index 4b09f1ac61..5db4df5c8d 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -5,15 +5,15 @@ "local-member-names.rkt" "annotate.rkt" "contract-traversal.rkt" + "xref.rkt" string-constants racket/unit racket/set racket/class racket/list syntax/boundmap - scribble/xref - scribble/manual-struct - framework/preferences) + framework/preferences + scribble/manual-struct) (provide make-traversal) @@ -1038,51 +1038,46 @@ ;; document-variable : stx[identifier,original] phase-level -> void (define (document-variable stx phase-level) - (let ([defs-text (current-annotations)]) - (when defs-text - (let ([binding-info (identifier-binding stx phase-level)]) - (when (and (pair? binding-info) - (syntax-position stx) - (syntax-span stx)) - (let* ([start (- (syntax-position stx) 1)] - [fin (+ start (syntax-span stx))] - [source-editor (find-source-editor stx)]) - (when source-editor - (let ([xref (get-xref)]) - (when xref - (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)]) - (when definition-tag - (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) - (when path - (let ([index-entry (xref-tag->index-entry xref definition-tag)]) - (when index-entry - (send defs-text syncheck:add-background-color - source-editor start fin - (if (preferences:get 'framework:white-on-black?) - "darkgreen" - "palegreen")) - (send defs-text syncheck:add-docs-menu - source-editor - start - fin - (syntax-e stx) - (build-docs-label (entry-desc index-entry)) - path - tag)))))))))))))))) + (define defs-text (current-annotations)) + (when defs-text + (define binding-info (identifier-binding stx phase-level)) + (when (and (pair? binding-info) + (syntax-position stx) + (syntax-span stx)) + (define start (- (syntax-position stx) 1)) + (define fin (+ start (syntax-span stx))) + (define source-editor (find-source-editor stx)) + (when source-editor + (define info (get-index-entry-info binding-info)) + (when info + (define-values (entry-desc path tag) (apply values info)) + (send defs-text syncheck:add-background-color + source-editor start fin + (if (preferences:get 'framework:white-on-black?) + "darkgreen" + "palegreen")) + (send defs-text syncheck:add-docs-menu + source-editor + start + fin + (syntax-e stx) + (build-docs-label entry-desc) + path + tag)))))) - (define (build-docs-label desc) - (let ([libs (exported-index-desc-from-libs desc)]) + (define (build-docs-label entry-desc) + (let ([libs (exported-index-desc-from-libs entry-desc)]) (cond [(null? libs) (format (string-constant cs-view-docs) - (exported-index-desc-name desc))] + (exported-index-desc-name entry-desc))] [else (format (string-constant cs-view-docs-from) (format (string-constant cs-view-docs) - (exported-index-desc-name desc)) + (exported-index-desc-name entry-desc)) (apply string-append (add-between (map (λ (x) (format "~s" x)) libs) diff --git a/collects/drracket/private/syncheck/xref.rkt b/collects/drracket/private/syncheck/xref.rkt new file mode 100644 index 0000000000..8451d3161e --- /dev/null +++ b/collects/drracket/private/syncheck/xref.rkt @@ -0,0 +1,51 @@ +#lang racket/base +(require setup/xref + racket/promise + scribble/xref + scribble/manual-struct) +(provide get-index-entry-info) + +(define delayed-xref + (if (getenv "PLTDRXREFDELAY") + (begin + (printf "PLTDRXREFDELAY: using plain delay\n") + (delay (begin + (printf "PLTDRXREFDELAY: loading xref\n") + (begin0 + (load-collections-xref) + (printf "PLTDRXREFDELAY: loaded xref\n"))))) + (delay/idle (load-collections-xref)))) + +(define req-chan (make-channel)) + +(define thd + (thread + (λ () + (let loop () + (define-values (binding-info resp-chan nack-evt) (apply values (channel-get req-chan))) + (define xref (force delayed-xref)) + (define resp + (and xref + (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)]) + (and definition-tag + (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) + (and path + (let ([index-entry (xref-tag->index-entry xref definition-tag)]) + (and index-entry + (list (entry-desc index-entry) + path + tag))))))))) + (sync (channel-put-evt resp-chan resp) + nack-evt) + (loop))))) + +;; this function is called from a thread that might be killed +;; (but the body of this module is run in a context where it is +;; guaranteed that that custodian doesn't get shut down) +(define (get-index-entry-info binding-info) + (sync + (nack-guard-evt + (λ (nack-evt) + (define resp-chan (make-channel)) + (channel-put req-chan (list binding-info resp-chan nack-evt)) + resp-chan))))