suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust check syntax so it can show info before expansion completes

Browse Source 
and sometimes when there are syntax errors raised

In more detail, rearrange online check syntax's internal plumbing
so that syntax objects can be handed to check syntax at any point
(via a special log message, see the changes to the docs)
not just when expansion is finished

Use this in TR to get check syntax information even when there is
a type error (and also get the check syntax information processing
started before type checking starts (altho this isn't running
in a separate place, so there is no new parallelism here))
This commit is contained in:
Robby Findler 2013-09-30 15:41:18 -05:00
parent c7d688df22
commit 09920bd8ce
11 changed files with 576 additions and 211 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
pkgs/drracket-pkgs/drracket-plugin-lib/drracket/private/drsig.rkt
View File

@ -120,10 +120,15 @@
(define-signature drracket:module-language-tools^ extends drracket:module-language-tools-cm^ (define-signature drracket:module-language-tools^ extends drracket:module-language-tools-cm^
(add-opt-out-toolbar-button (add-opt-out-toolbar-button
add-online-expansion-handler add-online-expansion-handler
register-online-expansion-pref)) add-online-expansion-monitor
register-online-expansion-pref
done
done?
start
start?))
(define-signature drracket:module-language-tools/int^ extends drracket:module-language-tools^ (define-signature drracket:module-language-tools/int^ extends drracket:module-language-tools^
(get-online-expansion-pref-funcs (get-online-expansion-pref-funcs
(struct online-expansion-handler (mod-path id local-handler)) (struct online-expansion-handler (mod-path id local-handler monitor?))
get-online-expansion-handlers get-online-expansion-handlers
no-more-online-expansion-handlers)) no-more-online-expansion-handlers))

7
pkgs/drracket-pkgs/drracket/drracket/HISTORY.txt
View File

@ -1,3 +1,10 @@
------------------------------
Version 6.1
------------------------------
. changed the online expansion handler machinery so that
the handlers receive exceptions when expansion raises one
------------------------------ ------------------------------
Version 6.0 Version 6.0
------------------------------ ------------------------------

60
pkgs/drracket-pkgs/drracket/drracket/private/expanding-place.rkt
View File

