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^
(add-opt-out-toolbar-button
add-online-expansion-handler
add-online-expansion-monitor
register-online-expansion-pref
done
done?
start
start?))
register-online-expansion-pref))
(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 monitor?))
(struct online-expansion-handler (mod-path id local-handler))
get-online-expansion-handlers
no-more-online-expansion-handlers))

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

@ -28,7 +28,6 @@ profile todo:
mrlib/include-bitmap
images/compile-time
pkg/lib
syntax/rect
(for-syntax images/icons/misc images/icons/style images/icons/control images/logos)
(for-syntax racket/base)
(submod "frame.rkt" install-pkg))
@ -339,13 +338,9 @@ profile todo:
[(pair? stack2)
(list (car stack2))]
[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)
(srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))])
(print-planet-icon-to-stderr exn)
(unless (exn:fail:user? 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
;; and still running here?
(send ints highlight-errors
src-locs
(if (null? stack1)
stack2
stack1)
srcloc-rects)))))))
(send ints highlight-errors src-locs (if (null? stack1)
stack2
stack1))))))))
(define (srcloc->edition/pair defs ints srcloc [port-name-matches-cache #f])
(let ([src (srcloc-source srcloc)])

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

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

53
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 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)
;; 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)
(struct handler (key proc))
(define handlers '())
(define module-language-parallel-lock-client
@ -42,15 +39,10 @@
(current-custodian)))
;; get the handlers in a second message
(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)))))
(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))))
(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
@ -108,23 +100,6 @@
(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")
@ -211,14 +186,12 @@
(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)]
#:unless (handler-monitor-pc handler))
(define proc-res
((handler-proc handler) expanded
path
the-source
orig-cust))
(list (handler-key handler) proc-res)))
(for/list ([handler (in-list handlers)])
(list (handler-key handler)
((handler-proc handler) expanded
path
the-source
orig-cust))))
(ep-log-info "expanding-place.rkt: 11 handlers finished")
(parameterize ([current-custodian orig-cust])
@ -345,7 +318,7 @@
exn-infos
(list-ref exn+loaded-paths 1)))))))))
(job cust #;response-pc working-thd stop-watching-abnormal-termination))
(job cust response-pc working-thd stop-watching-abnormal-termination))
(define (catch-and-log port sema)
(let loop ()

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

@ -3,7 +3,6 @@
(require mrlib/switchable-button
mrlib/bitmap-label
racket/contract
racket/place
framework
racket/unit
racket/class
@ -33,8 +32,7 @@
(define-local-member-name
set-lang-toolbar-buttons
get-lang-toolbar-buttons
get-online-expansion-monitor-pcs)
get-lang-toolbar-buttons)
(define tab-mixin
(mixin (drracket:unit:tab<%>) (drracket:module-language-tools:tab<%>)
@ -162,26 +160,21 @@
(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
@ -211,35 +204,28 @@
(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) '()]
@ -248,47 +234,46 @@
(if (= 3 (length button))
(append button (list #f))
button))]))
(define tab (get-tab))
(define frame (send tab get-frame))
(send frame when-initialized
(λ ()
(send frame begin-container-sequence)
;; avoid any time with both sets of buttons in the
;; panel so the window doesn't get too wide
(send (send frame get-toolbar-button-panel) change-children (λ (prev) '()))
(define directly-specified-buttons
(map (λ (button-spec)
(new switchable-button%
[label (list-ref button-spec 0)]
[bitmap (list-ref button-spec 1)]
[parent (send frame get-toolbar-button-panel)]
[callback
(lambda (button)
((list-ref button-spec 2) frame))]))
cleaned-up-buttons))
(define directly-specified-button-numbers
(map (λ (button-spec) (list-ref button-spec 3))
cleaned-up-buttons))
(define opt-out-buttons+numbers
(cond
[(eq? opt-out-ids #f) '()]
[else
(for/list ([opt-out-toolbar-button (in-list opt-out-toolbar-buttons)]
#:unless (member
(opt-out-toolbar-button-id opt-out-toolbar-button)
opt-out-ids))
(list ((opt-out-toolbar-button-make-button opt-out-toolbar-button)
frame
(send frame get-toolbar-button-panel))
(opt-out-toolbar-button-number opt-out-toolbar-button)))]))
(send tab set-lang-toolbar-buttons
(append directly-specified-buttons
(map (λ (x) (list-ref x 0)) opt-out-buttons+numbers))
(append directly-specified-button-numbers
(map (λ (x) (list-ref x 1)) opt-out-buttons+numbers)))
(send frame end-container-sequence))))
(let* ([tab (get-tab)]
[frame (send tab get-frame)])
(send frame when-initialized
(λ ()
(send frame begin-container-sequence)
;; avoid any time with both sets of buttons in the panel so the window doesn't get too wide
(send (send frame get-toolbar-button-panel) change-children (λ (prev) '()))
(let ([directly-specified-buttons
(map (λ (button-spec)
(new switchable-button%
[label (list-ref button-spec 0)]
[bitmap (list-ref button-spec 1)]
[parent (send frame get-toolbar-button-panel)]
[callback
(lambda (button)
((list-ref button-spec 2) frame))]))
cleaned-up-buttons)]
[directly-specified-button-numbers (map (λ (button-spec) (list-ref button-spec 3))
cleaned-up-buttons)]
[opt-out-buttons+numbers
(if (eq? opt-out-ids #f)
'()
(map
(λ (opt-out-toolbar-button)
(list ((opt-out-toolbar-button-make-button opt-out-toolbar-button)
frame
(send frame get-toolbar-button-panel))
(opt-out-toolbar-button-number opt-out-toolbar-button)))
(filter (λ (opt-out-toolbar-button)
(not (member (opt-out-toolbar-button-id opt-out-toolbar-button)
opt-out-ids)))
opt-out-toolbar-buttons)))])
(send tab set-lang-toolbar-buttons
(append directly-specified-buttons
(map (λ (x) (list-ref x 0)) opt-out-buttons+numbers))
(append directly-specified-button-numbers
(map (λ (x) (list-ref x 1)) opt-out-buttons+numbers))))
(send frame end-container-sequence)))))
(inherit get-text)
(define/private (get-lang-name pos)
@ -304,21 +289,6 @@
(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)
@ -332,20 +302,9 @@
(define no-more-online-expansion-handlers? #f)
(define (no-more-online-expansion-handlers) (set! no-more-online-expansion-handlers? #t))
(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?))
(struct online-expansion-handler (mod-path id local-handler))
(define online-expansion-handlers '())
(define (get-online-expansion-handlers)
(define (get-online-expansion-handlers)
(cond
[no-more-online-expansion-handlers?
online-expansion-handlers]
@ -353,32 +312,15 @@
(error 'get-online-expansion-handlers
"online-expansion-handlers can still be registered")]))
(define (add-online-expansion-handler mod-path id local-handler)
(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))))
(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))]))
(define online-expansion-pref-funcs '())
(define (get-online-expansion-pref-funcs) online-expansion-pref-funcs)

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

@ -10,7 +10,6 @@
racket/math
racket/match
racket/set
racket/place
racket/gui/base
compiler/embed
compiler/cm
@ -133,7 +132,6 @@
(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 %)
@ -2133,9 +2131,7 @@
(module-language-settings->prefab-module-settings settings)
(λ (res) (oc-finished res))
(λ (a b) (oc-status-message a b))
(λ (key val) (oc-monitor-value key val))
(get-currently-open-files)
(send dirty/pending-tab get-defs))]
(get-currently-open-files))]
[else
(line-of-interest)
(send dirty/pending-tab set-oc-status
@ -2146,7 +2142,7 @@
#f))))
(oc-maybe-start-something)])))
(define/oc-log (oc-finished res)
(define/oc-log (oc-finished res)
(define-values (running-tab dirty/pending-tab dirty-tabs clean-tabs) (get-current-oc-state))
(when running-tab
(cond
@ -2161,15 +2157,9 @@
(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)
(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)]))))
((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)]
@ -2189,19 +2179,6 @@
(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))
@ -2235,9 +2212,7 @@
prefab-module-settings
show-results
tell-the-tab-show-bkg-running
monitor-status
currently-open-files
defs)
currently-open-files)
(unless expanding-place
(set! expanding-place (dynamic-place expanding-place.rkt 'start))
(place-channel-put expanding-place module-language-compile-lock)
@ -2245,15 +2220,7 @@
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-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)))
(drracket:module-language-tools:online-expansion-handler-id o-e-h)))))
(set-pending-thread
tell-the-tab-show-bkg-running
(thread (λ ()
@ -2281,27 +2248,14 @@
(pending-tell-the-tab-show-bkg-running
'finished-expansion
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))
(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 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)))))))
(define (stop-place-running)
(when expanding-place

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

@ -23,7 +23,6 @@ TODO
racket/port
racket/set
syntax/rect
string-constants
setup/xref
racket/gui/base
@ -551,66 +550,10 @@ TODO
;; error-ranges : (union false? (cons srcloc (listof srcloc)))
(define error-ranges #f)
(define/public (get-error-ranges) error-ranges)
(define/public (set-error-ranges srclocs [srcloc-rects #f])
(define candidate-srclocs
(and srclocs
(not (null? srclocs))
(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/public (set-error-ranges ranges)
(set! error-ranges (and ranges
(not (null? ranges))
(cleanup-locs ranges))))
(define clear-error-highlighting void)
(define/public (reset-error-ranges)
(set-error-ranges #f)
@ -634,12 +577,11 @@ TODO
;; =Kernel= =handler=
;; highlight-errors : (listof srcloc)
;; (union #f (listof srcloc))
;; (union #f (listof srcloc-rect))
;; -> (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)
(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 error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows)))
@ -693,7 +635,7 @@ TODO
(send tlw ensure-defs-shown))))
(send first-file set-caret-owner (get-focus-snip) 'global))))
;; unlike highlight-error just above, this function does not change
;; what the currently noted errors locations are, it just highlights
;; one of them.

268
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?)
(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
@ -559,11 +552,9 @@ 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))))
@ -635,18 +626,13 @@ 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
@ -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)
(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))
@ -717,8 +702,7 @@ 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)))
@ -727,8 +711,7 @@ 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))))
@ -741,9 +724,8 @@ 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
@ -824,9 +806,7 @@ 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
@ -898,7 +878,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)
@ -990,19 +970,20 @@ 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)
(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)))
(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))))
(when (and cursor-pos
cursor-text)
(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
(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
@ -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))
(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)])
@ -1337,10 +1316,8 @@ 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?
@ -1360,16 +1337,12 @@ 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))
@ -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)))
(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
@ -1476,8 +1448,7 @@ 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)
@ -1576,8 +1547,7 @@ 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))
@ -1724,14 +1694,6 @@ 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)
@ -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
;; 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
@ -1866,44 +1827,38 @@ 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 bx)
(send (send defs-text get-tab) add-bkg-running-color
'syncheck "orchid" cs-syncheck-running)
(let loop ([val val]
[start-time (current-inexact-milliseconds)]
[i 0])
(cond
[(and (null? val) (pair? (unbox bx)))
(define new-val (car (unbox bx)))
(set-box! bx (cdr (unbox bx)))
(loop new-val start-time i)]
[(null? val)
(send defs-text syncheck:update-blue-boxes)
(send defs-text syncheck:update-drawn-arrows)
(send (send defs-text get-tab) remove-bkg-running-color 'syncheck)
(set-syncheck-running-mode #f)]
[(not (unbox bx))
;; if we've been asked to stop (because some new results are ready
;; and another trace is running).
(void)]
[(and (i . > . 0) ;; check i just in case things are really strange
(20 . <= . (- (current-inexact-milliseconds) start-time)))
(queue-callback
(λ ()
(when (unbox bx)
(log-timeline "continuing replay-compile-comp-trace"
(loop val (current-inexact-milliseconds) 0))))
#f)]
[else
(process-trace-element defs-text (car val))
(loop (cdr val) start-time (+ i 1))])))
(define/public (reset-previous-check-syntax-information defs-text)
(define tab (send defs-text get-tab))
(send tab syncheck:clear-error-message)
(send tab syncheck:clear-highlighting)
(send defs-text syncheck:reset-docs-im)
(send defs-text syncheck:init-arrows))
(define/public (replay-compile-comp-trace defs-text val)
(define bx (box #t))
(when (set-syncheck-running-mode bx)
;; reset any previous check syntax information
(let ([tab (send defs-text get-tab)])
(send tab syncheck:clear-error-message)
(send tab syncheck:clear-highlighting)
(send defs-text syncheck:reset-docs-im))
(send (send defs-text get-tab) add-bkg-running-color 'syncheck "orchid" cs-syncheck-running)
(send defs-text syncheck:init-arrows)
(let loop ([val val]
[start-time (current-inexact-milliseconds)]
[i 0])
(cond
[(null? val)
(send defs-text syncheck:update-blue-boxes)
(send defs-text syncheck:update-drawn-arrows)
(send (send defs-text get-tab) remove-bkg-running-color 'syncheck)
(set-syncheck-running-mode #f)]
[(and (i . > . 0) ;; check i just in case things are really strange
(20 . <= . (- (current-inexact-milliseconds) start-time)))
(queue-callback
(λ ()
(when (unbox bx)
(log-timeline "continuing replay-compile-comp-trace"
(loop val (current-inexact-milliseconds) 0))))
#f)]
[else
(process-trace-element defs-text (car val))
(loop (cdr val) start-time (+ i 1))]))))
(define/private (process-trace-element defs-text x)
;; 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)
(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)
@ -1978,8 +1932,7 @@ 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)]))
@ -2167,8 +2120,7 @@ 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<%>))
;; speeds up the copy
(send definitions-text-copy set-style-list (send definitions-text get-style-list))
(send definitions-text-copy set-style-list (send definitions-text get-style-list)) ;; speeds up the copy
(send definitions-text copy-self-to definitions-text-copy)
(with-lock/edit-sequence
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)
(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
@ -2212,8 +2162,7 @@ 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))))))
@ -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))
(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
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 (pick-next-arrow orig-arrows backwards? txt start-pos end-pos)
(cond
[(null? orig-arrows) #f]
[(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
(require racket/class
racket/place
racket/match
racket/contract
(for-syntax racket/base)
"../../private/eval-helpers.rkt"
"traversals.rkt"
@ -10,7 +8,7 @@
"intf.rkt"
"xref.rkt")
(provide go monitor)
(provide go)
(define obj%
(class (annotations-mixin object%)
@ -69,8 +67,7 @@
(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))
@ -80,15 +77,7 @@
(loop))))))
(void))
(define-logger online-check-syntax)
(define (go expanded path the-source orig-cust)
(define c (make-channel))
(log-message online-check-syntax-logger 'info "" expanded)
(log-message online-check-syntax-logger 'info "" c)
;; wait for everything to actually get sent back to the main place
(channel-get c))
(define (build-trace stx the-source orig-cust path)
(parameterize ([current-max-to-send-at-once 50])
(with-handlers ((exn:fail? (λ (x)
(printf "exception noticed in online-comp.rkt\n")
@ -108,27 +97,6 @@
(make-traversal (current-namespace)
(get-init-dir path)))
(parameterize ([current-annotations obj])
(expanded-expression stx)
(expanded-expression expanded)
(expansion-completed))
(send obj get-trace))))
(define (monitor send-back path the-source orig-cust)
(define lr (make-log-receiver (current-logger)
'info
'online-check-syntax))
(thread
(λ ()
(let loop ()
(define val (sync lr))
(match val
[(vector level message obj name)
(cond
[(syntax? obj)
(define trace (build-trace obj the-source orig-cust path))
(send-back trace)]
[(channel? obj)
;; signal back to the main place that we've gotten everything
;; and sent it back over
(channel-put obj (void))])]
[_ (void)])
(loop)))))

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
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)
@ -305,7 +292,6 @@ all of the names in the tools library, for use defining keybindings
to use a default name from the buffer, if the buffer contains something like
@tt{(module name ...)}.})
;
;

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)
(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)
(tc-setup/proc orig-stx stx expand-ctxt init checker
(λ (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 (add-typeof-expr e t)
(log-message online-check-syntax-logger 'info #f "type of expression" (list e t))
(when (optimize?)
(hash-update! table e
;; when typechecking a case-> type, types get added for
@ -31,7 +30,6 @@
(ret (map Un old-ts t-ts))]
[(_ _) t])) ; irrelevant to the optimizer, just clobber
t)))
(define-logger online-check-syntax)
(define (type-of e)
(hash-ref table e

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

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

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

@ -19,14 +19,14 @@
"private/arrow.rkt"
"private/base.rkt"
"private/guts.rkt"
"private/misc.rkt"
"private/opt.rkt")
"private/misc.rkt")
;; These are useful for all below.
(define-syntax (add-opt-contract stx)
(define-syntax (verify-contract 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
([current-contract-region (λ (stx) #'blame-stx)])
(let-values ([(res ...) (let () . body)])
(values (contract (add-opt-contract rc.ctc)
(values (contract (verify-contract 'with-contract rc.ctc)
res
blame-stx
blame-id) ...))))])
(syntax/loc stx
(let ()
(define-values (free-ctc-id ...)
(values (add-opt-contract free-ctc) ...))
(values (verify-contract 'with-contract free-ctc) ...))
(define blame-id
(current-contract-region))
(define-values ()
@ -757,7 +757,7 @@
(syntax/loc stx
(begin
(define-values (free-ctc-id ...)
(values (add-opt-contract free-ctc) ...))
(values (verify-contract 'with-contract free-ctc) ...))
(define blame-id
(current-contract-region))
(define-values ()
@ -787,7 +787,7 @@
ext-id
(contract ctc-id true-p blame-stx blame-id (quote ext-id) (quote-srcloc ext-id))
ctc-id
(add-opt-contract ctc))
(verify-contract 'with-contract ctc))
...)
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)