adjust check syntax so it can show info before expansion completes
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
parent
c7d688df22
commit
09920bd8ce
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
------------------------------
|
||||
|
|
|
|||
|
|
@ -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 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])
|
||||
|
|
@ -250,6 +277,13 @@
|
|||
(λ (exn+loaded-paths)
|
||||
(place-channel-put pc-status-expanding-place 'exn-raised)
|
||||
(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
|
||||
(cond
|
||||
[(exn:access? main-exn)
|
||||
|
|
@ -318,7 +352,7 @@
|
|||
exn-infos
|
||||
(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)
|
||||
(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)
|
||||
(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) '()))
|
||||
;; 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 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,7 +332,18 @@
|
|||
|
||||
(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)
|
||||
(cond
|
||||
|
|
@ -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 %)
|
||||
|
|
@ -2122,7 +2124,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
|
||||
|
|
@ -2148,9 +2152,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)]
|
||||
|
|
@ -2170,6 +2180,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))
|
||||
|
|
@ -2203,7 +2226,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)
|
||||
|
|
@ -2211,7 +2236,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 (λ ()
|
||||
|
|
@ -2239,14 +2272,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)
|
||||
(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))])))
|
||||
|
||||
;; 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 (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,16 @@
|
|||
(loop))))))
|
||||
(void))
|
||||
|
||||
(define-logger online-check-syntax)
|
||||
(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])
|
||||
(with-handlers ((exn:fail? (λ (x)
|
||||
(printf "exception noticed in online-comp.rkt\n")
|
||||
|
|
@ -97,6 +109,28 @@
|
|||
(make-traversal (current-namespace)
|
||||
(get-init-dir path)))
|
||||
(parameterize ([current-annotations obj])
|
||||
(expanded-expression expanded)
|
||||
(for ([stx (in-list stxes)])
|
||||
(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
|
||||
[(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)))))
|
||||
|
|
|
|||
|
|
@ -205,7 +205,6 @@
|
|||
[else
|
||||
(loop fst)
|
||||
(body-loop (car bodies) (cdr bodies))]))))
|
||||
|
||||
(syntax-case* stx-obj (#%plain-lambda case-lambda if begin begin0 let-values letrec-values
|
||||
set! quote quote-syntax with-continuation-mark
|
||||
#%plain-app #%top #%plain-module-begin
|
||||
|
|
|
|||
|
|
@ -227,19 +227,25 @@ all of the names in the tools library, for use defining keybindings
|
|||
void?)
|
||||
(mod-path id local-handler)
|
||||
@{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
|
||||
@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
|
||||
that separate place, @racket[expand]s the program there, and then supplies
|
||||
the fully expanded object to that first procedure. (The procedure is called
|
||||
in the same context as the expansion process.)
|
||||
|
||||
The contract for that procedure is
|
||||
@racketblock[(-> syntax? path? any/c custodian?
|
||||
any)]
|
||||
There are three other arguments.
|
||||
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
|
||||
@racketblock[(-> (or/c syntax? exn?) path? any/c custodian?
|
||||
any)]
|
||||
There are three other arguments:
|
||||
@itemize[
|
||||
@item{
|
||||
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,
|
||||
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
|
||||
drracket:module-language-tools:register-online-expansion-pref
|
||||
(-> (-> (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
|
||||
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)
|
||||
|
|
@ -293,6 +355,7 @@ all of the names in the tools library, for use defining keybindings
|
|||
@tt{(module name ...)}.})
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
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}
|
||||
|
||||
The teaching language are implemented via the tools interface and thus
|
||||
|
|
|
|||
|
|
@ -42,6 +42,8 @@
|
|||
.
|
||||
body)))
|
||||
|
||||
(define-logger online-check-syntax)
|
||||
|
||||
(define (tc-setup/proc orig-stx stx expand-ctxt init checker f)
|
||||
(set-box! typed-context? #t)
|
||||
;(start-timing (syntax-property stx 'enclosing-module-name))
|
||||
|
|
@ -62,6 +64,12 @@
|
|||
(when (show-input?)
|
||||
(pretty-print (syntax->datum fully-expanded-stx)))
|
||||
(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)
|
||||
(do-time "Initialized Envs")
|
||||
(find-mutated-vars fully-expanded-stx mvar-env)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user