IN PROGRESS: working on changing the protocol between the
expanding place and the drracket place to support sending information during the expansion process, not just at the end
This commit is contained in:
Robby Findler
parent
780fb37c0d
commit
90fc899b36
|
|
@ -120,10 +120,15 @@
|
|||
(define-signature drracket:module-language-tools^ extends drracket:module-language-tools-cm^
|
||||
(add-opt-out-toolbar-button
|
||||
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^
|
||||
(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
|
||||
no-more-online-expansion-handlers))
|
||||
|
||||
|
|
|
|||
|
|
@ -9,10 +9,13 @@
|
|||
|
||||
(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 #;response-pc working-thd stop-watching-abnormal-termination))
|
||||
|
||||
;; 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 module-language-parallel-lock-client
|
||||
|
|
@ -39,10 +42,15 @@
|
|||
(current-custodian)))
|
||||
|
||||
;; get the handlers in a second message
|
||||
(set! handlers (for/list ([lst (place-channel-get p)])
|
||||
(define file (list-ref lst 0))
|
||||
(define id (list-ref lst 1))
|
||||
(handler lst (dynamic-require file id))))
|
||||
(set! handlers
|
||||
(filter
|
||||
values
|
||||
(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]
|
||||
;; the old-registry argument holds on to the namespace-module-registry
|
||||
;; from a previous run in order to keep entries in the bytecode cache
|
||||
|
|
@ -100,6 +108,23 @@
|
|||
(parameterize ([current-custodian cust])
|
||||
(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")
|
||||
(define sema (make-semaphore 0))
|
||||
(ep-log-info "expanding-place.rkt: 02 setting basic parameters")
|
||||
|
|
@ -186,12 +211,14 @@
|
|||
(place-channel-put pc-status-expanding-place 'finished-expansion)
|
||||
(ep-log-info "expanding-place.rkt: 10 expanded")
|
||||
(define handler-results
|
||||
(for/list ([handler (in-list handlers)])
|
||||
(list (handler-key handler)
|
||||
((handler-proc handler) expanded
|
||||
path
|
||||
the-source
|
||||
orig-cust))))
|
||||
(for/list ([handler (in-list handlers)]
|
||||
#:unless (handler-monitor-pc handler))
|
||||
(define proc-res
|
||||
((handler-proc handler) expanded
|
||||
path
|
||||
the-source
|
||||
orig-cust))
|
||||
(list (handler-key handler) proc-res)))
|
||||
(ep-log-info "expanding-place.rkt: 11 handlers finished")
|
||||
|
||||
(parameterize ([current-custodian orig-cust])
|
||||
|
|
@ -318,7 +345,7 @@
|
|||
exn-infos
|
||||
(list-ref exn+loaded-paths 1)))))))))
|
||||
|
||||
(job cust response-pc working-thd stop-watching-abnormal-termination))
|
||||
(job cust #;response-pc working-thd stop-watching-abnormal-termination))
|
||||
|
||||
(define (catch-and-log port sema)
|
||||
(let loop ()
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(require mrlib/switchable-button
|
||||
mrlib/bitmap-label
|
||||
racket/contract
|
||||
racket/place
|
||||
framework
|
||||
racket/unit
|
||||
racket/class
|
||||
|
|
@ -32,7 +33,8 @@
|
|||
|
||||
(define-local-member-name
|
||||
set-lang-toolbar-buttons
|
||||
get-lang-toolbar-buttons)
|
||||
get-lang-toolbar-buttons
|
||||
get-online-expansion-monitor-pcs)
|
||||
|
||||
(define tab-mixin
|
||||
(mixin (drracket:unit:tab<%>) (drracket:module-language-tools:tab<%>)
|
||||
|
|
@ -160,21 +162,26 @@
|
|||
|
||||
(define/public (move-to-new-language)
|
||||
(let* ([port (open-input-text-editor this)]
|
||||
;; info-result : (or/c #f [#lang without a known language]
|
||||
;; (vector <get-info-proc>) [no #lang line, so we use the '#lang racket' info proc]
|
||||
;; <get-info-proc> [the get-info proc for the program in the definitions]
|
||||
[info-result (with-handlers ((exn:fail?
|
||||
(λ (x)
|
||||
(log-debug (format "DrRacket: error duing call to read-language for ~a:\n ~a"
|
||||
(or (send this get-filename) "<<unsaved file>>")
|
||||
(regexp-replace* #rx"\n(.)" (exn-message x) "\n\\1 ")))
|
||||
#f)))
|
||||
(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"))))))])
|
||||
;; info-result :
|
||||
;; (or/c #f [#lang without a known language]
|
||||
;; (vector <get-info-proc>)
|
||||
;; [no #lang line, so we use the '#lang racket' info proc]
|
||||
;; <get-info-proc>) [the get-info proc for the program in the definitions]
|
||||
[info-result
|
||||
(with-handlers ([exn:fail?
|
||||
(λ (x)
|
||||
(log-debug
|
||||
(format
|
||||
"DrRacket: error duing call to read-language for ~a:\n ~a"
|
||||
(or (send this get-filename) "<<unsaved file>>")
|
||||
(regexp-replace* #rx"\n(.)" (exn-message x) "\n\\1 ")))
|
||||
#f)])
|
||||
(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
|
||||
;; make it happen outside of DrRacket
|
||||
|
|
@ -204,28 +211,35 @@
|
|||
(get-lang-name pos))
|
||||
'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?)
|
||||
(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
|
||||
(register-new-buttons
|
||||
(ctc-on-info-proc-result (or/c #f (listof (or/c (list/c string?
|
||||
(is-a?/c bitmap%)
|
||||
(-> (is-a?/c drracket:unit:frame<%>) any))
|
||||
(list/c string?
|
||||
(is-a?/c bitmap%)
|
||||
(-> (is-a?/c drracket:unit:frame<%>) any)
|
||||
(or/c real? #f)))))
|
||||
(or (info-proc 'drracket:toolbar-buttons #f)
|
||||
(info-proc 'drscheme:toolbar-buttons #f)))
|
||||
(ctc-on-info-proc-result (or/c #f (listof symbol?))
|
||||
(or (info-proc 'drracket:opt-out-toolbar-buttons '())
|
||||
(info-proc 'drscheme:opt-out-toolbar-buttons '())))))))))
|
||||
(ctc-on-info-proc-result
|
||||
(or/c #f (listof (or/c (list/c string?
|
||||
(is-a?/c bitmap%)
|
||||
(-> (is-a?/c drracket:unit:frame<%>) any))
|
||||
(list/c string?
|
||||
(is-a?/c bitmap%)
|
||||
(-> (is-a?/c drracket:unit:frame<%>) any)
|
||||
(or/c real? #f)))))
|
||||
(or (info-proc 'drracket:toolbar-buttons #f)
|
||||
(info-proc 'drscheme:toolbar-buttons #f)))
|
||||
(ctc-on-info-proc-result
|
||||
(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)
|
||||
;; 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
|
||||
(cond
|
||||
[(not buttons) '()]
|
||||
|
|
@ -234,46 +248,47 @@
|
|||
(if (= 3 (length button))
|
||||
(append button (list #f))
|
||||
button))]))
|
||||
(let* ([tab (get-tab)]
|
||||
[frame (send tab get-frame)])
|
||||
(send frame when-initialized
|
||||
(λ ()
|
||||
(send frame begin-container-sequence)
|
||||
|
||||
;; avoid any time with both sets of buttons in the 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)
|
||||
(new switchable-button%
|
||||
[label (list-ref button-spec 0)]
|
||||
[bitmap (list-ref button-spec 1)]
|
||||
[parent (send frame get-toolbar-button-panel)]
|
||||
[callback
|
||||
(lambda (button)
|
||||
((list-ref button-spec 2) frame))]))
|
||||
cleaned-up-buttons)]
|
||||
[directly-specified-button-numbers (map (λ (button-spec) (list-ref button-spec 3))
|
||||
cleaned-up-buttons)]
|
||||
[opt-out-buttons+numbers
|
||||
(if (eq? opt-out-ids #f)
|
||||
'()
|
||||
(map
|
||||
(λ (opt-out-toolbar-button)
|
||||
(list ((opt-out-toolbar-button-make-button opt-out-toolbar-button)
|
||||
frame
|
||||
(send frame get-toolbar-button-panel))
|
||||
(opt-out-toolbar-button-number opt-out-toolbar-button)))
|
||||
(filter (λ (opt-out-toolbar-button)
|
||||
(not (member (opt-out-toolbar-button-id opt-out-toolbar-button)
|
||||
opt-out-ids)))
|
||||
opt-out-toolbar-buttons)))])
|
||||
(send tab set-lang-toolbar-buttons
|
||||
(append directly-specified-buttons
|
||||
(map (λ (x) (list-ref x 0)) opt-out-buttons+numbers))
|
||||
(append directly-specified-button-numbers
|
||||
(map (λ (x) (list-ref x 1)) opt-out-buttons+numbers))))
|
||||
(send frame end-container-sequence)))))
|
||||
(define tab (get-tab))
|
||||
(define frame (send tab get-frame))
|
||||
(send frame when-initialized
|
||||
(λ ()
|
||||
(send frame begin-container-sequence)
|
||||
|
||||
;; avoid any time with both sets of buttons in the
|
||||
;; panel so the window doesn't get too wide
|
||||
(send (send frame get-toolbar-button-panel) change-children (λ (prev) '()))
|
||||
|
||||
(define directly-specified-buttons
|
||||
(map (λ (button-spec)
|
||||
(new switchable-button%
|
||||
[label (list-ref button-spec 0)]
|
||||
[bitmap (list-ref button-spec 1)]
|
||||
[parent (send frame get-toolbar-button-panel)]
|
||||
[callback
|
||||
(lambda (button)
|
||||
((list-ref button-spec 2) frame))]))
|
||||
cleaned-up-buttons))
|
||||
(define directly-specified-button-numbers
|
||||
(map (λ (button-spec) (list-ref button-spec 3))
|
||||
cleaned-up-buttons))
|
||||
(define opt-out-buttons+numbers
|
||||
(cond
|
||||
[(eq? opt-out-ids #f) '()]
|
||||
[else
|
||||
(for/list ([opt-out-toolbar-button (in-list opt-out-toolbar-buttons)]
|
||||
#:unless (member
|
||||
(opt-out-toolbar-button-id opt-out-toolbar-button)
|
||||
opt-out-ids))
|
||||
(list ((opt-out-toolbar-button-make-button opt-out-toolbar-button)
|
||||
frame
|
||||
(send frame get-toolbar-button-panel))
|
||||
(opt-out-toolbar-button-number opt-out-toolbar-button)))]))
|
||||
(send tab set-lang-toolbar-buttons
|
||||
(append directly-specified-buttons
|
||||
(map (λ (x) (list-ref x 0)) opt-out-buttons+numbers))
|
||||
(append directly-specified-button-numbers
|
||||
(map (λ (x) (list-ref x 1)) opt-out-buttons+numbers)))
|
||||
(send frame end-container-sequence))))
|
||||
|
||||
(inherit get-text)
|
||||
(define/private (get-lang-name pos)
|
||||
|
|
@ -289,6 +304,21 @@
|
|||
(define/private (clear-things-out)
|
||||
(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)
|
||||
(update-in-module-language?
|
||||
(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) (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 (get-online-expansion-handlers)
|
||||
(define (get-online-expansion-handlers)
|
||||
(cond
|
||||
[no-more-online-expansion-handlers?
|
||||
online-expansion-handlers]
|
||||
|
|
@ -312,15 +353,32 @@
|
|||
(error 'get-online-expansion-handlers
|
||||
"online-expansion-handlers can still be registered")]))
|
||||
(define (add-online-expansion-handler mod-path id local-handler)
|
||||
(cond
|
||||
[no-more-online-expansion-handlers?
|
||||
(error 'add-online-expansion-handler
|
||||
"no more online-expansion-handlers can be registered; got ~e ~e ~e"
|
||||
mod-path id local-handler)]
|
||||
[else
|
||||
(set! online-expansion-handlers
|
||||
(cons (online-expansion-handler mod-path id local-handler)
|
||||
online-expansion-handlers))]))
|
||||
(check-bad-registration 'add-online-expansion-handler mod-path id local-handler)
|
||||
(set! online-expansion-handlers
|
||||
(cons (online-expansion-handler mod-path id local-handler #f)
|
||||
online-expansion-handlers)))
|
||||
|
||||
(define (add-online-expansion-monitor mod-path id local-handler)
|
||||
(check-bad-registration 'add-online-expansion-monitor mod-path id local-handler)
|
||||
(set! 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 (get-online-expansion-pref-funcs) online-expansion-pref-funcs)
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@
|
|||
racket/math
|
||||
racket/match
|
||||
racket/set
|
||||
racket/place
|
||||
racket/gui/base
|
||||
compiler/embed
|
||||
compiler/cm
|
||||
|
|
@ -132,6 +133,7 @@
|
|||
(define default-enforce-module-constants #t)
|
||||
(define (get-default-auto-text) (preferences:get 'drracket:module-language:auto-text))
|
||||
|
||||
|
||||
;; module-mixin : (implements drracket:language:language<%>)
|
||||
;; -> (implements drracket:language:language<%>)
|
||||
(define (module-mixin %)
|
||||
|
|
@ -2131,7 +2133,9 @@
|
|||
(module-language-settings->prefab-module-settings settings)
|
||||
(λ (res) (oc-finished res))
|
||||
(λ (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
|
||||
(line-of-interest)
|
||||
(send dirty/pending-tab set-oc-status
|
||||
|
|
@ -2142,7 +2146,7 @@
|
|||
#f))))
|
||||
(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))
|
||||
(when running-tab
|
||||
(cond
|
||||
|
|
@ -2157,9 +2161,15 @@
|
|||
(list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h)
|
||||
(drracket:module-language-tools:online-expansion-handler-id o-e-h)))
|
||||
(when (equal? this-key that-key)
|
||||
((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h)
|
||||
(send running-tab get-defs)
|
||||
val))))
|
||||
(cond
|
||||
[(drracket:module-language-tools:online-expansion-handler-monitor? o-e-h)
|
||||
((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-dep-paths (list->set (vector-ref res 2)) #f)]
|
||||
|
|
@ -2179,6 +2189,19 @@
|
|||
(line-of-interest)
|
||||
(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)
|
||||
(define (get-focus-tab)
|
||||
(define tlw (get-top-level-focus-window))
|
||||
|
|
@ -2212,7 +2235,9 @@
|
|||
prefab-module-settings
|
||||
show-results
|
||||
tell-the-tab-show-bkg-running
|
||||
currently-open-files)
|
||||
monitor-status
|
||||
currently-open-files
|
||||
defs)
|
||||
(unless expanding-place
|
||||
(set! expanding-place (dynamic-place expanding-place.rkt 'start))
|
||||
(place-channel-put expanding-place module-language-compile-lock)
|
||||
|
|
@ -2220,7 +2245,15 @@
|
|||
expanding-place
|
||||
(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)
|
||||
(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
|
||||
tell-the-tab-show-bkg-running
|
||||
(thread (λ ()
|
||||
|
|
@ -2248,14 +2281,27 @@
|
|||
(pending-tell-the-tab-show-bkg-running
|
||||
'finished-expansion
|
||||
sc-online-expansion-running)))))))
|
||||
(define res (place-channel-get pc-out))
|
||||
(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)))))))
|
||||
|
||||
;; this loop catches all responses but handles the monitor response
|
||||
;; response here and keeps waiting for the actual result in that case.
|
||||
(let loop ()
|
||||
(define res (place-channel-get pc-out))
|
||||
(cond
|
||||
[(equal? (vector-ref res 0) 'monitor-message)
|
||||
(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)
|
||||
(when expanding-place
|
||||
|
|
|
|||
|
|
@ -262,6 +262,13 @@ If the namespace does not, they are colored the unbound color.
|
|||
(define (get-untacked-brush white-on-black?)
|
||||
(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%)
|
||||
;; overrides methods that make sure the arrows go away appropriately.
|
||||
;; 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)
|
||||
(send text position-location left-pos xlb ylb #t)
|
||||
(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)]
|
||||
[(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)])
|
||||
(values (/ (+ xl xr) 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-values (base name dir?) (split-path file))
|
||||
(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)
|
||||
(callback (λ (x y) (fw:handler:edit-file file))))
|
||||
(void))
|
||||
(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 url (path->url path))
|
||||
(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)
|
||||
(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)
|
||||
(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<%>))
|
||||
;; -> void
|
||||
;; 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)
|
||||
(for/or ([var-arrow (in-list binding-identifiers)])
|
||||
((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
|
||||
(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
|
||||
name-to-offer
|
||||
#:dialog-mixin frame:focus-table-mixin))))
|
||||
|
|
@ -724,8 +741,9 @@ If the namespace does not, they are colored the unbound color.
|
|||
(equal?
|
||||
(message-box/custom
|
||||
(string-constant check-syntax)
|
||||
(fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error)
|
||||
new-sym)
|
||||
(fw:gui-utils:format-literal-label
|
||||
(string-constant cs-name-duplication-error)
|
||||
new-sym)
|
||||
(string-constant cs-rename-anyway)
|
||||
(string-constant cancel)
|
||||
#f
|
||||
|
|
@ -806,7 +824,9 @@ If the namespace does not, they are colored the unbound color.
|
|||
[(equal? raw-color "palegreen") "darkgreen"]
|
||||
[else 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
|
||||
(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
|
||||
(interval-map-cons*!
|
||||
arrow-record start end to-add null)])))
|
||||
(inherit get-top-level-window)
|
||||
(inherit get-top-level-window)
|
||||
|
||||
(define/augment (on-change)
|
||||
(inner (void) on-change)
|
||||
|
|
@ -970,20 +990,19 @@ If the namespace does not, they are colored the unbound color.
|
|||
'bold))
|
||||
(send dc set-text-foreground templ-color)
|
||||
(send dc set-alpha 0.5)
|
||||
(hash-for-each tacked-hash-table
|
||||
(λ (arrow v)
|
||||
(when v
|
||||
(cond
|
||||
[(var-arrow? arrow)
|
||||
(if (var-arrow-actual? arrow)
|
||||
(begin (send dc set-pen (get-var-pen 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?))
|
||||
(send dc set-brush (get-tacked-templ-brush white-on-black?))))]
|
||||
[(tail-arrow? arrow)
|
||||
(send dc set-pen (get-tail-pen white-on-black?))
|
||||
(send dc set-brush (get-tacked-tail-brush white-on-black?))])
|
||||
(draw-arrow2 arrow))))
|
||||
(for ([(arrow v) (in-hash tacked-hash-table)])
|
||||
(when v
|
||||
(cond
|
||||
[(var-arrow? arrow)
|
||||
(if (var-arrow-actual? arrow)
|
||||
(begin (send dc set-pen (get-var-pen 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?))
|
||||
(send dc set-brush (get-tacked-templ-brush white-on-black?))))]
|
||||
[(tail-arrow? arrow)
|
||||
(send dc set-pen (get-tail-pen white-on-black?))
|
||||
(send dc set-brush (get-tacked-tail-brush white-on-black?))])
|
||||
(draw-arrow2 arrow)))
|
||||
(when (and cursor-pos
|
||||
cursor-text)
|
||||
(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
|
||||
(define/private (start-arrow-draw-timer delay-ms)
|
||||
(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))
|
||||
|
||||
;; 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))
|
||||
(new menu-item%
|
||||
[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
|
||||
(λ (x y)
|
||||
(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)])
|
||||
(send txt end-edit-sequence)))
|
||||
|
||||
;; position->matching-identifiers-hash : 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?)
|
||||
;; position->matching-identifiers-hash
|
||||
;; : 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 (add-binding-arrow arr)
|
||||
(when (or include-require-arrows?
|
||||
|
|
@ -1337,12 +1360,16 @@ If the namespace does not, they are colored the unbound color.
|
|||
(add-binding-arrow arrow)]
|
||||
[else
|
||||
;; a bound occurrence => find binders
|
||||
(for ([candidate-binder (in-list (fetch-arrow-records (var-arrow-start-text arrow)
|
||||
(var-arrow-start-pos-left arrow)))])
|
||||
(for ([candidate-binder
|
||||
(in-list (fetch-arrow-records (var-arrow-start-text arrow)
|
||||
(var-arrow-start-pos-left arrow)))])
|
||||
(when (var-arrow? candidate-binder)
|
||||
(when (and (equal? (var-arrow-start-text arrow) (var-arrow-start-text 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)))
|
||||
(when (and (equal? (var-arrow-start-text arrow)
|
||||
(var-arrow-start-text 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))))])))))
|
||||
|
||||
(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)))
|
||||
|
||||
(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
|
||||
(let loop ([ed text])
|
||||
(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
|
||||
(colored-region-start 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
|
||||
(send (colored-region-text new-region) highlight-range
|
||||
(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
|
||||
;; callback for the jump popup menu item
|
||||
(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
|
||||
(sort (hash-map identifiers-hash
|
||||
(λ (x y) x))
|
||||
|
|
@ -1694,6 +1724,14 @@ If the namespace does not, they are colored the unbound color.
|
|||
(mixin (drracket:unit:tab<%>) ()
|
||||
(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 (new (fw:text:ports-mixin fw:racket:text%)))
|
||||
(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
|
||||
;; records how a particular check syntax is being played out in the editor right now.
|
||||
;; - #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.
|
||||
;; 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
|
||||
|
|
@ -1827,38 +1866,44 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
(define current-syncheck-running-mode #f)
|
||||
|
||||
(define/public (replay-compile-comp-trace defs-text val)
|
||||
(define bx (box #t))
|
||||
(when (set-syncheck-running-mode bx)
|
||||
|
||||
;; reset any previous check syntax information
|
||||
(let ([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 (send defs-text get-tab) add-bkg-running-color 'syncheck "orchid" cs-syncheck-running)
|
||||
(send defs-text syncheck:init-arrows)
|
||||
(let loop ([val val]
|
||||
[start-time (current-inexact-milliseconds)]
|
||||
[i 0])
|
||||
(cond
|
||||
[(null? val)
|
||||
(send defs-text syncheck:update-blue-boxes)
|
||||
(send defs-text syncheck:update-drawn-arrows)
|
||||
(send (send defs-text get-tab) remove-bkg-running-color 'syncheck)
|
||||
(set-syncheck-running-mode #f)]
|
||||
[(and (i . > . 0) ;; check i just in case things are really strange
|
||||
(20 . <= . (- (current-inexact-milliseconds) start-time)))
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(when (unbox bx)
|
||||
(log-timeline "continuing replay-compile-comp-trace"
|
||||
(loop val (current-inexact-milliseconds) 0))))
|
||||
#f)]
|
||||
[else
|
||||
(process-trace-element defs-text (car val))
|
||||
(loop (cdr val) start-time (+ i 1))]))))
|
||||
(define/public (replay-compile-comp-trace defs-text val bx)
|
||||
(send (send defs-text get-tab) add-bkg-running-color
|
||||
'syncheck "orchid" cs-syncheck-running)
|
||||
(let loop ([val val]
|
||||
[start-time (current-inexact-milliseconds)]
|
||||
[i 0])
|
||||
(cond
|
||||
[(and (null? val) (pair? (unbox bx)))
|
||||
(define new-val (car (unbox bx)))
|
||||
(set-box! bx (cdr (unbox bx)))
|
||||
(loop new-val start-time i)]
|
||||
[(null? val)
|
||||
(send defs-text syncheck:update-blue-boxes)
|
||||
(send defs-text syncheck:update-drawn-arrows)
|
||||
(send (send defs-text get-tab) remove-bkg-running-color 'syncheck)
|
||||
(set-syncheck-running-mode #f)]
|
||||
[(not (unbox bx))
|
||||
;; if we've been asked to stop (because some new results are ready
|
||||
;; and another trace is running).
|
||||
(void)]
|
||||
[(and (i . > . 0) ;; check i just in case things are really strange
|
||||
(20 . <= . (- (current-inexact-milliseconds) start-time)))
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(when (unbox bx)
|
||||
(log-timeline "continuing replay-compile-comp-trace"
|
||||
(loop val (current-inexact-milliseconds) 0))))
|
||||
#f)]
|
||||
[else
|
||||
(process-trace-element defs-text (car val))
|
||||
(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)
|
||||
;; 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)
|
||||
(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)
|
||||
(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)
|
||||
(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)
|
||||
|
|
@ -1932,7 +1978,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
(define/augment (after-percentage-change)
|
||||
(define ps (get-percentages))
|
||||
(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))
|
||||
(super-new))
|
||||
[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?
|
||||
(is-a? (drracket:language-configuration:language-settings-language settings)
|
||||
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)
|
||||
(with-lock/edit-sequence
|
||||
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)
|
||||
(drracket:eval:expand-program
|
||||
#: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
|
||||
(not module-language?)
|
||||
init-proc
|
||||
|
|
@ -2162,7 +2212,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
definitions-text
|
||||
(λ ()
|
||||
(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])
|
||||
(expanded-expression sexp))
|
||||
(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))
|
||||
(fw:color-prefs:add-to-preferences-panel (string-constant check-syntax)
|
||||
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:get/extend:extend-definitions-text make-syncheck-text%)
|
||||
(drracket:get/extend:extend-definitions-canvas docs-editor-canvas-mixin)
|
||||
(drracket:get/extend:extend-unit-frame unit-frame-mixin #f)
|
||||
(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
|
||||
online-comp.rkt
|
||||
'go
|
||||
(λ (defs-text val)
|
||||
(log-timeline
|
||||
"replace-compile-comp-trace"
|
||||
(send (send (send defs-text get-tab) get-frame)
|
||||
replay-compile-comp-trace
|
||||
defs-text
|
||||
val))))))
|
||||
|
||||
|
||||
void)))
|
||||
|
||||
(define wbs '())
|
||||
|
||||
(define-runtime-path online-comp.rkt "online-comp.rkt")
|
||||
|
||||
|
||||
|
||||
|
||||
(define (pick-next-arrow orig-arrows backwards? txt start-pos end-pos)
|
||||
|
||||
(cond
|
||||
[(null? orig-arrows) #f]
|
||||
[(null? (cdr orig-arrows)) (car orig-arrows)]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/place
|
||||
racket/match
|
||||
racket/contract
|
||||
(for-syntax racket/base)
|
||||
"../../private/eval-helpers.rkt"
|
||||
"traversals.rkt"
|
||||
|
|
@ -8,7 +10,7 @@
|
|||
"intf.rkt"
|
||||
"xref.rkt")
|
||||
|
||||
(provide go)
|
||||
(provide go monitor)
|
||||
|
||||
(define obj%
|
||||
(class (annotations-mixin object%)
|
||||
|
|
@ -67,7 +69,8 @@
|
|||
(parameterize (#;[current-custodian orig-cust])
|
||||
(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 ()
|
||||
(define id/name (place-channel-get local-chan))
|
||||
(define id (list-ref id/name 0))
|
||||
|
|
@ -77,7 +80,15 @@
|
|||
(loop))))))
|
||||
(void))
|
||||
|
||||
(define-logger online-check-syntax)
|
||||
(define (go expanded path the-source orig-cust)
|
||||
(define c (make-channel))
|
||||
(log-message online-check-syntax-logger 'info "" 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 stx the-source orig-cust path)
|
||||
(parameterize ([current-max-to-send-at-once 50])
|
||||
(with-handlers ((exn:fail? (λ (x)
|
||||
(printf "exception noticed in online-comp.rkt\n")
|
||||
|
|
@ -97,6 +108,27 @@
|
|||
(make-traversal (current-namespace)
|
||||
(get-init-dir path)))
|
||||
(parameterize ([current-annotations obj])
|
||||
(expanded-expression expanded)
|
||||
(expanded-expression stx)
|
||||
(expansion-completed))
|
||||
(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
|
||||
[(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)))))
|
||||
|
|
|
|||
|
|
@ -278,6 +278,19 @@ all of the names in the tools library, for use defining keybindings
|
|||
preferences panel. The function is passed a panel that contains
|
||||
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
|
||||
drracket:module-language:add-module-language
|
||||
(-> any)
|
||||
|
|
@ -292,6 +305,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
|
||||
@tt{(module name ...)}.})
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user