@ -9,10 +9,13 @@
(struct exn-info (str src-vecs exn-stack missing-mods) #:prefab) (struct exn-info (str src-vecs exn-stack missing-mods) #:prefab)
(struct job (cust response-pc working-thd stop-watching-abnormal-termination)) (struct job (cust working-thd stop-watching-abnormal-termination))
;; key : any (used by equal? for comparision, but back in the main place) ;; key : any (used by equal? for comparision, but back in the main place)
(struct handler (key proc)) ;; monitor-pc : (or/c #f place-channel)
;; -- #f means a "end of expansion" notification,
;; -- place-channel means to notify at the beginning
(struct handler (key monitor-pc proc) #:transparent)
(define handlers '()) (define handlers '())
(define module-language-parallel-lock-client (define module-language-parallel-lock-client
@ -39,10 +42,15 @@
(current-custodian))) (current-custodian)))
;; get the handlers in a second message ;; get the handlers in a second message
(set! handlers (for/list ([lst (place-channel-get p)]) (set! handlers
(define file (list-ref lst 0)) (filter
(define id (list-ref lst 1)) values
(handler lst (dynamic-require file id)))) (for/list ([lst (place-channel-get p)])
(define file (list-ref lst 0))
(define id (list-ref lst 1))
(define monitor-pc (list-ref lst 2))
(handler (list file id) monitor-pc (dynamic-require file id)))))
(let loop ([current-job #f] (let loop ([current-job #f]
;; the old-registry argument holds on to the namespace-module-registry ;; the old-registry argument holds on to the namespace-module-registry
;; from a previous run in order to keep entries in the bytecode cache ;; from a previous run in order to keep entries in the bytecode cache
@ -100,6 +108,23 @@
(parameterize ([current-custodian cust]) (parameterize ([current-custodian cust])
(thread (thread
(λ () (λ ()
(ep-log-info "expanding-place.rkt: 00 starting monitors")
(for ([handler (in-list handlers)])
(define pc (handler-monitor-pc handler))
(when pc
(define (failed x)
(eprintf "starting monitor ~s failed:\n" (handler-key handler))
((error-display-handler) (exn-message x) x))
(with-handlers ([exn:fail? failed])
(define (send-back val)
(place-channel-put
response-pc
(vector 'monitor-message
(handler-key handler)
val)))
((handler-proc handler) send-back path the-source orig-cust))))
(ep-log-info "expanding-place.rkt: 01 starting thread") (ep-log-info "expanding-place.rkt: 01 starting thread")
(define sema (make-semaphore 0)) (define sema (make-semaphore 0))
(ep-log-info "expanding-place.rkt: 02 setting basic parameters") (ep-log-info "expanding-place.rkt: 02 setting basic parameters")
@ -186,12 +211,14 @@
(place-channel-put pc-status-expanding-place 'finished-expansion) (place-channel-put pc-status-expanding-place 'finished-expansion)
(ep-log-info "expanding-place.rkt: 10 expanded") (ep-log-info "expanding-place.rkt: 10 expanded")
(define handler-results (define handler-results
(for/list ([handler (in-list handlers)]) (for/list ([handler (in-list handlers)]
(list (handler-key handler) #:unless (handler-monitor-pc handler))
((handler-proc handler) expanded (define proc-res
path ((handler-proc handler) expanded
the-source path
orig-cust)))) the-source
orig-cust))
(list (handler-key handler) proc-res)))
(ep-log-info "expanding-place.rkt: 11 handlers finished") (ep-log-info "expanding-place.rkt: 11 handlers finished")
(parameterize ([current-custodian orig-cust]) (parameterize ([current-custodian orig-cust])
@ -250,6 +277,13 @@
(λ (exn+loaded-paths) (λ (exn+loaded-paths)
(place-channel-put pc-status-expanding-place 'exn-raised) (place-channel-put pc-status-expanding-place 'exn-raised)
(define main-exn (list-ref exn+loaded-paths 0)) (define main-exn (list-ref exn+loaded-paths 0))
;; inform the handlers that an exn has been raised
(when (exn? main-exn)
(for ([handler (in-list handlers)]
#:unless (handler-monitor-pc handler))
((handler-proc handler) main-exn path the-source orig-cust)))
(define exn-type (define exn-type
(cond (cond
[(exn:access? main-exn) [(exn:access? main-exn)
@ -318,7 +352,7 @@
exn-infos exn-infos
(list-ref exn+loaded-paths 1))))))))) (list-ref exn+loaded-paths 1)))))))))
(job cust response-pc working-thd stop-watching-abnormal-termination)) (job cust working-thd stop-watching-abnormal-termination))
(define (catch-and-log port sema) (define (catch-and-log port sema)
(let loop () (let loop ()

222
pkgs/drracket-pkgs/drracket/drracket/private/module-language-tools.rkt
View File

@ -3,6 +3,7 @@
(require mrlib/switchable-button (require mrlib/switchable-button
mrlib/bitmap-label mrlib/bitmap-label
racket/contract racket/contract
racket/place
framework framework
racket/unit racket/unit
racket/class racket/class
@ -32,7 +33,8 @@
(define-local-member-name (define-local-member-name
set-lang-toolbar-buttons set-lang-toolbar-buttons
get-lang-toolbar-buttons) get-lang-toolbar-buttons
get-online-expansion-monitor-pcs)
(define tab-mixin (define tab-mixin
(mixin (drracket:unit:tab<%>) (drracket:module-language-tools:tab<%>) (mixin (drracket:unit:tab<%>) (drracket:module-language-tools:tab<%>)
@ -160,21 +162,26 @@
(define/public (move-to-new-language) (define/public (move-to-new-language)
(let* ([port (open-input-text-editor this)] (let* ([port (open-input-text-editor this)]
;; info-result : (or/c #f [#lang without a known language] ;; info-result :
;; (vector <get-info-proc>) [no #lang line, so we use the '#lang racket' info proc] ;; (or/c #f [#lang without a known language]
;; <get-info-proc> [the get-info proc for the program in the definitions] ;; (vector <get-info-proc>)
[info-result (with-handlers ((exn:fail? ;; [no #lang line, so we use the '#lang racket' info proc]
(λ (x) ;; <get-info-proc>) [the get-info proc for the program in the definitions]
(log-debug (format "DrRacket: error duing call to read-language for ~a:\n ~a" [info-result
(or (send this get-filename) "<<unsaved file>>") (with-handlers ([exn:fail?
(regexp-replace* #rx"\n(.)" (exn-message x) "\n\\1 "))) (λ (x)
#f))) (log-debug
(read-language (format
port "DrRacket: error duing call to read-language for ~a:\n ~a"
(lambda () (or (send this get-filename) "<<unsaved file>>")
;; fall back to whatever #lang racket does if (regexp-replace* #rx"\n(.)" (exn-message x) "\n\\1 ")))
;; we don't have a #lang line present in the file #f)])
(vector (read-language (open-input-string "#lang racket"))))))]) (read-language
port
(lambda ()
;; fall back to whatever #lang racket does if
;; we don't have a #lang line present in the file
(vector (read-language (open-input-string "#lang racket"))))))])
; sometimes I get eof here, but I don't know why and can't seem to ; sometimes I get eof here, but I don't know why and can't seem to
;; make it happen outside of DrRacket ;; make it happen outside of DrRacket
@ -204,28 +211,35 @@
(get-lang-name pos)) (get-lang-name pos))
'drracket/private/module-language-tools)) 'drracket/private/module-language-tools))
(define lang-wants-big-defs/ints-labels? (and info-proc (info-proc 'drracket:show-big-defs/ints-labels #f))) (define lang-wants-big-defs/ints-labels?
(and info-proc (info-proc 'drracket:show-big-defs/ints-labels #f)))
(set-lang-wants-big-defs/ints-labels? lang-wants-big-defs/ints-labels?) (set-lang-wants-big-defs/ints-labels? lang-wants-big-defs/ints-labels?)
(send (send (get-tab) get-ints) set-lang-wants-big-defs/ints-labels? lang-wants-big-defs/ints-labels?) (send (send (get-tab) get-ints) set-lang-wants-big-defs/ints-labels?
lang-wants-big-defs/ints-labels?)
(when info-result (when info-result
(register-new-buttons (register-new-buttons
(ctc-on-info-proc-result (or/c #f (listof (or/c (list/c string? (ctc-on-info-proc-result
(is-a?/c bitmap%) (or/c #f (listof (or/c (list/c string?
(-> (is-a?/c drracket:unit:frame<%>) any)) (is-a?/c bitmap%)
(list/c string? (-> (is-a?/c drracket:unit:frame<%>) any))
(is-a?/c bitmap%) (list/c string?
(-> (is-a?/c drracket:unit:frame<%>) any) (is-a?/c bitmap%)
(or/c real? #f))))) (-> (is-a?/c drracket:unit:frame<%>) any)
(or (info-proc 'drracket:toolbar-buttons #f) (or/c real? #f)))))
(info-proc 'drscheme:toolbar-buttons #f))) (or (info-proc 'drracket:toolbar-buttons #f)
(ctc-on-info-proc-result (or/c #f (listof symbol?)) (info-proc 'drscheme:toolbar-buttons #f)))
(or (info-proc 'drracket:opt-out-toolbar-buttons '()) (ctc-on-info-proc-result
(info-proc 'drscheme:opt-out-toolbar-buttons '()))))))))) (or/c #f (listof symbol?))
(or (info-proc 'drracket:opt-out-toolbar-buttons '())
(info-proc 'drscheme:opt-out-toolbar-buttons '())))))))))
(define/private (register-new-buttons buttons opt-out-ids) (define/private (register-new-buttons buttons opt-out-ids)
;; cleaned-up-buttons : (listof (list/c string? (is-a?/c bitmap%) (-> (is-a?/c drracket:unit:frame<%>) any) (or/c real? #f))) ;; cleaned-up-buttons : (listof (list/c string?
;; (is-a?/c bitmap%)
;; (-> (is-a?/c drracket:unit:frame<%>) any)
;; (or/c real? #f)))
(define cleaned-up-buttons (define cleaned-up-buttons
(cond (cond
[(not buttons) '()] [(not buttons) '()]
@ -234,46 +248,47 @@
(if (= 3 (length button)) (if (= 3 (length button))
(append button (list #f)) (append button (list #f))
button))])) button))]))
(let* ([tab (get-tab)] (define tab (get-tab))
[frame (send tab get-frame)]) (define frame (send tab get-frame))
(send frame when-initialized (send frame when-initialized
(λ () (λ ()
(send frame begin-container-sequence) (send frame begin-container-sequence)
;; avoid any time with both sets of buttons in the panel so the window doesn't get too wide ;; avoid any time with both sets of buttons in the
(send (send frame get-toolbar-button-panel) change-children (λ (prev) '())) ;; panel so the window doesn't get too wide
(send (send frame get-toolbar-button-panel) change-children (λ (prev) '()))
(let ([directly-specified-buttons
(map (λ (button-spec) (define directly-specified-buttons
(new switchable-button% (map (λ (button-spec)
[label (list-ref button-spec 0)] (new switchable-button%
[bitmap (list-ref button-spec 1)] [label (list-ref button-spec 0)]
[parent (send frame get-toolbar-button-panel)] [bitmap (list-ref button-spec 1)]
[callback [parent (send frame get-toolbar-button-panel)]
(lambda (button) [callback
((list-ref button-spec 2) frame))])) (lambda (button)
cleaned-up-buttons)] ((list-ref button-spec 2) frame))]))
[directly-specified-button-numbers (map (λ (button-spec) (list-ref button-spec 3)) cleaned-up-buttons))
cleaned-up-buttons)] (define directly-specified-button-numbers
[opt-out-buttons+numbers (map (λ (button-spec) (list-ref button-spec 3))
(if (eq? opt-out-ids #f) cleaned-up-buttons))
'() (define opt-out-buttons+numbers
(map (cond
(λ (opt-out-toolbar-button) [(eq? opt-out-ids #f) '()]
(list ((opt-out-toolbar-button-make-button opt-out-toolbar-button) [else
frame (for/list ([opt-out-toolbar-button (in-list opt-out-toolbar-buttons)]
(send frame get-toolbar-button-panel)) #:unless (member
(opt-out-toolbar-button-number opt-out-toolbar-button))) (opt-out-toolbar-button-id opt-out-toolbar-button)
(filter (λ (opt-out-toolbar-button) opt-out-ids))
(not (member (opt-out-toolbar-button-id opt-out-toolbar-button) (list ((opt-out-toolbar-button-make-button opt-out-toolbar-button)
opt-out-ids))) frame
opt-out-toolbar-buttons)))]) (send frame get-toolbar-button-panel))
(send tab set-lang-toolbar-buttons (opt-out-toolbar-button-number opt-out-toolbar-button)))]))
(append directly-specified-buttons (send tab set-lang-toolbar-buttons
(map (λ (x) (list-ref x 0)) opt-out-buttons+numbers)) (append directly-specified-buttons
(append directly-specified-button-numbers (map (λ (x) (list-ref x 0)) opt-out-buttons+numbers))
(map (λ (x) (list-ref x 1)) opt-out-buttons+numbers)))) (append directly-specified-button-numbers
(send frame end-container-sequence))))) (map (λ (x) (list-ref x 1)) opt-out-buttons+numbers)))
(send frame end-container-sequence))))
(inherit get-text) (inherit get-text)
(define/private (get-lang-name pos) (define/private (get-lang-name pos)
@ -289,6 +304,21 @@
(define/private (clear-things-out) (define/private (clear-things-out)
(send (get-tab) set-lang-toolbar-buttons '() '())) (send (get-tab) set-lang-toolbar-buttons '() '()))
;; online-expansion-monitor-table : hash[(cons mod-path id) -o> (cons/c local-pc remote-pc)]
(define online-expansion-monitor-table (make-hash))
(define/public (get-online-expansion-monitor-pcs an-online-expansion-handler)
(define key (cons (online-expansion-handler-mod-path an-online-expansion-handler)
(online-expansion-handler-id an-online-expansion-handler)))
(define old (hash-ref online-expansion-monitor-table key #f))
(cond
[old
(values (car old) (cdr old))]
[else
(define-values (local-pc remote-pc) (place-channel))
(hash-set! key (cons local-pc remote-pc))
(values local-pc remote-pc)]))
(define/augment (after-set-next-settings settings) (define/augment (after-set-next-settings settings)
(update-in-module-language? (update-in-module-language?
(is-a? (drracket:language-configuration:language-settings-language settings) (is-a? (drracket:language-configuration:language-settings-language settings)
@ -302,9 +332,20 @@
(define no-more-online-expansion-handlers? #f) (define no-more-online-expansion-handlers? #f)
(define (no-more-online-expansion-handlers) (set! no-more-online-expansion-handlers? #t)) (define (no-more-online-expansion-handlers) (set! no-more-online-expansion-handlers? #t))
(struct online-expansion-handler (mod-path id local-handler)) (define-values (done done?)
(let ()
(struct done ())
(values (done) done?)))
(define-values (start start?)
(let ()
(struct start ())
(values (start) start?)))
;; mod-path : module-path?
;; id : symbol?
;; local-handler : ... -> ...
(struct online-expansion-handler (mod-path id local-handler monitor?))
(define online-expansion-handlers '()) (define online-expansion-handlers '())
(define (get-online-expansion-handlers) (define (get-online-expansion-handlers)
(cond (cond
[no-more-online-expansion-handlers? [no-more-online-expansion-handlers?
online-expansion-handlers] online-expansion-handlers]
@ -312,15 +353,32 @@
(error 'get-online-expansion-handlers (error 'get-online-expansion-handlers
"online-expansion-handlers can still be registered")])) "online-expansion-handlers can still be registered")]))
(define (add-online-expansion-handler mod-path id local-handler) (define (add-online-expansion-handler mod-path id local-handler)
(cond (check-bad-registration 'add-online-expansion-handler mod-path id local-handler)
[no-more-online-expansion-handlers? (set! online-expansion-handlers
(error 'add-online-expansion-handler (cons (online-expansion-handler mod-path id local-handler #f)
"no more online-expansion-handlers can be registered; got ~e ~e ~e" online-expansion-handlers)))
mod-path id local-handler)]
[else (define (add-online-expansion-monitor mod-path id local-handler)
(set! online-expansion-handlers (check-bad-registration 'add-online-expansion-monitor mod-path id local-handler)
(cons (online-expansion-handler mod-path id local-handler) (set! online-expansion-handlers
online-expansion-handlers))])) (cons (online-expansion-handler mod-path id local-handler #t)
online-expansion-handlers)))
(define (check-bad-registration who mod-path id local-handler)
(when no-more-online-expansion-handlers?
(error who
"no more online-expansion-handlers can be registered; got ~e ~e ~e"
mod-path id local-handler))
(for ([handler (in-list online-expansion-handlers)])
(when (and (equal? (online-expansion-handler-mod-path handler) mod-path)
(equal? (online-expansion-handler-id handler) id))
(error who
(string-append
"already registered a handler with the same mod-path and id\n"
" mod-path: ~e\n"
" id: ~e")
mod-path
id))))
(define online-expansion-pref-funcs '()) (define online-expansion-pref-funcs '())
(define (get-online-expansion-pref-funcs) online-expansion-pref-funcs) (define (get-online-expansion-pref-funcs) online-expansion-pref-funcs)

76
pkgs/drracket-pkgs/drracket/drracket/private/module-language.rkt
View File

@ -10,6 +10,7 @@
racket/math racket/math
racket/match racket/match
racket/set racket/set
racket/place
racket/gui/base racket/gui/base
compiler/embed compiler/embed
compiler/cm compiler/cm
@ -132,6 +133,7 @@
(define default-enforce-module-constants #t) (define default-enforce-module-constants #t)
(define (get-default-auto-text) (preferences:get 'drracket:module-language:auto-text)) (define (get-default-auto-text) (preferences:get 'drracket:module-language:auto-text))
;; module-mixin : (implements drracket:language:language<%>) ;; module-mixin : (implements drracket:language:language<%>)
;; -> (implements drracket:language:language<%>) ;; -> (implements drracket:language:language<%>)
(define (module-mixin %) (define (module-mixin %)
@ -2122,7 +2124,9 @@
(module-language-settings->prefab-module-settings settings) (module-language-settings->prefab-module-settings settings)
(λ (res) (oc-finished res)) (λ (res) (oc-finished res))
(λ (a b) (oc-status-message a b)) (λ (a b) (oc-status-message a b))
(get-currently-open-files))] (λ (key val) (oc-monitor-value key val))
(get-currently-open-files)
(send dirty/pending-tab get-defs))]
[else [else
(line-of-interest) (line-of-interest)
(send dirty/pending-tab set-oc-status (send dirty/pending-tab set-oc-status
@ -2133,7 +2137,7 @@
#f)))) #f))))
(oc-maybe-start-something)]))) (oc-maybe-start-something)])))
(define/oc-log (oc-finished res) (define/oc-log (oc-finished res)
(define-values (running-tab dirty/pending-tab dirty-tabs clean-tabs) (get-current-oc-state)) (define-values (running-tab dirty/pending-tab dirty-tabs clean-tabs) (get-current-oc-state))
(when running-tab (when running-tab
(cond (cond
@ -2148,9 +2152,15 @@
(list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h) (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h)
(drracket:module-language-tools:online-expansion-handler-id o-e-h))) (drracket:module-language-tools:online-expansion-handler-id o-e-h)))
(when (equal? this-key that-key) (when (equal? this-key that-key)
((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h) (cond
(send running-tab get-defs) [(drracket:module-language-tools:online-expansion-handler-monitor? o-e-h)
val)))) ((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h)
(send running-tab get-defs)
drracket:module-language-tools:done)]
[else
((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h)
(send running-tab get-defs)
val)]))))
(send running-tab set-oc-status (clean #f #f)) (send running-tab set-oc-status (clean #f #f))
(send running-tab set-dep-paths (list->set (vector-ref res 2)) #f)] (send running-tab set-dep-paths (list->set (vector-ref res 2)) #f)]
@ -2170,6 +2180,19 @@
(line-of-interest) (line-of-interest)
(send running-tab set-oc-status (running sym str)))) (send running-tab set-oc-status (running sym str))))
(define/oc-log (oc-monitor-value key val)
(define-values (running-tab dirty/pending-tab dirty-tabs clean-tabs) (get-current-oc-state))
(when running-tab
(line-of-interest)
(for ([handler (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
(when (equal? (list (drracket:module-language-tools:online-expansion-handler-mod-path handler)
(drracket:module-language-tools:online-expansion-handler-id handler))
key)
(line-of-interest)
((drracket:module-language-tools:online-expansion-handler-local-handler handler)
(send running-tab get-defs)
val)))))
;; get-focus-tab : -> (or/c tab #f) ;; get-focus-tab : -> (or/c tab #f)
(define (get-focus-tab) (define (get-focus-tab)
(define tlw (get-top-level-focus-window)) (define tlw (get-top-level-focus-window))
@ -2203,7 +2226,9 @@
prefab-module-settings prefab-module-settings
show-results show-results
tell-the-tab-show-bkg-running tell-the-tab-show-bkg-running
currently-open-files) monitor-status
currently-open-files
defs)
(unless expanding-place (unless expanding-place
(set! expanding-place (dynamic-place expanding-place.rkt 'start)) (set! expanding-place (dynamic-place expanding-place.rkt 'start))
(place-channel-put expanding-place module-language-compile-lock) (place-channel-put expanding-place module-language-compile-lock)
@ -2211,7 +2236,15 @@
expanding-place expanding-place
(for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))]) (for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
(list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h) (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h)
(drracket:module-language-tools:online-expansion-handler-id o-e-h))))) (drracket:module-language-tools:online-expansion-handler-id o-e-h)
(drracket:module-language-tools:online-expansion-handler-monitor? o-e-h)))))
(for ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
(when (drracket:module-language-tools:online-expansion-handler-monitor? o-e-h)
((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h)
defs
drracket:module-language-tools:start)))
(set-pending-thread (set-pending-thread
tell-the-tab-show-bkg-running tell-the-tab-show-bkg-running
(thread (λ () (thread (λ ()
@ -2239,14 +2272,27 @@
(pending-tell-the-tab-show-bkg-running (pending-tell-the-tab-show-bkg-running
'finished-expansion 'finished-expansion
sc-online-expansion-running))))))) sc-online-expansion-running)))))))
(define res (place-channel-get pc-out))
(queue-callback ;; this loop catches all responses but handles the monitor response
(λ () ;; response here and keeps waiting for the actual result in that case.
(when (eq? us pending-thread) (let loop ()
(set-pending-thread #f #f)) (define res (place-channel-get pc-out))
(when (getenv "PLTDRPLACEPRINT") (cond
(printf "PLTDRPLACEPRINT: got results back from the place\n")) [(equal? (vector-ref res 0) 'monitor-message)
(show-results res))))))) (queue-callback
(λ ()
(when (getenv "PLTDRPLACEPRINT")
(printf "PLTDRPLACEPRINT: got monitor result back from the place\n"))
(monitor-status (vector-ref res 1) (vector-ref res 2))))
(loop)]
[else
(queue-callback
(λ ()
(when (eq? us pending-thread)
(set-pending-thread #f #f))
(when (getenv "PLTDRPLACEPRINT")
(printf "PLTDRPLACEPRINT: got results back from the place\n"))
(show-results res)))]))))))
(define (stop-place-running) (define (stop-place-running)
(when expanding-place (when expanding-place

268
pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt
View File

@ -262,6 +262,13 @@ If the namespace does not, they are colored the unbound color.
(define (get-untacked-brush white-on-black?) (define (get-untacked-brush white-on-black?)
(send the-brush-list find-or-create-brush "WHITE" 'solid)) (send the-brush-list find-or-create-brush "WHITE" 'solid))
(define-local-member-name
reset-previous-check-syntax-information
get-next-trace-refresh?
set-next-trace-refresh
set-replay-state
get-replay-state)
;; clearing-text-mixin : (mixin text%) ;; clearing-text-mixin : (mixin text%)
;; overrides methods that make sure the arrows go away appropriately. ;; overrides methods that make sure the arrows go away appropriately.
;; adds a begin/end-edit-sequence to the insertion and deletion ;; adds a begin/end-edit-sequence to the insertion and deletion
@ -552,9 +559,11 @@ If the namespace does not, they are colored the unbound color.
(define/private (find-poss text left-pos right-pos) (define/private (find-poss text left-pos right-pos)
(send text position-location left-pos xlb ylb #t) (send text position-location left-pos xlb ylb #t)
(send text position-location right-pos xrb yrb #f) (send text position-location right-pos xrb yrb #f)
(let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location
(unbox xlb) (unbox ylb))]
[(xl yl) (dc-location-to-editor-location xl-off yl-off)] [(xl yl) (dc-location-to-editor-location xl-off yl-off)]
[(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] [(xr-off yr-off) (send text editor-location-to-dc-location
(unbox xrb) (unbox yrb))]
[(xr yr) (dc-location-to-editor-location xr-off yr-off)]) [(xr yr) (dc-location-to-editor-location xr-off yr-off)])
(values (/ (+ xl xr) 2) (values (/ (+ xl xr) 2)
(/ (+ yl yr) 2)))) (/ (+ yl yr) 2))))
@ -626,13 +635,18 @@ If the namespace does not, they are colored the unbound color.
(define ((make-require-open-menu file) menu) (define ((make-require-open-menu file) menu)
(define-values (base name dir?) (split-path file)) (define-values (base name dir?) (split-path file))
(new menu-item% (new menu-item%
(label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) (label (fw:gui-utils:format-literal-label
(string-constant cs-open-file) (path->string name)))
(parent menu) (parent menu)
(callback (λ (x y) (fw:handler:edit-file file)))) (callback (λ (x y) (fw:handler:edit-file file))))
(void)) (void))
(syncheck:add-menu text start-pos end-pos #f (make-require-open-menu file))) (syncheck:add-menu text start-pos end-pos #f (make-require-open-menu file)))
(define/public (syncheck:add-docs-menu text start-pos end-pos id the-label path definition-tag tag) (define/public (syncheck:add-docs-menu text start-pos end-pos id
the-label
path
definition-tag
tag)
(define (visit-docs-url) (define (visit-docs-url)
(define url (path->url path)) (define url (path->url path))
(define url2 (if tag (define url2 (if tag
@ -659,7 +673,8 @@ If the namespace does not, they are colored the unbound color.
(define/public (syncheck:add-definition-target source start-pos end-pos id mods) (define/public (syncheck:add-definition-target source start-pos end-pos id mods)
(hash-set! definition-targets (list id mods) (list source start-pos end-pos))) (hash-set! definition-targets (list id mods) (list source start-pos end-pos)))
;; syncheck:find-definition-target : sym (listof sym) -> (or/c (list/c text number number) #f) ;; syncheck:find-definition-target
;; : sym (listof sym) -> (or/c (list/c text number number) #f)
(define/public (syncheck:find-definition-target id mods) (define/public (syncheck:find-definition-target id mods)
(hash-ref definition-targets (list id mods) #f)) (hash-ref definition-targets (list id mods) #f))
@ -702,7 +717,8 @@ If the namespace does not, they are colored the unbound color.
;; (union #f (is-a?/c top-level-window<%>)) ;; (union #f (is-a?/c top-level-window<%>))
;; -> void ;; -> void
;; callback for the rename popup menu item ;; callback for the rename popup menu item
(define/private (rename-menu-callback identifiers-hash name-to-offer binding-identifiers parent) (define/private (rename-menu-callback identifiers-hash name-to-offer
binding-identifiers parent)
(define (name-dup? x) (define (name-dup? x)
(for/or ([var-arrow (in-list binding-identifiers)]) (for/or ([var-arrow (in-list binding-identifiers)])
((var-arrow-name-dup? var-arrow) x))) ((var-arrow-name-dup? var-arrow) x)))
@ -711,7 +727,8 @@ If the namespace does not, they are colored the unbound color.
(λ () (λ ()
(get-text-from-user (get-text-from-user
(string-constant cs-rename-id) (string-constant cs-rename-id)
(fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to)
name-to-offer)
parent parent
name-to-offer name-to-offer
#:dialog-mixin frame:focus-table-mixin)))) #:dialog-mixin frame:focus-table-mixin))))
@ -724,8 +741,9 @@ If the namespace does not, they are colored the unbound color.
(equal? (equal?
(message-box/custom (message-box/custom
(string-constant check-syntax) (string-constant check-syntax)
(fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) (fw:gui-utils:format-literal-label
new-sym) (string-constant cs-name-duplication-error)
new-sym)
(string-constant cs-rename-anyway) (string-constant cs-rename-anyway)
(string-constant cancel) (string-constant cancel)
#f #f
@ -806,7 +824,9 @@ If the namespace does not, they are colored the unbound color.
[(equal? raw-color "palegreen") "darkgreen"] [(equal? raw-color "palegreen") "darkgreen"]
[else raw-color]) [else raw-color])
raw-color)) raw-color))
(add-to-range/key text start fin (make-colored-region color text start fin) #f #f)))) (add-to-range/key text start fin
(make-colored-region color text start fin)
#f #f))))
;; this method is no longer used; see docs for more ;; this method is no longer used; see docs for more
(define/public (syncheck:add-arrow start-text start-pos-left start-pos-right (define/public (syncheck:add-arrow start-text start-pos-left start-pos-right
@ -878,7 +898,7 @@ If the namespace does not, they are colored the unbound color.
[else [else
(interval-map-cons*! (interval-map-cons*!
arrow-record start end to-add null)]))) arrow-record start end to-add null)])))
(inherit get-top-level-window) (inherit get-top-level-window)
(define/augment (on-change) (define/augment (on-change)
(inner (void) on-change) (inner (void) on-change)
@ -970,20 +990,19 @@ If the namespace does not, they are colored the unbound color.
'bold)) 'bold))
(send dc set-text-foreground templ-color) (send dc set-text-foreground templ-color)
(send dc set-alpha 0.5) (send dc set-alpha 0.5)
(hash-for-each tacked-hash-table (for ([(arrow v) (in-hash tacked-hash-table)])
(λ (arrow v) (when v
(when v (cond
(cond [(var-arrow? arrow)
[(var-arrow? arrow) (if (var-arrow-actual? arrow)
(if (var-arrow-actual? arrow) (begin (send dc set-pen (get-var-pen white-on-black?))
(begin (send dc set-pen (get-var-pen white-on-black?)) (send dc set-brush (get-tacked-var-brush white-on-black?)))
(send dc set-brush (get-tacked-var-brush white-on-black?))) (begin (send dc set-pen (get-templ-pen white-on-black?))
(begin (send dc set-pen (get-templ-pen white-on-black?)) (send dc set-brush (get-tacked-templ-brush white-on-black?))))]
(send dc set-brush (get-tacked-templ-brush white-on-black?))))] [(tail-arrow? arrow)
[(tail-arrow? arrow) (send dc set-pen (get-tail-pen white-on-black?))
(send dc set-pen (get-tail-pen white-on-black?)) (send dc set-brush (get-tacked-tail-brush white-on-black?))])
(send dc set-brush (get-tacked-tail-brush white-on-black?))]) (draw-arrow2 arrow)))
(draw-arrow2 arrow))))
(when (and cursor-pos (when (and cursor-pos
cursor-text) cursor-text)
(define arrow-records-at-cursor (fetch-arrow-records cursor-text cursor-pos)) (define arrow-records-at-cursor (fetch-arrow-records cursor-text cursor-pos))
@ -1064,7 +1083,8 @@ If the namespace does not, they are colored the unbound color.
;; Starts or restarts a one-shot arrow draw timer ;; Starts or restarts a one-shot arrow draw timer
(define/private (start-arrow-draw-timer delay-ms) (define/private (start-arrow-draw-timer delay-ms)
(unless arrow-draw-timer (unless arrow-draw-timer
(set! arrow-draw-timer (make-object logging-timer% (λ () (maybe-update-drawn-arrows))))) (set! arrow-draw-timer (make-object logging-timer%
(λ () (maybe-update-drawn-arrows)))))
(send arrow-draw-timer start delay-ms #t)) (send arrow-draw-timer start delay-ms #t))
;; this will be set to a time in the future if arrows shouldn't be drawn until then ;; this will be set to a time in the future if arrows shouldn't be drawn until then
@ -1251,7 +1271,8 @@ If the namespace does not, they are colored the unbound color.
(define name-to-offer (find-name-to-offer binding-identifiers)) (define name-to-offer (find-name-to-offer binding-identifiers))
(new menu-item% (new menu-item%
[parent menu] [parent menu]
[label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)] [label (fw:gui-utils:format-literal-label (string-constant cs-rename-var)
name-to-offer)]
[callback [callback
(λ (x y) (λ (x y)
(let ([frame-parent (find-menu-parent menu)]) (let ([frame-parent (find-menu-parent menu)])
@ -1316,8 +1337,10 @@ If the namespace does not, they are colored the unbound color.
(for ([txt (in-list in-edit-sequence)]) (for ([txt (in-list in-edit-sequence)])
(send txt end-edit-sequence))) (send txt end-edit-sequence)))
;; position->matching-identifiers-hash : txt pos pos -> (values (listof var-arrow?) hash[(list txt pos pos) -o> #t]) ;; position->matching-identifiers-hash
(define/private (position->matching-identifiers-hash the-text the-start-pos the-end-pos include-require-arrows?) ;; : txt pos pos -> (values (listof var-arrow?) hash[(list txt pos pos) -o> #t])
(define/private (position->matching-identifiers-hash the-text the-start-pos the-end-pos
include-require-arrows?)
(define binding-arrows '()) (define binding-arrows '())
(define (add-binding-arrow arr) (define (add-binding-arrow arr)
(when (or include-require-arrows? (when (or include-require-arrows?
@ -1337,12 +1360,16 @@ If the namespace does not, they are colored the unbound color.
(add-binding-arrow arrow)] (add-binding-arrow arrow)]
[else [else
;; a bound occurrence => find binders ;; a bound occurrence => find binders
(for ([candidate-binder (in-list (fetch-arrow-records (var-arrow-start-text arrow) (for ([candidate-binder
(var-arrow-start-pos-left arrow)))]) (in-list (fetch-arrow-records (var-arrow-start-text arrow)
(var-arrow-start-pos-left arrow)))])
(when (var-arrow? candidate-binder) (when (var-arrow? candidate-binder)
(when (and (equal? (var-arrow-start-text arrow) (var-arrow-start-text candidate-binder)) (when (and (equal? (var-arrow-start-text arrow)
(equal? (var-arrow-start-pos-left arrow) (var-arrow-start-pos-left candidate-binder)) (var-arrow-start-text candidate-binder))
(equal? (var-arrow-start-pos-right arrow) (var-arrow-start-pos-right candidate-binder))) (equal? (var-arrow-start-pos-left arrow)
(var-arrow-start-pos-left candidate-binder))
(equal? (var-arrow-start-pos-right arrow)
(var-arrow-start-pos-right candidate-binder)))
(add-binding-arrow candidate-binder))))]))))) (add-binding-arrow candidate-binder))))])))))
(define identifiers-hash (make-hash)) (define identifiers-hash (make-hash))
@ -1421,7 +1448,8 @@ If the namespace does not, they are colored the unbound color.
(define eol-pos (line-end-position (position-line right-pos))) (define eol-pos (line-end-position (position-line right-pos)))
(send text position-location eol-pos xlb ylb #t #t) (send text position-location eol-pos xlb ylb #t #t)
(define-values (x-off y-off) (send text editor-location-to-dc-location (+ (unbox xlb) 4) (unbox ylb))) (define-values (x-off y-off)
(send text editor-location-to-dc-location (+ (unbox xlb) 4) (unbox ylb)))
(define window (define window
(let loop ([ed text]) (let loop ([ed text])
(cond (cond
@ -1448,7 +1476,8 @@ If the namespace does not, they are colored the unbound color.
(send (colored-region-text current-colored-region) unhighlight-range (send (colored-region-text current-colored-region) unhighlight-range
(colored-region-start current-colored-region) (colored-region-start current-colored-region)
(colored-region-fin current-colored-region) (colored-region-fin current-colored-region)
(send the-color-database find-color (colored-region-color current-colored-region)))) (send the-color-database find-color
(colored-region-color current-colored-region))))
(when new-region (when new-region
(send (colored-region-text new-region) highlight-range (send (colored-region-text new-region) highlight-range
(colored-region-start new-region) (colored-region-start new-region)
@ -1547,7 +1576,8 @@ If the namespace does not, they are colored the unbound color.
;; jump-to-next-callback : num text boolean? -> void ;; jump-to-next-callback : num text boolean? -> void
;; callback for the jump popup menu item ;; callback for the jump popup menu item
(define/private (jump-to-next-callback start-pos end-pos txt backwards?) (define/private (jump-to-next-callback start-pos end-pos txt backwards?)
(define-values (_binders identifiers-hash) (position->matching-identifiers-hash txt start-pos end-pos #t)) (define-values (_binders identifiers-hash)
(position->matching-identifiers-hash txt start-pos end-pos #t))
(define orig-arrows (define orig-arrows
(sort (hash-map identifiers-hash (sort (hash-map identifiers-hash
(λ (x y) x)) (λ (x y) x))
@ -1694,6 +1724,14 @@ If the namespace does not, they are colored the unbound color.
(mixin (drracket:unit:tab<%>) () (mixin (drracket:unit:tab<%>) ()
(inherit is-current-tab? get-defs get-frame) (inherit is-current-tab? get-defs get-frame)
(define next-trace-refresh? #t)
(define/public (get-next-trace-refresh?) next-trace-refresh?)
(define/public (set-next-trace-refresh b) (set! next-trace-refresh? b))
(define current-replay-state #f)
(define/public (set-replay-state rs) (set! current-replay-state #f))
(define/public (get-replay-state) current-replay-state)
(define report-error-text-has-something? #f) (define report-error-text-has-something? #f)
(define report-error-text (new (fw:text:ports-mixin fw:racket:text%))) (define report-error-text (new (fw:text:ports-mixin fw:racket:text%)))
(define error-report-visible? #f) (define error-report-visible? #f)
@ -1793,7 +1831,8 @@ If the namespace does not, they are colored the unbound color.
;; set-syncheck-running-mode : (or/c (box boolean?) 'button #f) -> boolean ;; set-syncheck-running-mode : (or/c (box boolean?) 'button #f) -> boolean
;; records how a particular check syntax is being played out in the editor right now. ;; records how a particular check syntax is being played out in the editor right now.
;; - #f means nothing is currently running. ;; - #f means nothing is currently running.
;; - 'button means someone clicked the check syntax button (or the menu item or keyboard shortcut...) ;; - 'button means someone clicked the check syntax button
;; (or the menu item or keyboard shortcut...)
;; - the boxed boolean means that a trace is being replayed from the other place. ;; - the boxed boolean means that a trace is being replayed from the other place.
;; if the box is set to #f, then the trace replay will be stopped. ;; if the box is set to #f, then the trace replay will be stopped.
;; if #f is returned, then the mode change is not allowed; this only happens when ;; if #f is returned, then the mode change is not allowed; this only happens when
@ -1827,38 +1866,44 @@ If the namespace does not, they are colored the unbound color.
(define current-syncheck-running-mode #f) (define current-syncheck-running-mode #f)
(define/public (replay-compile-comp-trace defs-text val) (define/public (replay-compile-comp-trace defs-text val bx)
(define bx (box #t)) (send (send defs-text get-tab) add-bkg-running-color
(when (set-syncheck-running-mode bx) 'syncheck "orchid" cs-syncheck-running)
(let loop ([val val]
;; reset any previous check syntax information [start-time (current-inexact-milliseconds)]
(let ([tab (send defs-text get-tab)]) [i 0])
(send tab syncheck:clear-error-message) (cond
(send tab syncheck:clear-highlighting) [(and (null? val) (pair? (unbox bx)))
(send defs-text syncheck:reset-docs-im)) (define new-val (car (unbox bx)))
(set-box! bx (cdr (unbox bx)))
(send (send defs-text get-tab) add-bkg-running-color 'syncheck "orchid" cs-syncheck-running) (loop new-val start-time i)]
(send defs-text syncheck:init-arrows) [(null? val)
(let loop ([val val] (send defs-text syncheck:update-blue-boxes)
[start-time (current-inexact-milliseconds)] (send defs-text syncheck:update-drawn-arrows)
[i 0]) (send (send defs-text get-tab) remove-bkg-running-color 'syncheck)
(cond (set-syncheck-running-mode #f)]
[(null? val) [(not (unbox bx))
(send defs-text syncheck:update-blue-boxes) ;; if we've been asked to stop (because some new results are ready
(send defs-text syncheck:update-drawn-arrows) ;; and another trace is running).
(send (send defs-text get-tab) remove-bkg-running-color 'syncheck) (void)]
(set-syncheck-running-mode #f)] [(and (i . > . 0) ;; check i just in case things are really strange
[(and (i . > . 0) ;; check i just in case things are really strange (20 . <= . (- (current-inexact-milliseconds) start-time)))
(20 . <= . (- (current-inexact-milliseconds) start-time))) (queue-callback
(queue-callback (λ ()
(λ () (when (unbox bx)
(when (unbox bx) (log-timeline "continuing replay-compile-comp-trace"
(log-timeline "continuing replay-compile-comp-trace" (loop val (current-inexact-milliseconds) 0))))
(loop val (current-inexact-milliseconds) 0)))) #f)]
#f)] [else
[else (process-trace-element defs-text (car val))
(process-trace-element defs-text (car val)) (loop (cdr val) start-time (+ i 1))])))
(loop (cdr val) start-time (+ i 1))]))))
(define/public (reset-previous-check-syntax-information defs-text)
(define tab (send defs-text get-tab))
(send tab syncheck:clear-error-message)
(send tab syncheck:clear-highlighting)
(send defs-text syncheck:reset-docs-im)
(send defs-text syncheck:init-arrows))
(define/private (process-trace-element defs-text x) (define/private (process-trace-element defs-text x)
;; using 'defs-text' all the time is wrong in the case of embedded editors, ;; using 'defs-text' all the time is wrong in the case of embedded editors,
@ -1883,7 +1928,8 @@ If the namespace does not, they are colored the unbound color.
[`#(syncheck:add-require-open-menu ,start-pos ,end-pos ,file) [`#(syncheck:add-require-open-menu ,start-pos ,end-pos ,file)
(send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)] (send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)]
[`#(syncheck:add-docs-menu ,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag) [`#(syncheck:add-docs-menu ,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag)
(send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path definition-tag tag)] (send defs-text syncheck:add-docs-menu defs-text start-pos end-pos
key the-label path definition-tag tag)]
[`#(syncheck:add-definition-target ,start-pos ,end-pos ,id ,mods) [`#(syncheck:add-definition-target ,start-pos ,end-pos ,id ,mods)
(send defs-text syncheck:add-definition-target defs-text start-pos end-pos id mods)] (send defs-text syncheck:add-definition-target defs-text start-pos end-pos id mods)]
[`#(syncheck:add-id-set ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) [`#(syncheck:add-id-set ,to-be-renamed/poss ,name-dup-pc ,name-dup-id)
@ -1932,7 +1978,8 @@ If the namespace does not, they are colored the unbound color.
(define/augment (after-percentage-change) (define/augment (after-percentage-change)
(define ps (get-percentages)) (define ps (get-percentages))
(when (and record-prefs? (= 2 (length ps))) (when (and record-prefs? (= 2 (length ps)))
(preferences:set 'drracket:check-syntax-error-report-window-percentage (list-ref ps 0))) (preferences:set 'drracket:check-syntax-error-report-window-percentage
(list-ref ps 0)))
(inner (void) after-percentage-change)) (inner (void) after-percentage-change))
(super-new)) (super-new))
[parent (super get-definitions/interactions-panel-parent)])) [parent (super get-definitions/interactions-panel-parent)]))
@ -2120,7 +2167,8 @@ If the namespace does not, they are colored the unbound color.
(define module-language? (define module-language?
(is-a? (drracket:language-configuration:language-settings-language settings) (is-a? (drracket:language-configuration:language-settings-language settings)
drracket:module-language:module-language<%>)) drracket:module-language:module-language<%>))
(send definitions-text-copy set-style-list (send definitions-text get-style-list)) ;; speeds up the copy ;; speeds up the copy
(send definitions-text-copy set-style-list (send definitions-text get-style-list))
(send definitions-text copy-self-to definitions-text-copy) (send definitions-text copy-self-to definitions-text-copy)
(with-lock/edit-sequence (with-lock/edit-sequence
definitions-text-copy definitions-text-copy
@ -2131,7 +2179,9 @@ If the namespace does not, they are colored the unbound color.
(send (send the-tab get-defs) syncheck:init-arrows) (send (send the-tab get-defs) syncheck:init-arrows)
(drracket:eval:expand-program (drracket:eval:expand-program
#:gui-modules? #f #:gui-modules? #f
(drracket:language:make-text/pos definitions-text-copy 0 (send definitions-text-copy last-position)) (drracket:language:make-text/pos definitions-text-copy
0
(send definitions-text-copy last-position))
settings settings
(not module-language?) (not module-language?)
init-proc init-proc
@ -2162,7 +2212,8 @@ If the namespace does not, they are colored the unbound color.
definitions-text definitions-text
(λ () (λ ()
(open-status-line 'drracket:check-syntax:status) (open-status-line 'drracket:check-syntax:status)
(update-status-line 'drracket:check-syntax:status status-coloring-program) (update-status-line
'drracket:check-syntax:status status-coloring-program)
(parameterize ([current-annotations definitions-text]) (parameterize ([current-annotations definitions-text])
(expanded-expression sexp)) (expanded-expression sexp))
(close-status-line 'drracket:check-syntax:status)))))) (close-status-line 'drracket:check-syntax:status))))))
@ -2311,33 +2362,72 @@ If the namespace does not, they are colored the unbound color.
(add-check-syntax-key-bindings (drracket:rep:get-drs-bindings-keymap)) (add-check-syntax-key-bindings (drracket:rep:get-drs-bindings-keymap))
(fw:color-prefs:add-to-preferences-panel (string-constant check-syntax) (fw:color-prefs:add-to-preferences-panel (string-constant check-syntax)
syncheck-add-to-preferences-panel) syncheck-add-to-preferences-panel)
(drracket:module-language-tools:register-online-expansion-pref syncheck-add-to-online-expansion-prefs-panel) (drracket:module-language-tools:register-online-expansion-pref
syncheck-add-to-online-expansion-prefs-panel)
(drracket:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t) (drracket:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t)
(drracket:get/extend:extend-definitions-text make-syncheck-text%) (drracket:get/extend:extend-definitions-text make-syncheck-text%)
(drracket:get/extend:extend-definitions-canvas docs-editor-canvas-mixin) (drracket:get/extend:extend-definitions-canvas docs-editor-canvas-mixin)
(drracket:get/extend:extend-unit-frame unit-frame-mixin #f) (drracket:get/extend:extend-unit-frame unit-frame-mixin #f)
(drracket:get/extend:extend-tab tab-mixin) (drracket:get/extend:extend-tab tab-mixin)
(drracket:module-language-tools:add-online-expansion-monitor
online-comp.rkt
'monitor
(λ (defs-text val)
(define tab (send defs-text get-tab))
(cond
[(drracket:module-language-tools:start? val) (send tab set-next-trace-refresh #t)]
[(drracket:module-language-tools:done? val) (void)]
[else
;; replay-state =
;; (or/c #f -- no replay running
;; (box #t -- keep running this replay
;; (listof (listof stuff))
;; -- pick up some new elements to add to the current replay
;; #f)) -- doesn't actually get set on a tab, but this means to
;; just stop running the replay
(when (send tab get-next-trace-refresh?)
(define old-replay-state (send tab get-replay-state))
(when (box? old-replay-state)
(set-box! old-replay-state #f))
(send tab set-replay-state #f)
(send tab set-next-trace-refresh #f)
;; reset any previous check syntax information
(send tab syncheck:clear-error-message)
(send tab syncheck:clear-highlighting)
(send defs-text syncheck:reset-docs-im)
(send tab add-bkg-running-color 'syncheck "orchid" cs-syncheck-running)
(send defs-text syncheck:init-arrows))
(define current-replay-state (send tab get-replay-state))
(define drr-frame (send (send defs-text get-tab) get-frame))
(cond
[(not current-replay-state)
(define new-replay-state (box '()))
(send tab set-replay-state new-replay-state)
(send drr-frame replay-compile-comp-trace
defs-text
val
(box '()))]
[else
(set-box! current-replay-state
(append (unbox current-replay-state) (list val)))])])))
(drracket:module-language-tools:add-online-expansion-handler (drracket:module-language-tools:add-online-expansion-handler
online-comp.rkt online-comp.rkt
'go 'go
(λ (defs-text val) void)))
(log-timeline
"replace-compile-comp-trace"
(send (send (send defs-text get-tab) get-frame)
replay-compile-comp-trace
defs-text
val))))))
(define wbs '())
(define-runtime-path online-comp.rkt "online-comp.rkt") (define-runtime-path online-comp.rkt "online-comp.rkt")
(define (pick-next-arrow orig-arrows backwards? txt start-pos end-pos) (define (pick-next-arrow orig-arrows backwards? txt start-pos end-pos)
(cond (cond
[(null? orig-arrows) #f] [(null? orig-arrows) #f]
[(null? (cdr orig-arrows)) (car orig-arrows)] [(null? (cdr orig-arrows)) (car orig-arrows)]

40
pkgs/drracket-pkgs/drracket/drracket/private/syncheck/online-comp.rkt
View File

@ -1,6 +1,8 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/place racket/place
racket/match
racket/contract
(for-syntax racket/base) (for-syntax racket/base)
"../../private/eval-helpers.rkt" "../../private/eval-helpers.rkt"
"traversals.rkt" "traversals.rkt"
@ -8,7 +10,7 @@
"intf.rkt" "intf.rkt"
"xref.rkt") "xref.rkt")
(provide go) (provide go monitor)
(define obj% (define obj%
(class (annotations-mixin object%) (class (annotations-mixin object%)
@ -67,7 +69,8 @@
(parameterize (#;[current-custodian orig-cust]) (parameterize (#;[current-custodian orig-cust])
(thread (thread
(λ () (λ ()
(with-handlers ((exn:fail? (λ (x) (eprintf "online-comp.rkt: thread failed ~a\n" (exn-message x))))) (with-handlers ([exn:fail? (λ (x) (eprintf "online-comp.rkt: thread failed ~a\n"
(exn-message x)))])
(let loop () (let loop ()
(define id/name (place-channel-get local-chan)) (define id/name (place-channel-get local-chan))
(define id (list-ref id/name 0)) (define id (list-ref id/name 0))
@ -77,7 +80,16 @@
(loop)))))) (loop))))))
(void)) (void))
(define-logger online-check-syntax)
(define (go expanded path the-source orig-cust) (define (go expanded path the-source orig-cust)
(define c (make-channel))
(unless (exn? expanded)
(log-message online-check-syntax-logger 'info "" (list expanded)))
(log-message online-check-syntax-logger 'info "" c)
;; wait for everything to actually get sent back to the main place
(channel-get c))
(define (build-trace stxes the-source orig-cust path)
(parameterize ([current-max-to-send-at-once 50]) (parameterize ([current-max-to-send-at-once 50])
(with-handlers ((exn:fail? (λ (x) (with-handlers ((exn:fail? (λ (x)
(printf "exception noticed in online-comp.rkt\n") (printf "exception noticed in online-comp.rkt\n")
@ -97,6 +109,28 @@
(make-traversal (current-namespace) (make-traversal (current-namespace)
(get-init-dir path))) (get-init-dir path)))
(parameterize ([current-annotations obj]) (parameterize ([current-annotations obj])
(expanded-expression expanded) (for ([stx (in-list stxes)])
(expanded-expression stx))
(expansion-completed)) (expansion-completed))
(send obj get-trace)))) (send obj get-trace))))
(define (monitor send-back path the-source orig-cust)
(define lr (make-log-receiver (current-logger)
'info
'online-check-syntax))
(thread
(λ ()
(let loop ()
(define val (sync lr))
(match val
[(vector level message obj name)
(cond
[(and (list? obj) (andmap syntax? obj))
(define trace (build-trace obj the-source orig-cust path))
(send-back trace)]
[(channel? obj)
;; signal back to the main place that we've gotten everything
;; and sent it back over
(channel-put obj (void))])]
[_ (void)])
(loop)))))

1
pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt
View File

@ -205,7 +205,6 @@
[else [else
(loop fst) (loop fst)
(body-loop (car bodies) (cdr bodies))])))) (body-loop (car bodies) (cdr bodies))]))))
(syntax-case* stx-obj (#%plain-lambda case-lambda if begin begin0 let-values letrec-values (syntax-case* stx-obj (#%plain-lambda case-lambda if begin begin0 let-values letrec-values
set! quote quote-syntax with-continuation-mark set! quote quote-syntax with-continuation-mark
#%plain-app #%top #%plain-module-begin #%plain-app #%top #%plain-module-begin

75
pkgs/drracket-pkgs/drracket/drracket/tool-lib.rkt
View File

@ -227,19 +227,25 @@ all of the names in the tools library, for use defining keybindings
void?) void?)
(mod-path id local-handler) (mod-path id local-handler)
@{Registers a pair of procedures with DrRacket's online expansion machinery. @{Registers a pair of procedures with DrRacket's online expansion machinery.
(See also @racket[drracket:module-language-tools:add-online-expansion-monitor].)
The first two arguments name a procedure in a module that is loaded by The first two arguments name a procedure in a module that is loaded by
@racket[dynamic-require] is a separate place. When DrRacket detects that @racket[dynamic-require] is specially designed separate @racket[place].
When DrRacket detects that
the editor has been modified, it sends the contents of the editor over to the editor has been modified, it sends the contents of the editor over to
that separate place, @racket[expand]s the program there, and then supplies that separate place, @racket[expand]s the program there, and then supplies
the fully expanded object to that first procedure. (The procedure is called the fully expanded object to that first procedure. (The procedure is called
in the same context as the expansion process.) in the same context as the expansion process.)
If the expansion raises an exception, then that exception is supplied as the
first argument instead of the syntax object. If a non-@racket[exn?] is raised,
or if the expansion process is terminated (e.g. via @racket[custodian-shutdown-all]
called during expansion), then the expansion monitor is not notified.
The contract for that procedure is The contract for that procedure is
@racketblock[(-> syntax? path? any/c custodian? @racketblock[(-> (or/c syntax? exn?) path? any/c custodian?
any)] any)]
There are three other arguments. There are three other arguments:
@itemize[ @itemize[
@item{ @item{
The @racket[path?] argument is the path that was the @racket[current-directory] The @racket[path?] argument is the path that was the @racket[current-directory]
@ -270,6 +276,49 @@ all of the names in the tools library, for use defining keybindings
and other tools), but any long running computations may freeze DrRacket's GUI, and other tools), but any long running computations may freeze DrRacket's GUI,
since this procedure is invoked on DrRacket's eventspace's handler thread.}) since this procedure is invoked on DrRacket's eventspace's handler thread.})
(proc-doc/names
drracket:module-language-tools:add-online-expansion-monitor
(-> path-string? symbol?
(-> (is-a?/c drracket:unit:definitions-text<%>)
(or/c drracket:module-language-tools:start?
any/c)
any)
void?)
(mod-path id local-handler)
@{Registers a pair of procedures with DrRacket's online expansion machinery.
Like @racket[drracket:module-language-tools:add-online-expansion-handler],
the first two arguments name a procedure that is called in the separate place
designated for expansion.
The procedure is called before expansion starts and once it returns, expansion
begins. The procedure should match this contract:
@racketblock[(-> (-> any/c void?)
path? any/c custodian?
any)]
The first argument is a function that transmits its argument back to the
DrRacket place, send it to the @racket[local-handler] argument.
The other three arguments are the same as the corresponding procedure used
by @racket[drracket:module-language-tools:add-online-expansion-handler].
The expectation is that this procedure creates a thread and monitors the
expansion process, sending back information to the main place while
expansion is progressing.
The @racket[local-handler] procedure is called each time the
@racket[(-> any/c void?)] procedure (described just above) is called.
It is also called each time an expansion starts; it receives a value
that returns @racket[#t] from @racket[drracket:module-language-tools:start?]
in that case.})
(proc-doc/names
drracket:module-language-tools:start?
(-> any/c boolean?)
(val)
@{Returns @racket[#t] if this is a special (unique) value, used as
discussed in @racket[drracket:module-language-tools:add-online-expansion-monitor].
Returns @racket[#f] otherwise.})
(proc-doc/names (proc-doc/names
drracket:module-language-tools:register-online-expansion-pref drracket:module-language-tools:register-online-expansion-pref
(-> (-> (is-a?/c vertical-panel%) void?) void?) (-> (-> (is-a?/c vertical-panel%) void?) void?)
@ -278,6 +327,19 @@ all of the names in the tools library, for use defining keybindings
preferences panel. The function is passed a panel that contains preferences panel. The function is passed a panel that contains
other configuration controls for online expansion.}) other configuration controls for online expansion.})
(proc-doc/names
drracket:module-language-tools:done?
(-> any/c boolean?)
(val)
@{Returns @racket[#t] for @racket[drracket:module-language-tools:done]
and @racket[#f] otherwise.})
(thing-doc
drracket:module-language-tools:done
drracket:module-language-tools:done?
@{Used to inform a monitor-based handler that the online expansion has finished.})
(proc-doc/names (proc-doc/names
drracket:module-language:add-module-language drracket:module-language:add-module-language
(-> any) (-> any)
@ -292,6 +354,7 @@ all of the names in the tools library, for use defining keybindings
to use a default name from the buffer, if the buffer contains something like to use a default name from the buffer, if the buffer contains something like
@tt{(module name ...)}.}) @tt{(module name ...)}.})
; ;
; ;

21
pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl
View File

@ -1011,6 +1011,27 @@ Finally, Check Syntax only draws arrows between identifiers that are @racket[syn
or that have the @racket[syntax-property] @racket['original-for-check-syntax] or that have the @racket[syntax-property] @racket['original-for-check-syntax]
set to @racket[#t]. set to @racket[#t].
@section{Cooperating with Background Check Syntax}
DrRacket's continuous, background check syntax runs each time
an edit to the definitions text happens. In some cases, that
expansion process fails, but there is still a well-formed syntax
object that check syntax can use to display information to the user.
In order to communicate that syntax object to check syntax,
send a log message with the name @racket['online-check-syntax],
e.g.
@racketblock[(define-logger online-check-syntax)
(log-message online-check-syntax-logger
'info
"ignored message"
list-of-syntax-objects)]
The fourth argument to @racket[log-message] should be a list
of syntax objects; these are processed as if they were the result
of expansion.
Note: the identifiers in these objects should be @racket[syntax-original?]
or else they will be ignored by check syntax.
@section{Teaching Languages} @section{Teaching Languages}
The teaching language are implemented via the tools interface and thus The teaching language are implemented via the tools interface and thus

8
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt
View File

@ -42,6 +42,8 @@
. .
body))) body)))
(define-logger online-check-syntax)
(define (tc-setup/proc orig-stx stx expand-ctxt init checker f) (define (tc-setup/proc orig-stx stx expand-ctxt init checker f)
(set-box! typed-context? #t) (set-box! typed-context? #t)
;(start-timing (syntax-property stx 'enclosing-module-name)) ;(start-timing (syntax-property stx 'enclosing-module-name))
@ -62,6 +64,12 @@
(when (show-input?) (when (show-input?)
(pretty-print (syntax->datum fully-expanded-stx))) (pretty-print (syntax->datum fully-expanded-stx)))
(do-time "Local Expand Done") (do-time "Local Expand Done")
(let ([exprs (syntax->list (syntax-local-introduce fully-expanded-stx))])
(when (pair? exprs)
(log-message online-check-syntax-logger
'info
"TR's expanded syntax objects; this message is ignored"
(cdr exprs))))
(init) (init)
(do-time "Initialized Envs") (do-time "Initialized Envs")
(find-mutated-vars fully-expanded-stx mvar-env) (find-mutated-vars fully-expanded-stx mvar-env)