From 40f7ab2ba4a948a9ac9f6b1114a91c71a0968e9b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 2 Nov 2013 09:50:32 -0500 Subject: [PATCH] Sorry all; stupid mistake This reverts commit 90fc899b368bbbd16d284d03dcef53039fffbfca. This reverts commit 780fb37c0dab0bdab8b91a083660ae88021435e8. This reverts commit 9e54b2bc1b8c0ca8a3d84b86a438153e8e1ff2e7. This reverts commit 43a584f7105ba3a0d7830879003a8c5241258969. --- .../drracket/private/drsig.rkt | 9 +- .../drracket/drracket/private/debug.rkt | 16 +- .../drracket/drracket/private/eval.rkt | 1 - .../drracket/private/expanding-place.rkt | 53 +--- .../private/module-language-tools.rkt | 222 ++++++--------- .../drracket/private/module-language.rkt | 76 +---- .../drracket/drracket/private/rep.rkt | 72 +---- .../drracket/private/syncheck/gui.rkt | 268 ++++++------------ .../drracket/private/syncheck/online-comp.rkt | 38 +-- .../drracket/drracket/tool-lib.rkt | 14 - .../typed-racket/tc-setup.rkt | 2 - .../typed-racket/types/type-table.rkt | 2 - .../racket/contract/private/provide.rkt | 45 +-- racket/collects/racket/contract/region.rkt | 16 +- racket/collects/syntax/rect.rkt | 24 -- racket/lib/collects/syntax/rect.rkt | 24 -- 16 files changed, 251 insertions(+), 631 deletions(-) delete mode 100644 racket/collects/syntax/rect.rkt delete mode 100644 racket/lib/collects/syntax/rect.rkt diff --git a/pkgs/drracket-pkgs/drracket-plugin-lib/drracket/private/drsig.rkt b/pkgs/drracket-pkgs/drracket-plugin-lib/drracket/private/drsig.rkt index 797e7711ef..100bdd4d1e 100644 --- a/pkgs/drracket-pkgs/drracket-plugin-lib/drracket/private/drsig.rkt +++ b/pkgs/drracket-pkgs/drracket-plugin-lib/drracket/private/drsig.rkt @@ -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)) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt index 6c703be44d..7442bfea0c 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt @@ -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)]) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt index 103c3dd893..27e0107455 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt @@ -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 diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/expanding-place.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/expanding-place.rkt index 39088bf090..ac2446dcaa 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/expanding-place.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/expanding-place.rkt @@ -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 () diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/module-language-tools.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/module-language-tools.rkt index 433e7e72dc..cccd654642 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/module-language-tools.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/module-language-tools.rkt @@ -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 ) - ;; [no #lang line, so we use the '#lang racket' 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) "<>") - (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 ) [no #lang line, so we use the '#lang racket' 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) "<>") + (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) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/module-language.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/module-language.rkt index 16605b74b7..c87accbae3 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/module-language.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/module-language.rkt @@ -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 diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt index 870ae327a2..b3e1faa85f 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt @@ -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. diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt index 9b1f6bf768..974b4f8aa2 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt @@ -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)] diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/online-comp.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/online-comp.rkt index fc03b222e6..28d4592e2d 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/online-comp.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/online-comp.rkt @@ -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))))) diff --git a/pkgs/drracket-pkgs/drracket/drracket/tool-lib.rkt b/pkgs/drracket-pkgs/drracket/drracket/tool-lib.rkt index 8484b9d72c..40bfa6b18b 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/tool-lib.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/tool-lib.rkt @@ -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 ...)}.}) - ; ; diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt index 7d0a32284e..f5f51d3ba3 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt @@ -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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt index c04d476236..9d7cf9d47f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt @@ -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 diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index 590f8204df..11ec0e1414 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/racket/collects/racket/contract/private/provide.rkt @@ -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 diff --git a/racket/collects/racket/contract/region.rkt b/racket/collects/racket/contract/region.rkt index a7d98625c3..e7b770173d 100644 --- a/racket/collects/racket/contract/region.rkt +++ b/racket/collects/racket/contract/region.rkt @@ -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 . diff --git a/racket/collects/syntax/rect.rkt b/racket/collects/syntax/rect.rkt deleted file mode 100644 index 2c361dcd13..0000000000 --- a/racket/collects/syntax/rect.rkt +++ /dev/null @@ -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) diff --git a/racket/lib/collects/syntax/rect.rkt b/racket/lib/collects/syntax/rect.rkt deleted file mode 100644 index 2c361dcd13..0000000000 --- a/racket/lib/collects/syntax/rect.rkt +++ /dev/null @@ -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)