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

Sorry all; stupid mistake

Browse Source 
This reverts commit 90fc899b36.
This reverts commit 780fb37c0d.
This reverts commit 9e54b2bc1b.
This reverts commit 43a584f710.
This commit is contained in:
Robby Findler 2013-11-02 09:50:32 -05:00
parent 90fc899b36
commit 40f7ab2ba4
16 changed files with 251 additions and 631 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

14
pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt
View File

@ -28,7 +28,6 @@ profile todo:
mrlib/include-bitmap mrlib/include-bitmap
images/compile-time images/compile-time
pkg/lib pkg/lib
syntax/rect
(for-syntax images/icons/misc images/icons/style images/icons/control images/logos) (for-syntax images/icons/misc images/icons/style images/icons/control images/logos)
(for-syntax racket/base) (for-syntax racket/base)
(submod "frame.rkt" install-pkg)) (submod "frame.rkt" install-pkg))
@ -339,13 +338,9 @@ profile todo:
[(pair? stack2) [(pair? stack2)
(list (car stack2))] (list (car stack2))]
[else '()])] [else '()])]
[srcloc-rects (cond
[(and (exn:srcloc-rects? exn)
(exn:srclocs? exn)) ;; only look at the rects when the exn has srclocs
((exn:srcloc-rects-accessor exn) exn)]
[else #f])]
[src-locs-edition (and (pair? src-locs) [src-locs-edition (and (pair? src-locs)
(srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))]) (srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))])
(print-planet-icon-to-stderr exn) (print-planet-icon-to-stderr exn)
(unless (exn:fail:user? exn) (unless (exn:fail:user? exn)
(unless (exn:fail:syntax? exn) (unless (exn:fail:syntax? exn)
@ -367,12 +362,9 @@ profile todo:
(λ () (λ ()
;; need to make sure that the user's eventspace is still the same ;; need to make sure that the user's eventspace is still the same
;; and still running here? ;; and still running here?
(send ints highlight-errors (send ints highlight-errors src-locs (if (null? stack1)
src-locs
(if (null? stack1)
stack2 stack2
stack1) stack1))))))))
srcloc-rects)))))))
(define (srcloc->edition/pair defs ints srcloc [port-name-matches-cache #f]) (define (srcloc->edition/pair defs ints srcloc [port-name-matches-cache #f])
(let ([src (srcloc-source srcloc)]) (let ([src (srcloc-source srcloc)])

1
pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt
View File

@ -187,7 +187,6 @@
(list ''#%foreign (list ''#%foreign
'(lib "mzlib/pconvert-prop.rkt") '(lib "mzlib/pconvert-prop.rkt")
'(lib "planet/terse-info.rkt") '(lib "planet/terse-info.rkt")
'(lib "syntax/rect.rkt")
;; preserve the invariant that: ;; preserve the invariant that:
;; if a module is shared, so ;; if a module is shared, so
;; are all of its submodules ;; are all of its submodules

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

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

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

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

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

@ -10,7 +10,6 @@
racket/math racket/math
racket/match racket/match
racket/set racket/set
racket/place
racket/gui/base racket/gui/base
compiler/embed compiler/embed
compiler/cm compiler/cm
@ -133,7 +132,6 @@
(define default-enforce-module-constants #t) (define default-enforce-module-constants #t)
(define (get-default-auto-text) (preferences:get 'drracket:module-language:auto-text)) (define (get-default-auto-text) (preferences:get 'drracket:module-language:auto-text))
;; module-mixin : (implements drracket:language:language<%>) ;; module-mixin : (implements drracket:language:language<%>)
;; -> (implements drracket:language:language<%>) ;; -> (implements drracket:language:language<%>)
(define (module-mixin %) (define (module-mixin %)
@ -2133,9 +2131,7 @@
(module-language-settings->prefab-module-settings settings) (module-language-settings->prefab-module-settings settings)
(λ (res) (oc-finished res)) (λ (res) (oc-finished res))
(λ (a b) (oc-status-message a b)) (λ (a b) (oc-status-message a b))
(λ (key val) (oc-monitor-value key val)) (get-currently-open-files))]
(get-currently-open-files)
(send dirty/pending-tab get-defs))]
[else [else
(line-of-interest) (line-of-interest)
(send dirty/pending-tab set-oc-status (send dirty/pending-tab set-oc-status
@ -2161,15 +2157,9 @@
(list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h) (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h)
(drracket:module-language-tools:online-expansion-handler-id o-e-h))) (drracket:module-language-tools:online-expansion-handler-id o-e-h)))
(when (equal? this-key that-key) (when (equal? this-key that-key)
(cond
[(drracket:module-language-tools:online-expansion-handler-monitor? o-e-h)
((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h) ((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h)
(send running-tab get-defs) (send running-tab get-defs)
drracket:module-language-tools:done)] val))))
[else
((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h)
(send running-tab get-defs)
val)]))))
(send running-tab set-oc-status (clean #f #f)) (send running-tab set-oc-status (clean #f #f))
(send running-tab set-dep-paths (list->set (vector-ref res 2)) #f)] (send running-tab set-dep-paths (list->set (vector-ref res 2)) #f)]
@ -2189,19 +2179,6 @@
(line-of-interest) (line-of-interest)
(send running-tab set-oc-status (running sym str)))) (send running-tab set-oc-status (running sym str))))
(define/oc-log (oc-monitor-value key val)
(define-values (running-tab dirty/pending-tab dirty-tabs clean-tabs) (get-current-oc-state))
(when running-tab
(line-of-interest)
(for ([handler (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
(when (equal? (list (drracket:module-language-tools:online-expansion-handler-mod-path handler)
(drracket:module-language-tools:online-expansion-handler-id handler))
key)
(line-of-interest)
((drracket:module-language-tools:online-expansion-handler-local-handler handler)
(send running-tab get-defs)
val)))))
;; get-focus-tab : -> (or/c tab #f) ;; get-focus-tab : -> (or/c tab #f)
(define (get-focus-tab) (define (get-focus-tab)
(define tlw (get-top-level-focus-window)) (define tlw (get-top-level-focus-window))
@ -2235,9 +2212,7 @@
prefab-module-settings prefab-module-settings
show-results show-results
tell-the-tab-show-bkg-running tell-the-tab-show-bkg-running
monitor-status currently-open-files)
currently-open-files
defs)
(unless expanding-place (unless expanding-place
(set! expanding-place (dynamic-place expanding-place.rkt 'start)) (set! expanding-place (dynamic-place expanding-place.rkt 'start))
(place-channel-put expanding-place module-language-compile-lock) (place-channel-put expanding-place module-language-compile-lock)
@ -2245,15 +2220,7 @@
expanding-place expanding-place
(for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))]) (for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
(list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h) (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h)
(drracket:module-language-tools:online-expansion-handler-id o-e-h) (drracket:module-language-tools:online-expansion-handler-id o-e-h)))))
(drracket:module-language-tools:online-expansion-handler-monitor? o-e-h)))))
(for ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
(when (drracket:module-language-tools:online-expansion-handler-monitor? o-e-h)
((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h)
defs
drracket:module-language-tools:start)))
(set-pending-thread (set-pending-thread
tell-the-tab-show-bkg-running tell-the-tab-show-bkg-running
(thread (λ () (thread (λ ()
@ -2281,27 +2248,14 @@
(pending-tell-the-tab-show-bkg-running (pending-tell-the-tab-show-bkg-running
'finished-expansion 'finished-expansion
sc-online-expansion-running))))))) sc-online-expansion-running)))))))
;; 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)) (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 (queue-callback
(λ () (λ ()
(when (eq? us pending-thread) (when (eq? us pending-thread)
(set-pending-thread #f #f)) (set-pending-thread #f #f))
(when (getenv "PLTDRPLACEPRINT") (when (getenv "PLTDRPLACEPRINT")
(printf "PLTDRPLACEPRINT: got results back from the place\n")) (printf "PLTDRPLACEPRINT: got results back from the place\n"))
(show-results res)))])))))) (show-results res)))))))
(define (stop-place-running) (define (stop-place-running)
(when expanding-place (when expanding-place

70
pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt
View File

@ -23,7 +23,6 @@ TODO
racket/port racket/port
racket/set racket/set
syntax/rect
string-constants string-constants
setup/xref setup/xref
racket/gui/base racket/gui/base
@ -551,66 +550,10 @@ TODO
;; error-ranges : (union false? (cons srcloc (listof srcloc))) ;; error-ranges : (union false? (cons srcloc (listof srcloc)))
(define error-ranges #f) (define error-ranges #f)
(define/public (get-error-ranges) error-ranges) (define/public (get-error-ranges) error-ranges)
(define/public (set-error-ranges srclocs [srcloc-rects #f]) (define/public (set-error-ranges ranges)
(define candidate-srclocs (set! error-ranges (and ranges
(and srclocs (not (null? ranges))
(not (null? srclocs)) (cleanup-locs ranges))))
(cleanup-locs srclocs)))
(cond
[(and candidate-srclocs srcloc-rects)
(set! error-ranges
(apply
append
(for/list ([srcloc (in-list candidate-srclocs)])
(define pending-range-start #f)
(define pending-range-end #f)
(define srclocs '())
(for ([pos (in-range (srcloc-position srcloc)
(+ (srcloc-position srcloc)
(srcloc-span srcloc)))])
(define keep-pos?
(for/or ([srcloc-rect (in-list srcloc-rects)]
#:when (equal? (srcloc-rect-source srcloc-rect)
(srcloc-source range)))
(pos-in-rect? pos srcloc-rect)))
(when keep-pos?
(cond
[(not pending-range-start)
(set! pending-range-start pos)
(set! pending-range-end pos)]
[(= (+ pending-range-end 1) pos)
(set! pending-range-end pos)]
[else
(set! srclocs (cons (srcloc (srcloc-source srcloc)
#f #f
pending-range-start
(- pending-range-end pending-range-start))
srclocs))
(set! pending-range-start pos)
(set! pending-range-end pos)])))
srclocs)))]
[else
(set! error-ranges candidate-srclocs)]))
(define/private (pos-in-rect? pos srcloc-rect)
(define src (srcloc-rect-source srcloc-rect))
(define height (srcloc-rect-height srcloc-rect))
(define width (srcloc-rect-width srcloc-rect))
(cond
[(is-a? src text%)
(define start-para (send src position-paragraph (srcloc-rect-pos srcloc-rect)))
(define para-offset (- (srcloc-rect-pos srcloc-rect) start-para))
(let loop ([this-line-start (srcloc-rect-pos srcloc-rect)]
[y 0])
(cond
[(= y height) #f]
[(<= this-line-start pos (+ this-line-start width)) #t]
[else
(loop (+ (send src paragraph-start-position (+ start-para y)) para-offset)
(+ y 1))]))]
[else #f]))
(define clear-error-highlighting void) (define clear-error-highlighting void)
(define/public (reset-error-ranges) (define/public (reset-error-ranges)
(set-error-ranges #f) (set-error-ranges #f)
@ -634,12 +577,11 @@ TODO
;; =Kernel= =handler= ;; =Kernel= =handler=
;; highlight-errors : (listof srcloc) ;; highlight-errors : (listof srcloc)
;; (union #f (listof srcloc)) ;; (union #f (listof srcloc))
;; (union #f (listof srcloc-rect))
;; -> (void) ;; -> (void)
(define/public (highlight-errors raw-locs [raw-error-arrows #f] [srcloc-rects #f]) (define/public (highlight-errors raw-locs [raw-error-arrows #f])
(clear-error-highlighting) (clear-error-highlighting)
(when definitions-text (send definitions-text set-error-arrows #f)) (when definitions-text (send definitions-text set-error-arrows #f))
(set-error-ranges raw-locs srcloc-rects) (set-error-ranges raw-locs)
(define locs (or (get-error-ranges) '())) ;; calling set-error-range cleans up the locs (define locs (or (get-error-ranges) '())) ;; calling set-error-range cleans up the locs
(define error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))) (define error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows)))

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

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

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

@ -1,8 +1,6 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/place racket/place
racket/match
racket/contract
(for-syntax racket/base) (for-syntax racket/base)
"../../private/eval-helpers.rkt" "../../private/eval-helpers.rkt"
"traversals.rkt" "traversals.rkt"
@ -10,7 +8,7 @@
"intf.rkt" "intf.rkt"
"xref.rkt") "xref.rkt")
(provide go monitor) (provide go)
(define obj% (define obj%
(class (annotations-mixin object%) (class (annotations-mixin object%)
@ -69,8 +67,7 @@
(parameterize (#;[current-custodian orig-cust]) (parameterize (#;[current-custodian orig-cust])
(thread (thread
(λ () (λ ()
(with-handlers ([exn:fail? (λ (x) (eprintf "online-comp.rkt: thread failed ~a\n" (with-handlers ((exn:fail? (λ (x) (eprintf "online-comp.rkt: thread failed ~a\n" (exn-message x)))))
(exn-message x)))])
(let loop () (let loop ()
(define id/name (place-channel-get local-chan)) (define id/name (place-channel-get local-chan))
(define id (list-ref id/name 0)) (define id (list-ref id/name 0))
@ -80,15 +77,7 @@
(loop)))))) (loop))))))
(void)) (void))
(define-logger online-check-syntax)
(define (go expanded path the-source orig-cust) (define (go expanded path the-source orig-cust)
(define c (make-channel))
(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]) (parameterize ([current-max-to-send-at-once 50])
(with-handlers ((exn:fail? (λ (x) (with-handlers ((exn:fail? (λ (x)
(printf "exception noticed in online-comp.rkt\n") (printf "exception noticed in online-comp.rkt\n")
@ -108,27 +97,6 @@
(make-traversal (current-namespace) (make-traversal (current-namespace)
(get-init-dir path))) (get-init-dir path)))
(parameterize ([current-annotations obj]) (parameterize ([current-annotations obj])
(expanded-expression stx) (expanded-expression expanded)
(expansion-completed)) (expansion-completed))
(send obj get-trace)))) (send obj get-trace))))
(define (monitor send-back path the-source orig-cust)
(define lr (make-log-receiver (current-logger)
'info
'online-check-syntax))
(thread
(λ ()
(let loop ()
(define val (sync lr))
(match val
[(vector level message obj name)
(cond
[(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)))))

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

@ -278,19 +278,6 @@ all of the names in the tools library, for use defining keybindings
preferences panel. The function is passed a panel that contains preferences panel. The function is passed a panel that contains
other configuration controls for online expansion.}) other configuration controls for online expansion.})
(proc-doc/names
drracket:module-language-tools:done?
(-> any/c boolean?)
(val)
@{Returns @racket[#t] for @racket[drracket:module-language-tools:done]
and @racket[#f] otherwise.})
(thing-doc
drracket:module-language-tools:done
drracket:module-language-tools:done?
@{Used to inform a monitor-based handler that the online expansion has finished.})
(proc-doc/names (proc-doc/names
drracket:module-language:add-module-language drracket:module-language:add-module-language
(-> any) (-> any)
@ -306,7 +293,6 @@ all of the names in the tools library, for use defining keybindings
@tt{(module name ...)}.}) @tt{(module name ...)}.})
; ;
; ;
; ;

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

@ -34,8 +34,6 @@
(type-alias-env-map (lambda (id ty) (type-alias-env-map (lambda (id ty)
(cons (syntax-e id) ty)))))) (cons (syntax-e id) ty))))))
(define-logger online-check-syntax)
(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx init checker pre-result post-result . body) (define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx init checker pre-result post-result . body)
(tc-setup/proc orig-stx stx expand-ctxt init checker (tc-setup/proc orig-stx stx expand-ctxt init checker
(λ (fully-expanded-stx pre-result post-result) (λ (fully-expanded-stx pre-result post-result)

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt
View File

@ -12,7 +12,6 @@
(define (reset-type-table) (set! table (make-hasheq))) (define (reset-type-table) (set! table (make-hasheq)))
(define (add-typeof-expr e t) (define (add-typeof-expr e t)
(log-message online-check-syntax-logger 'info #f "type of expression" (list e t))
(when (optimize?) (when (optimize?)
(hash-update! table e (hash-update! table e
;; when typechecking a case-> type, types get added for ;; when typechecking a case-> type, types get added for
@ -31,7 +30,6 @@
(ret (map Un old-ts t-ts))] (ret (map Un old-ts t-ts))]
[(_ _) t])) ; irrelevant to the optimizer, just clobber [(_ _) t])) ; irrelevant to the optimizer, just clobber
t))) t)))
(define-logger online-check-syntax)
(define (type-of e) (define (type-of e)
(hash-ref table e (hash-ref table e

33
racket/collects/racket/contract/private/provide.rkt
View File

@ -24,10 +24,14 @@
"guts.rkt" "guts.rkt"
"misc.rkt" "misc.rkt"
"exists.rkt" "exists.rkt"
"opt.rkt"
syntax/location syntax/location
syntax/srcloc) syntax/srcloc)
(define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)]))
(define-for-syntax (self-ctor-transformer orig stx) (define-for-syntax (self-ctor-transformer orig stx)
(with-syntax ([orig orig]) (with-syntax ([orig orig])
(syntax-case stx () (syntax-case stx ()
@ -368,10 +372,12 @@
#t))] #t))]
[mutator-ids (reverse (list-ref the-struct-info 4))] ;; (listof (union #f identifier)) [mutator-ids (reverse (list-ref the-struct-info 4))] ;; (listof (union #f identifier))
[field-contract-ids (map (λ (field-name field-contract) [field-contract-ids (map (λ (field-name field-contract)
(if (a:known-good-contract? field-contract)
field-contract
(a:mangle-id provide-stx (a:mangle-id provide-stx
"provide/contract-field-contract" "provide/contract-field-contract"
field-name field-name
struct-name)) struct-name)))
field-names field-names
field-contracts)] field-contracts)]
[struct:struct-name [struct:struct-name
@ -526,9 +532,11 @@
[(field-contract-id-definitions ...) [(field-contract-id-definitions ...)
(filter values (map (λ (field-contract-id field-contract) (filter values (map (λ (field-contract-id field-contract)
(if (a:known-good-contract? field-contract)
#f
(with-syntax ([field-contract-id field-contract-id] (with-syntax ([field-contract-id field-contract-id]
[field-contract field-contract]) [field-contract field-contract])
#'(define field-contract-id (opt/c field-contract #:error-name provide/contract)))) #`(define field-contract-id (verify-contract '#,who field-contract)))))
field-contract-ids field-contract-ids
field-contracts))] field-contracts))]
[(field-contracts ...) field-contracts] [(field-contracts ...) field-contracts]
@ -734,14 +742,17 @@
(define (code-for-one-id/new-name stx id reflect-id ctrct/no-prop user-rename-id (define (code-for-one-id/new-name stx id reflect-id ctrct/no-prop user-rename-id
[mangle-for-maker? #f] [mangle-for-maker? #f]
[provide? #t]) [provide? #t])
(let ([ex-id (or reflect-id id)] (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct/no-prop)]
[ex-id (or reflect-id id)]
[ctrct (syntax-property ctrct/no-prop [ctrct (syntax-property ctrct/no-prop
'racket/contract:contract-on-boundary 'racket/contract:contract-on-boundary
(gensym 'provide/contract-boundary))]) (gensym 'provide/contract-boundary))])
(with-syntax ([id-rename (id-for-one-id user-rename-id reflect-id id mangle-for-maker?)] (with-syntax ([id-rename (id-for-one-id user-rename-id reflect-id id mangle-for-maker?)]
[contract-id (a:mangle-id provide-stx [contract-id (if no-need-to-check-ctrct?
ctrct
(a:mangle-id provide-stx
"provide/contract-contract-id" "provide/contract-contract-id"
(or user-rename-id ex-id))] (or user-rename-id ex-id)))]
[pos-stx (datum->syntax id 'here)] [pos-stx (datum->syntax id 'here)]
[id id] [id id]
[ex-id ex-id] [ex-id ex-id]
@ -759,11 +770,11 @@
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(define contract-id #,@(if no-need-to-check-ctrct?
;; let is here to give the right name. (list)
(let ([ex-id (opt/c ctrct #:error-name provide/contract)]) (list #`(define contract-id
ex-id)) (let ([ex-id ctrct]) ;; let is here to give the right name.
(verify-contract '#,who ex-id)))))
(define-syntax id-rename (define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id) (make-provide/contract-transformer (quote-syntax contract-id)
(a:update-loc (a:update-loc

16
racket/collects/racket/contract/region.rkt
View File

@ -19,14 +19,14 @@
"private/arrow.rkt" "private/arrow.rkt"
"private/base.rkt" "private/base.rkt"
"private/guts.rkt" "private/guts.rkt"
"private/misc.rkt" "private/misc.rkt")
"private/opt.rkt")
;; These are useful for all below. ;; These are useful for all below.
(define-syntax (add-opt-contract stx) (define-syntax (verify-contract stx)
(syntax-case stx () (syntax-case stx ()
[(_ x) #'(opt/c x #:error-name with-contract)])) [(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)]))
@ -688,14 +688,14 @@
(with-syntax ([new-stx (add-context #'(syntax-parameterize (with-syntax ([new-stx (add-context #'(syntax-parameterize
([current-contract-region (λ (stx) #'blame-stx)]) ([current-contract-region (λ (stx) #'blame-stx)])
(let-values ([(res ...) (let () . body)]) (let-values ([(res ...) (let () . body)])
(values (contract (add-opt-contract rc.ctc) (values (contract (verify-contract 'with-contract rc.ctc)
res res
blame-stx blame-stx
blame-id) ...))))]) blame-id) ...))))])
(syntax/loc stx (syntax/loc stx
(let () (let ()
(define-values (free-ctc-id ...) (define-values (free-ctc-id ...)
(values (add-opt-contract free-ctc) ...)) (values (verify-contract 'with-contract free-ctc) ...))
(define blame-id (define blame-id
(current-contract-region)) (current-contract-region))
(define-values () (define-values ()
@ -757,7 +757,7 @@
(syntax/loc stx (syntax/loc stx
(begin (begin
(define-values (free-ctc-id ...) (define-values (free-ctc-id ...)
(values (add-opt-contract free-ctc) ...)) (values (verify-contract 'with-contract free-ctc) ...))
(define blame-id (define blame-id
(current-contract-region)) (current-contract-region))
(define-values () (define-values ()
@ -787,7 +787,7 @@
ext-id ext-id
(contract ctc-id true-p blame-stx blame-id (quote ext-id) (quote-srcloc ext-id)) (contract ctc-id true-p blame-stx blame-id (quote ext-id) (quote-srcloc ext-id))
ctc-id ctc-id
(add-opt-contract ctc)) (verify-contract 'with-contract ctc))
...) ...)
blame-stx blame-stx
. .

24
racket/collects/syntax/rect.rkt
View File

@ -1,24 +0,0 @@
#lang racket/base
(provide (struct-out exn:fail:syntax/rects)
(struct-out exn:fail:read/rects)
(struct-out exn:fail:read:eof/rects)
(struct-out exn:fail:read:non-char/rects)
(struct-out srcloc-rect)
prop:exn:srcloc-rects
exn:srcloc-rects?
exn:srcloc-rects-accessor)
(define-values (prop:exn:srcloc-rects exn:srcloc-rects? exn:srcloc-rects-accessor)
(make-struct-type-property 'exn:srcloc-rects))
(struct exn:fail:syntax/rects exn:fail:syntax (rects)
#:property prop:exn:srcloc-rects (λ (x) (exn:fail:syntax/rects-rects x)))
(struct exn:fail:read/rects exn:fail:read (rects)
#:property prop:exn:srcloc-rects (λ (x) (exn:fail:read/rects-rects x)))
(struct exn:fail:read:eof/rects exn:fail:read:eof (rects)
#:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:eof/rects-rects x)))
(struct exn:fail:read:non-char/rects exn:fail:read:non-char (rects)
#:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:non-char/rects-rects x)))
(struct srcloc-rect (source pos width height) #:transparent)

24
racket/lib/collects/syntax/rect.rkt
View File

@ -1,24 +0,0 @@
#lang racket/base
(provide (struct-out exn:fail:syntax/rects)
(struct-out exn:fail:read/rects)
(struct-out exn:fail:read:eof/rects)
(struct-out exn:fail:read:non-char/rects)
(struct-out srcloc-rect)
prop:exn:srcloc-rects
exn:srcloc-rects?
exn:srcloc-rects-accessor)
(define-values (prop:exn:srcloc-rects exn:srcloc-rects? exn:srcloc-rects-accessor)
(make-struct-type-property 'exn:srcloc-rects))
(struct exn:fail:syntax/rects exn:fail:syntax (rects)
#:property prop:exn:srcloc-rects (λ (x) (exn:fail:syntax/rects-rects x)))
(struct exn:fail:read/rects exn:fail:read (rects)
#:property prop:exn:srcloc-rects (λ (x) (exn:fail:read/rects-rects x)))
(struct exn:fail:read:eof/rects exn:fail:read:eof (rects)
#:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:eof/rects-rects x)))
(struct exn:fail:read:non-char/rects exn:fail:read:non-char (rects)
#:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:non-char/rects-rects x)))
(struct srcloc-rect (source pos width height) #:transparent)