adjust the interaction between online check syntax and the documentation

system to guarantee that killing online check syntax doesn't wedge the docs
information lookup process

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)

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))))

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) 

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))))