From b972a0940d04f4ff2c659d494805a7d34358da17 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 3 Jun 2011 21:08:39 -0700 Subject: [PATCH] Added online expansion and compilation of files being edited in DrRacket (via places) Added an API to let tools have access to that information (and compute more stuff) Used that to make an online version of Check Syntax which led to a separately callable Check Syntax API. --- collects/drracket/check-syntax.rkt | 35 + collects/drracket/private/debug.rkt | 3 +- collects/drracket/private/drsig.rkt | 51 +- collects/drracket/private/eval-helpers.rkt | 97 + collects/drracket/private/eval.rkt | 24 +- collects/drracket/private/expanding-place.rkt | 207 + collects/drracket/private/frame.rkt | 15 +- collects/drracket/private/get-extend.rkt | 21 +- collects/drracket/private/interface.rkt | 133 + .../private/language-configuration.rkt | 2 +- collects/drracket/private/link.rkt | 22 +- .../drracket/private/local-member-names.rkt | 15 + collects/drracket/private/main.rkt | 5 +- .../private/module-language-tools.rkt | 45 +- collects/drracket/private/module-language.rkt | 640 +- .../drracket/private/multi-file-search.rkt | 3 +- collects/drracket/private/rep.rkt | 68 +- .../drracket/private/syncheck/annotate.rkt | 57 +- collects/drracket/private/syncheck/colors.rkt | 70 +- collects/drracket/private/syncheck/gui.rkt | 832 +- collects/drracket/private/syncheck/intf.rkt | 60 +- .../drracket/private/syncheck/online-comp.rkt | 63 + .../drracket/private/syncheck/traversals.rkt | 414 +- collects/drracket/private/tools-drs.rkt | 3 +- collects/drracket/private/tools.rkt | 4 +- collects/drracket/private/tracing.rkt | 3 +- collects/drracket/private/unit.rkt | 8708 ++++++++--------- collects/drracket/tool-lib.rkt | 25 + collects/scribblings/tools/tools.scrbl | 184 +- collects/scribblings/tools/unit.scrbl | 38 +- .../private/english-string-constants.rkt | 9 +- collects/tests/drracket/syncheck-test.rkt | 24 +- .../tests/drracket/test-docs-complete.rkt | 3 + .../base-env/base-types-extra.rkt | 7 +- 34 files changed, 6601 insertions(+), 5289 deletions(-) create mode 100644 collects/drracket/check-syntax.rkt create mode 100644 collects/drracket/private/eval-helpers.rkt create mode 100644 collects/drracket/private/expanding-place.rkt create mode 100644 collects/drracket/private/interface.rkt create mode 100644 collects/drracket/private/local-member-names.rkt create mode 100644 collects/drracket/private/syncheck/online-comp.rkt create mode 100644 collects/tests/drracket/test-docs-complete.rkt diff --git a/collects/drracket/check-syntax.rkt b/collects/drracket/check-syntax.rkt new file mode 100644 index 0000000000..0fff0bbe03 --- /dev/null +++ b/collects/drracket/check-syntax.rkt @@ -0,0 +1,35 @@ +#lang at-exp racket/base +(require racket/contract + racket/class + "private/syncheck/traversals.rkt" + "private/syncheck/intf.rkt") + +(provide/contract + [make-traversal + (-> namespace? + (or/c path-string? #f) + (values (->* (syntax?) ((-> syntax? void?)) void?) + (-> void?)))] + [syncheck-annotations<%> + interface?] + [current-annotations + (parameter/c (or/c #f (is-a?/c syncheck-annotations<%>)))] + [annotations-mixin + (and/c mixin-contract + (-> any/c (implementation?/c syncheck-annotations<%>)))]) + +;; methods in syncheck-annotations<%> +(provide + syncheck:find-source-object + syncheck:add-background-color + syncheck:add-require-open-menu + syncheck:add-docs-menu + syncheck:add-rename-menu + syncheck:add-arrow + syncheck:add-tail-arrow + syncheck:add-mouse-over-status + syncheck:add-jump-to-definition + syncheck:color-range) + + + diff --git a/collects/drracket/private/debug.rkt b/collects/drracket/private/debug.rkt index 495bd09f47..fcdd89f514 100644 --- a/collects/drracket/private/debug.rkt +++ b/collects/drracket/private/debug.rkt @@ -37,7 +37,8 @@ profile todo: [prefix drracket:unit: drracket:unit^] [prefix drracket:language: drracket:language^] [prefix drracket:language-configuration: drracket:language-configuration/internal^] - [prefix drracket:init: drracket:init^]) + [prefix drracket:init: drracket:init^] + [prefix drracket: drracket:interface^]) (export drracket:debug^) ; diff --git a/collects/drracket/private/drsig.rkt b/collects/drracket/private/drsig.rkt index a3e4ea0ee0..63f03209ff 100644 --- a/collects/drracket/private/drsig.rkt +++ b/collects/drracket/private/drsig.rkt @@ -4,6 +4,7 @@ (provide drracket:eval^ drracket:debug^ drracket:module-language^ + drracket:module-language/int^ drracket:module-language-tools^ drracket:get-collection^ drracket:main^ @@ -31,7 +32,8 @@ drracket:tool^ drracket:tool-cm^ drscheme:tool^ - drscheme:tool-cm^) + drscheme:tool-cm^ + drracket:interface^) (define-signature drracket:modes-cm^ ()) @@ -90,16 +92,23 @@ (define-signature drracket:module-language^ extends drracket:module-language-cm^ (add-module-language module-language-put-file-mixin)) +(define-signature drracket:module-language/int^ extends drracket:module-language^ + (module-language-online-expand-text-mixin + module-language-online-expand-frame-mixin + module-language-online-expand-tab-mixin)) (define-signature drracket:module-language-tools-cm^ (frame-mixin - frame<%> tab-mixin - tab<%> - definitions-text-mixin - definitions-text<%>)) + definitions-text-mixin)) (define-signature drracket:module-language-tools^ extends drracket:module-language-tools-cm^ - (add-opt-out-toolbar-button)) + (add-opt-out-toolbar-button + add-online-expansion-handler + + ;; the below should be hidden from tools + (struct online-expansion-handler (mod-path id local-handler)) + get-online-expansion-handlers + no-more-online-expansion-handlers)) (define-signature drracket:get-collection-cm^ ()) (define-signature drracket:get-collection^ extends drracket:get-collection-cm^ @@ -177,12 +186,9 @@ (define-signature drracket:unit-cm^ (tab% - tab<%> frame% - frame<%> definitions-canvas% get-definitions-text% - definitions-text<%> interactions-canvas%)) (define-signature drracket:unit^ extends drracket:unit-cm^ (open-drscheme-window @@ -196,10 +202,8 @@ add-search-help-desk-menu-item)) (define-signature drracket:frame-cm^ - (<%> - mixin - basics-mixin - basics<%>)) + (mixin + basics-mixin)) (define-signature drracket:frame^ extends drracket:frame-cm^ (create-root-menubar add-keybindings-item @@ -234,8 +238,7 @@ (define-signature drracket:rep-cm^ (drs-bindings-keymap-mixin text% - text<%> - context<%>)) + text<%>)) (define-signature drracket:rep^ extends drracket:rep-cm^ (current-rep current-language-settings @@ -332,6 +335,18 @@ (define-signature drracket:tracing^ extends drracket:tracing-cm^ (annotate)) +(define-signature drracket:interface^ + (frame:basics<%> + frame:<%> + unit:frame<%> + unit:definitions-text<%> + unit:tab<%> + rep:context<%> + + module-language-tools:definitions-text<%> + module-language-tools:tab<%> + module-language-tools:frame<%>)) + (define-signature drracket:tool-exports-cm^ ()) (define-signature drracket:tool-exports^ extends drracket:tool-exports-cm^ @@ -352,7 +367,8 @@ (open (prefix modes: drracket:modes-cm^)) (open (prefix tracing: drracket:tracing-cm^)) (open (prefix module-language: drracket:module-language-cm^)) - (open (prefix module-language-tools: drracket:module-language-tools-cm^)))) + (open (prefix module-language-tools: drracket:module-language-tools-cm^)) + (open drracket:interface^))) (define-signature drracket:tool-cm^ ((open (prefix drracket: no-prefix:tool-cm^)))) @@ -372,7 +388,8 @@ (open (prefix modes: drracket:modes^)) (open (prefix tracing: drracket:tracing^)) (open (prefix module-language: drracket:module-language^)) - (open (prefix module-language-tools: drracket:module-language-tools^)))) + (open (prefix module-language-tools: drracket:module-language-tools^)) + (open drracket:interface^))) (define-signature drracket:tool^ ((open (prefix drracket: no-prefix:tool^)))) diff --git a/collects/drracket/private/eval-helpers.rkt b/collects/drracket/private/eval-helpers.rkt new file mode 100644 index 0000000000..a27569fdfa --- /dev/null +++ b/collects/drracket/private/eval-helpers.rkt @@ -0,0 +1,97 @@ +#lang racket/base +(require racket/class + racket/draw + racket/list + compiler/cm + setup/dirs + planet/config + (prefix-in *** '#%foreign) ;; just to make sure it is here + ) + +(provide set-basic-parameters/no-gui + set-module-language-parameters + (struct-out prefab-module-settings) + transform-module) + +(struct prefab-module-settings + (command-line-args + collection-paths + compilation-on? + full-trace? + annotations) + #:prefab) + +(define orig-namespace (current-namespace)) + +(define (set-basic-parameters/no-gui) + (let ([cust (current-custodian)]) + (define (drracket-plain-exit-handler arg) + (custodian-shutdown-all cust)) + (exit-handler drracket-plain-exit-handler)) + (current-thread-group (make-thread-group)) + (current-command-line-arguments #()) + (current-pseudo-random-generator (make-pseudo-random-generator)) + (current-evt-pseudo-random-generator (make-pseudo-random-generator)) + (read-curly-brace-as-paren #t) + (read-square-bracket-as-paren #t) + (error-print-width 250) + (current-ps-setup (make-object ps-setup%)) + (current-namespace (make-base-empty-namespace)) + ;; is this wise? + #;(namespace-attach-module orig-namespace ''#%foreign)) + + +(define (set-module-language-parameters settings module-language-parallel-lock-client + #:use-use-current-security-guard? [use-current-security-guard? #f]) + (current-command-line-arguments (prefab-module-settings-command-line-args settings)) + (let* ([default (current-library-collection-paths)] + [cpaths (append-map (λ (x) (if (symbol? x) default (list x))) + (prefab-module-settings-collection-paths settings))]) + (when (null? cpaths) + (fprintf (current-error-port) + "WARNING: your collection paths are empty!\n")) + (current-library-collection-paths cpaths)) + + (compile-context-preservation-enabled (prefab-module-settings-full-trace? settings)) + + (when (prefab-module-settings-compilation-on? settings) + (case (prefab-module-settings-annotations settings) + [(none) + (use-compiled-file-paths + (cons (build-path "compiled" "drracket") + (use-compiled-file-paths)))] + [(debug) + (use-compiled-file-paths + (cons (build-path "compiled" "drracket" "errortrace") + (use-compiled-file-paths)))]) + (parallel-lock-client module-language-parallel-lock-client) + (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler + #t + #:security-guard (and use-current-security-guard? + (current-security-guard)))) + (let* ([cd (find-collects-dir)] + [no-dirs (if cd + (list (CACHE-DIR) cd) + (list (CACHE-DIR)))]) + (manager-skip-file-handler + (λ (p) (file-stamp-in-paths p no-dirs)))))) + +(define (transform-module filename stx raise-hopeless-syntax-error) + (define-values (mod name lang body) + (syntax-case stx () + [(module name lang . body) + (eq? 'module (syntax-e #'module)) + (values #'module #'name #'lang #'body)] + [_ (raise-hopeless-syntax-error + (string-append "only a module expression is allowed, either\n" + " #lang \n or\n" + " (module ...)\n") + stx)])) + (define name* (syntax-e name)) + (unless (symbol? name*) + (raise-hopeless-syntax-error "bad syntax in name position of module" + stx name)) + (let* (;; rewrite the module to use the racket/base version of `module' + [mod (datum->syntax #'here 'module mod)] + [expr (datum->syntax stx `(,mod ,name ,lang . ,body) stx stx)]) + (values name lang expr))) diff --git a/collects/drracket/private/eval.rkt b/collects/drracket/private/eval.rkt index d03e5c9ec1..c8cebc7c06 100644 --- a/collects/drracket/private/eval.rkt +++ b/collects/drracket/private/eval.rkt @@ -6,9 +6,11 @@ racket/class syntax/toplevel framework + "eval-helpers.rkt" "drsig.rkt") - ;; to ensure this guy is loaded (and the snipclass installed) in the drscheme namespace & eventspace + ;; to ensure this guy is loaded (and the snipclass installed) + ;; in the drracket namespace & eventspace ;; these things are for effect only! (require mrlib/cache-image-snip (prefix-in image-core: mrlib/image-core)) @@ -166,22 +168,7 @@ (define (set-basic-parameters snip-classes #:gui-modules? [gui-modules? #t]) (for-each (λ (snip-class) (send (get-the-snip-class-list) add snip-class)) snip-classes) - - (let ([cust (current-custodian)]) - (define (drracket-plain-exit-handler arg) - (custodian-shutdown-all cust)) - (exit-handler drracket-plain-exit-handler)) - - (current-thread-group (make-thread-group)) - (current-command-line-arguments #()) - (current-pseudo-random-generator (make-pseudo-random-generator)) - (current-evt-pseudo-random-generator (make-pseudo-random-generator)) - (read-curly-brace-as-paren #t) - (read-square-bracket-as-paren #t) - (error-print-width 250) - (current-ps-setup (make-object ps-setup%)) - - (current-namespace (make-empty-namespace)) + (set-basic-parameters/no-gui) (for-each (λ (x) (namespace-attach-module drracket:init:system-namespace x)) to-be-copied-module-names) (when gui-modules? @@ -196,8 +183,7 @@ ;; these module specs are copied over to each new user's namespace (define to-be-copied-module-specs - (list 'racket/base - ''#%foreign + (list ''#%foreign '(lib "mzlib/pconvert-prop.rkt") '(lib "planet/terse-info.rkt"))) diff --git a/collects/drracket/private/expanding-place.rkt b/collects/drracket/private/expanding-place.rkt new file mode 100644 index 0000000000..7dec525a79 --- /dev/null +++ b/collects/drracket/private/expanding-place.rkt @@ -0,0 +1,207 @@ +#lang racket/base +(require racket/place + "eval-helpers.rkt" + compiler/cm) +(provide start) + +(struct job (cust response-pc)) + +;; key : any (used by equal? for comparision, but back in the main place) +(struct handler (key proc)) +(define handlers '()) + +(define module-language-parallel-lock-client + 'uninitialized-module-language-parallel-lock-client) + +(define (start p) + ;; get the module-language-compile-lock in the initial message + (set! module-language-parallel-lock-client + (compile-lock->parallel-lock-client + (place-channel-get p))) + + ;; get the handlers in a second message + (set! handlers (for/list ([lst (place-channel-get p)]) + (define file (list-ref lst 0)) + (define id (list-ref lst 1)) + (handler lst (dynamic-require file id)))) + (let loop ([current-job #f]) + (sync + (handle-evt + p + (λ (message) + (cond + [(eq? message 'abort) + (when current-job (abort-job current-job)) + (loop #f)] + [(vector? message) + (when current-job (abort-job current-job)) + (define program-as-string (vector-ref message 0)) + (define path (vector-ref message 1)) + (define response-pc (vector-ref message 2)) + (define settings (vector-ref message 3)) + (loop (new-job program-as-string path response-pc settings))])))))) + +(define (abort-job job) + (custodian-shutdown-all (job-cust job)) + (place-channel-put (job-response-pc job) #f)) + +(struct exn:access exn:fail ()) + +(define (new-job program-as-string path response-pc settings) + (define cust (make-custodian)) + (define exn-chan (make-channel)) + (define result-chan (make-channel)) + (define normal-termination (make-channel)) + (define abnormal-termination (make-channel)) + (define the-source (or path "unsaved editor")) + (define orig-cust (current-custodian)) + + (define thd + (parameterize ([current-custodian cust]) + (thread + (λ () + (log-info "expanding-place.rkt: starting thread") + (define sema (make-semaphore 0)) + (set-basic-parameters/no-gui) + (set-module-language-parameters settings + module-language-parallel-lock-client + #:use-use-current-security-guard? #t) + (when path + (let-values ([(base name dir?) (split-path path)]) + (current-directory base) + (current-load-relative-directory base))) + (define sp (open-input-string program-as-string)) + (port-count-lines! sp) + (install-security-guard) ;; must come after the call to set-module-language-parameters + (uncaught-exception-handler + (λ (exn) + (parameterize ([current-custodian orig-cust]) + (thread + (λ () + (channel-put normal-termination #t) + (semaphore-post sema) + (channel-put exn-chan exn)))) + (semaphore-wait sema) + ((error-escape-handler)))) + (log-info "expanding-place.rkt: starting read-syntax") + (define stx + (parameterize ([read-accept-reader #t]) + (read-syntax the-source sp))) + (log-info "expanding-place.rkt: read") + (when (syntax? stx) ;; could be eof + (define-values (name lang transformed-stx) + (transform-module path + (namespace-syntax-introduce stx) + raise-hopeless-syntax-error)) + (log-info "expanding-place.rkt: starting expansion") + (define expanded (expand transformed-stx)) + (log-info "expanding-place.rkt: expanded") + (define handler-results + (for/list ([handler (in-list handlers)]) + (list (handler-key handler) + ((handler-proc handler) expanded + path + the-source)))) + (log-info "expanding-place.rkt: handlers finished") + (parameterize ([current-custodian orig-cust]) + (thread + (λ () + (channel-put normal-termination #t) + (semaphore-post sema) + (channel-put result-chan handler-results)))) + (semaphore-wait sema)))))) + + (thread + (λ () + (sync + (handle-evt + normal-termination + (λ (x) (void))) + (handle-evt + (thread-dead-evt thd) + (λ (x) (channel-put abnormal-termination #t)))))) + + (thread + (λ () + (sync + (handle-evt + abnormal-termination + (λ (val) + (place-channel-put + response-pc + (vector 'abnormal-termination)))) + (handle-evt + result-chan + (λ (val) + (place-channel-put response-pc (vector 'handler-results val)))) + (handle-evt + exn-chan + (λ (exn) + (place-channel-put + response-pc + (cond + [(exn:access? exn) + (vector 'access-violation (exn-message exn))] + [(and (exn:fail:read? exn) + (andmap (λ (srcloc) (equal? (srcloc-source srcloc) the-source)) + (exn:fail:read-srclocs exn))) + ;; figure the syntax colorer can deal + ;; with these better than we can + (vector 'no-errors)] + [else + (vector + 'exn + (trim-message + (if (exn? exn) + (regexp-replace* #rx"[ \t]*\n[ \t]*" (exn-message exn) " ") + (format "uncaught exn: ~s" exn))) + (if (exn:srclocs? exn) + (sort + (filter + values + (for/list ([srcloc ((exn:srclocs-accessor exn) exn)]) + (and (srcloc? srcloc) + (equal? the-source (srcloc-source srcloc)) + (srcloc-position srcloc) + (srcloc-span srcloc) + (vector (srcloc-position srcloc) + (srcloc-span srcloc))))) + < + #:key (λ (x) (vector-ref x 0))) + '()))]))))))) + (job cust response-pc)) + +(define (raise-hopeless-syntax-error . args) + (apply raise-syntax-error '|Module Language| args)) + +(define (install-security-guard) + (current-security-guard + (make-security-guard + (current-security-guard) + (λ (prim path whats) + (when (or (member 'write whats) + (member 'execute whats) + (member 'delete whats)) + (raise (exn:access (format "~a: forbidden ~a access to ~a" prim whats path) + (current-continuation-marks))))) + (λ (prim target port what) + (raise (exn:access (format "~a: forbidden ~a access to ~a:~a" prim what target port) + (current-continuation-marks)))) + (λ (prim path1 path2) + (raise (exn:access (format "~a: forbidden to link ~a to ~a" prim path1 path2) + (current-continuation-marks))))))) + +;; trim-message : string -> string[200 chars max] +(define (trim-message str) + (cond + [(<= (string-length str) 200) + str] + [else + (define prefix-len 99) + (define suffix-len 98) + (define middle "...") + + ;; (+ prefix-len suffix-len (string-length middle)) must be 200 (or less) + (string-append (substring str 0 prefix-len) + middle + (substring str (- (string-length str) suffix-len) (string-length str)))])) diff --git a/collects/drracket/private/frame.rkt b/collects/drracket/private/frame.rkt index f086f4df9c..a13e60daa7 100644 --- a/collects/drracket/private/frame.rkt +++ b/collects/drracket/private/frame.rkt @@ -16,16 +16,15 @@ [prefix drracket:app: drracket:app^] [prefix help: drracket:help-desk^] [prefix drracket:multi-file-search: drracket:multi-file-search^] - [prefix drracket:init: drracket:init^]) + [prefix drracket:init: drracket:init^] + [prefix drracket: drracket:interface^]) (export (rename drracket:frame^ [-mixin mixin])) - (define basics<%> (interface (frame:standard-menus<%>))) - (define last-keybindings-planet-attempt "") (define basics-mixin - (mixin (frame:standard-menus<%>) (basics<%>) + (mixin (frame:standard-menus<%>) (drracket:frame:basics<%>) (define/override (on-subwindow-char receiver event) (let ([user-key? (send (keymap:get-user) @@ -588,14 +587,8 @@ (update-bindings) (send f show #t))) - (define <%> - (interface (frame:editor<%> basics<%> frame:text-info<%>) - get-show-menu - update-shown - add-show-menu-items)) - (define -mixin - (mixin (frame:editor<%> frame:text-info<%> basics<%>) (<%>) + (mixin (frame:editor<%> frame:text-info<%> drracket:frame:basics<%>) (drracket:frame:<%>) (inherit get-editor get-menu% get-menu-bar) (define show-menu #f) (define/public get-show-menu (λ () show-menu)) diff --git a/collects/drracket/private/get-extend.rkt b/collects/drracket/private/get-extend.rkt index eab8fb5d8a..28818eefff 100644 --- a/collects/drracket/private/get-extend.rkt +++ b/collects/drracket/private/get-extend.rkt @@ -8,6 +8,7 @@ [prefix drracket:rep: drracket:rep^] [prefix drracket:debug: drracket:debug^] [prefix drracket:tracing: drracket:tracing^] + [prefix drracket:module-language: drracket:module-language/int^] [prefix drracket:module-language-tools: drracket:module-language-tools^]) (export drracket:get/extend^) @@ -45,11 +46,12 @@ built))))) (define (get-base-tab%) - (drracket:module-language-tools:tab-mixin - (drracket:tracing:tab-mixin - (drracket:debug:test-coverage-tab-mixin - (drracket:debug:profile-tab-mixin - drracket:unit:tab%))))) + (drracket:module-language:module-language-online-expand-tab-mixin + (drracket:module-language-tools:tab-mixin + (drracket:tracing:tab-mixin + (drracket:debug:test-coverage-tab-mixin + (drracket:debug:profile-tab-mixin + drracket:unit:tab%)))))) (define-values (extend-tab get-tab) (make-extender get-base-tab% 'tab%)) @@ -82,10 +84,11 @@ (make-extender get-base-interactions-text% 'interactions-text%)) (define (get-base-definitions-text%) - (drracket:module-language-tools:definitions-text-mixin - (drracket:debug:test-coverage-definitions-text-mixin - (drracket:debug:profile-definitions-text-mixin - (drracket:unit:get-definitions-text%))))) + (drracket:module-language:module-language-online-expand-text-mixin + (drracket:module-language-tools:definitions-text-mixin + (drracket:debug:test-coverage-definitions-text-mixin + (drracket:debug:profile-definitions-text-mixin + (drracket:unit:get-definitions-text%)))))) (define-values (extend-definitions-text get-definitions-text) (make-extender get-base-definitions-text% 'definitions-text%)) diff --git a/collects/drracket/private/interface.rkt b/collects/drracket/private/interface.rkt new file mode 100644 index 0000000000..d0772a0dab --- /dev/null +++ b/collects/drracket/private/interface.rkt @@ -0,0 +1,133 @@ +#lang racket/unit +#| + +This file has names with partial prefixes built into them +because the interfaces here used to be in other files, but +that was causing circular dependencies; the interfaces +were moved here to break the cycle, but the names should +remain the same for tools that use them. + +|# + +(require "drsig.rkt" + "local-member-names.rkt" + racket/class + framework) +(import) +(export drracket:interface^) + +(define frame:basics<%> (interface (frame:standard-menus<%>))) +(define frame:<%> + (interface (frame:editor<%> frame:basics<%> frame:text-info<%>) + get-show-menu + update-shown + add-show-menu-items)) + +(define unit:frame<%> + (interface (frame:<%> + frame:searchable-text<%> + frame:delegate<%> + frame:open-here<%>) + get-insert-menu + get-special-menu + get-interactions-text + get-definitions-text + get-interactions-canvas + get-definitions-canvas + get-button-panel + execute-callback + get-current-tab + open-in-new-tab + close-current-tab + on-tab-change + enable-evaluation + disable-evaluation + get-definitions/interactions-panel-parent + register-capability-menu-item + + ensure-rep-shown + ensure-rep-hidden + ensure-defs-shown + + + get-language-menu + register-toolbar-button + register-toolbar-buttons + unregister-toolbar-button + get-tabs)) + +(define unit:definitions-text<%> + (interface () + begin-metadata-changes + end-metadata-changes + get-tab + get-next-settings + after-set-next-settings + set-needs-execution-message)) + +(define rep:context<%> + (interface () + ensure-rep-shown ;; (interactions-text -> void) + ;; make the rep visible in the frame + + repl-submit-happened ;; (-> boolean) + ;; notify the context that an evaluation is about to + ;; happen in the REPL (so it can show a warning about + ;; the language/etc is out of sync if neccessary). + + enable-evaluation ;; (-> void) + ;; make the context enable all methods of evaluation + ;; (disable buttons, menus, etc) + + disable-evaluation ;; (-> void) + ;; make the context disable all methods of evaluation + ;; (disable buttons, menus, etc) + + set-breakables ;; (union thread #f) (union custodian #f) -> void + ;; the context might initiate breaks or kills to + ;; the thread passed to this function + + get-breakables ;; -> (values (union thread #f) (union custodian #f)) + ;; returns the last values passed to set-breakables. + + reset-offer-kill ;; (-> void) + ;; the next time the break button is pushed, it will only + ;; break. (if the break button is clicked twice without + ;; this method being called in between, it will offer to + ;; kill the user's program) + + update-running ;; (boolean -> void) + ;; a callback to indicate that the repl may have changed its running state + ;; use the repls' get-in-evaluation? method to find out what the current state is. + + clear-annotations ;; (-> void) + ;; clear any error highlighting context + + get-directory ;; (-> (union #f string[existing directory])) + ;; returns the directory that should be the default for + ;; the `current-directory' and `current-load-relative-directory' + ;; parameters in the repl. + )) + +(define unit:tab<%> + (interface (rep:context<%>) + get-frame + get-defs + get-ints + get-visible-defs + set-visible-defs + set-visible-ints + set-focus-d/i + get-i + set-i + break-callback + is-current-tab? + get-enabled + on-close + can-close? + toggle-log)) + +(define module-language-tools:definitions-text<%> (interface () move-to-new-language)) +(define module-language-tools:tab<%> (interface ())) +(define module-language-tools:frame<%> (interface ())) + diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index bb607e23aa..1370d7259f 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -56,7 +56,7 @@ [prefix drracket:app: drracket:app^] [prefix drracket:tools: drracket:tools^] [prefix drracket:help-desk: drracket:help-desk^] - [prefix drracket:module-language: drracket:module-language^]) + [prefix drracket:module-language: drracket:module-language/int^]) (export drracket:language-configuration/internal^) ;; settings-preferences-symbol : symbol diff --git a/collects/drracket/private/link.rkt b/collects/drracket/private/link.rkt index c4f79cbb99..978624422a 100644 --- a/collects/drracket/private/link.rkt +++ b/collects/drracket/private/link.rkt @@ -22,7 +22,8 @@ "tracing.rkt" "get-extend.rkt" "help-desk.rkt" - "module-language-tools.rkt") + "module-language-tools.rkt" + "interface.rkt") (provide drracket@) @@ -39,11 +40,12 @@ drracket:eval^ drracket:modes^ drracket:tracing^ - drracket:module-language^ - drracket:module-language-tools^) - (link init@ tools@ tools-drs@ modes@ text@ eval@ frame@ rep@ language@ - module-overview@ unit@ debug@ multi-file-search@ get-extend@ - language-configuration@ font@ module-language@ module-language-tools@ + drracket:module-language/int^ + drracket:module-language-tools^ + drracket:interface^) + (link interface@ init@ tools@ tools-drs@ modes@ text@ eval@ frame@ rep@ language@ + module-overview@ module-language@ unit@ debug@ multi-file-search@ get-extend@ + language-configuration@ font@ module-language-tools@ help-desk@ tracing@ app@ main@)) @@ -65,8 +67,9 @@ (prefix drracket:eval: drracket:eval^) (prefix drracket:modes: drracket:modes^) (prefix drracket:tracing: drracket:tracing^) - (prefix drracket:module-language: drracket:module-language^) + (prefix drracket:module-language: drracket:module-language/int^) (prefix drracket:module-language-tools: drracket:module-language-tools^) + (prefix drracket: drracket:interface^) (prefix drscheme:debug: drracket:debug^) (prefix drscheme:unit: drracket:unit^) @@ -79,6 +82,7 @@ (prefix drscheme:eval: drracket:eval^) (prefix drscheme:modes: drracket:modes^) (prefix drscheme:tracing: drracket:tracing^) - (prefix drscheme:module-language: drracket:module-language^) - (prefix drscheme:module-language-tools: drracket:module-language-tools^)) + (prefix drscheme:module-language: drracket:module-language/int^) + (prefix drscheme:module-language-tools: drracket:module-language-tools^) + (prefix drscheme: drracket:interface^)) drracket-unit@)) diff --git a/collects/drracket/private/local-member-names.rkt b/collects/drracket/private/local-member-names.rkt new file mode 100644 index 0000000000..7927111b61 --- /dev/null +++ b/collects/drracket/private/local-member-names.rkt @@ -0,0 +1,15 @@ +#lang racket/base +(require racket/class) +(provide (all-defined-out)) + +(define-local-member-name + get-visible-defs + set-visible-defs + set-focus-d/i + get-i + set-i + insert-auto-text) + +;; from module-language-tools.rkt +(define-local-member-name when-initialized #;move-to-new-language get-in-module-language?) + diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index b3f888ffdf..ee99019681 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -18,7 +18,7 @@ [prefix drracket:get/extend: drracket:get/extend^] [prefix drracket:language-configuration: drracket:language-configuration/internal^] [prefix drracket:language: drracket:language^] - [prefix drracket:module-language: drracket:module-language^] + [prefix drracket:module-language: drracket:module-language/int^] [prefix drracket:tools: drracket:tools^] [prefix drracket:debug: drracket:debug^] [prefix drracket:frame: drracket:frame^] @@ -522,6 +522,9 @@ (or settings (send lang default-settings))))))))) ;; preferences initialization + + (preferences:set-default 'drracket:online-compilation #t boolean?) + (drr:set-default 'drracket:multi-file-search:recur? #t boolean?) (drr:set-default 'drracket:multi-file-search:filter? #t boolean?) (drr:set-default 'drracket:multi-file-search:filter-regexp "\\.(rkt.?|scrbl|ss|scm)$" string?) diff --git a/collects/drracket/private/module-language-tools.rkt b/collects/drracket/private/module-language-tools.rkt index 873aeb06ec..858a0fd619 100644 --- a/collects/drracket/private/module-language-tools.rkt +++ b/collects/drracket/private/module-language-tools.rkt @@ -7,20 +7,20 @@ racket/unit racket/class racket/gui/base - "drsig.rkt") + "drsig.rkt" + "local-member-names.rkt") (define op (current-output-port)) (define (oprintf . args) (apply fprintf op args)) (define-unit module-language-tools@ (import [prefix drracket:unit: drracket:unit^] - [prefix drracket:module-language: drracket:module-language^] + [prefix drracket:module-language: drracket:module-language/int^] [prefix drracket:language: drracket:language^] - [prefix drracket:language-configuration: drracket:language-configuration^]) + [prefix drracket:language-configuration: drracket:language-configuration^] + [prefix drracket: drracket:interface^]) (export drracket:module-language-tools^) - (define-local-member-name when-initialized move-to-new-language get-in-module-language?) - (define-struct opt-out-toolbar-button (make-button id) #:transparent) (define opt-out-toolbar-buttons '()) @@ -29,10 +29,8 @@ (cons (make-opt-out-toolbar-button make-button id) opt-out-toolbar-buttons))) - (define tab<%> (interface ())) - (define tab-mixin - (mixin (drracket:unit:tab<%>) (tab<%>) + (mixin (drracket:unit:tab<%>) (drracket:module-language-tools:tab<%>) (inherit get-frame) (define toolbar-buttons '()) (define/public (get-lang-toolbar-buttons) toolbar-buttons) @@ -48,9 +46,8 @@ (λ (l) toolbar-buttons))))) (super-new))) - (define frame<%> (interface ())) (define frame-mixin - (mixin (drracket:unit:frame<%>) (frame<%>) + (mixin (drracket:unit:frame<%>) (drracket:module-language-tools:frame<%>) (inherit unregister-toolbar-button get-definitions-text) (define toolbar-button-panel #f) @@ -90,9 +87,8 @@ (when (send defs get-in-module-language?) (send defs move-to-new-language)))))) - (define definitions-text<%> (interface ())) (define definitions-text-mixin - (mixin (text:basic<%> drracket:unit:definitions-text<%>) (definitions-text<%>) + (mixin (text:basic<%> drracket:unit:definitions-text<%>) (drracket:module-language-tools:definitions-text<%>) (inherit get-next-settings) (define in-module-language? #f) ;; true when we are in the module language (define hash-lang-last-location #f) ;; non-false when we know where the hash-lang line ended @@ -242,4 +238,27 @@ (super-new) (set! in-module-language? (is-a? (drracket:language-configuration:language-settings-language (get-next-settings)) - drracket:module-language:module-language<%>))))) + drracket:module-language:module-language<%>)))) + + + (define no-more-online-expansion-handlers? #f) + (define (no-more-online-expansion-handlers) (set! no-more-online-expansion-handlers? #t)) + (struct online-expansion-handler (mod-path id local-handler)) + (define online-expansion-handlers '()) + (define (get-online-expansion-handlers) + (cond + [no-more-online-expansion-handlers? + online-expansion-handlers] + [else + (error 'get-online-expansion-handlers + "online-expansion-handlers can still be registered")])) + (define (add-online-expansion-handler mod-path id local-handler) + (cond + [no-more-online-expansion-handlers? + (error 'add-online-expansion-handler + "no more online-expansion-handlers can be registered; got ~e ~e ~e" + mod-path id local-handler)] + [else + (set! online-expansion-handlers + (cons (online-expansion-handler mod-path id local-handler) + online-expansion-handlers))]))) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index 79bb967e1a..4c5a4f1426 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -7,6 +7,8 @@ racket/path racket/contract racket/sandbox + racket/runtime-path + racket/math mred compiler/embed compiler/cm @@ -15,8 +17,18 @@ string-constants planet/config setup/dirs + racket/place "drsig.rkt" - "rep.rkt") + "rep.rkt" + "eval-helpers.rkt" + "local-member-names.rkt") + +(define-runtime-path expanding-place.rkt "expanding-place.rkt") + +(define sc-online-expansion-running (string-constant online-expansion-running)) +(define sc-only-raw-text-files-supported (string-constant only-raw-text-files-supported)) +(define sc-abnormal-termination (string-constant abnormal-termination)) +(define sc-jump-to-error (string-constant jump-to-error)) (define op (current-output-port)) (define (oprintf . args) (apply fprintf op args)) @@ -26,8 +38,10 @@ [prefix drracket:language: drracket:language^] [prefix drracket:unit: drracket:unit^] [prefix drracket:rep: drracket:rep^] - [prefix drracket:init: drracket:init^]) - (export drracket:module-language^) + [prefix drracket:init: drracket:init^] + [prefix drracket:module-language-tools: drracket:module-language-tools^] + [prefix drracket: drracket:interface^]) + (export drracket:module-language/int^) (define module-language<%> (interface () @@ -52,6 +66,13 @@ (define-struct (module-language-settings drracket:language:simple-settings) (collection-paths command-line-args auto-text compilation-on? full-trace?)) + (define (module-language-settings->prefab-module-settings settings) + (prefab-module-settings (module-language-settings-command-line-args settings) + (module-language-settings-collection-paths settings) + (module-language-settings-compilation-on? settings) + (module-language-settings-full-trace? settings) + (drracket:language:simple-settings-annotations settings))) + (define default-compilation-on? #t) (define default-full-trace? #t) (define default-auto-text "#lang racket\n") @@ -245,40 +266,8 @@ (run-in-user-thread (λ () - (current-command-line-arguments - (module-language-settings-command-line-args settings)) - (let* ([default (current-library-collection-paths)] - [cpaths (append-map (λ (x) (if (symbol? x) default (list x))) - (module-language-settings-collection-paths - settings))]) - (when (null? cpaths) - (fprintf (current-error-port) - "WARNING: your collection paths are empty!\n")) - (current-library-collection-paths cpaths)) - - (compile-context-preservation-enabled (module-language-settings-full-trace? settings)) - - (when (module-language-settings-compilation-on? settings) - - (let ([annotations (drracket:language:simple-settings-annotations settings)]) - (case annotations - [(none) - (use-compiled-file-paths - (cons (build-path "compiled" "drracket") - (use-compiled-file-paths)))] - [(debug) - (use-compiled-file-paths - (cons (build-path "compiled" "drracket" "errortrace") - (use-compiled-file-paths)))])) - - (parallel-lock-client module-language-parallel-lock-client) - (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler #t)) - (let* ([cd (find-collects-dir)] - [no-dirs (if cd - (list (CACHE-DIR) cd) - (list (CACHE-DIR)))]) - (manager-skip-file-handler - (λ (p) (file-stamp-in-paths p no-dirs)))))))) + (set-module-language-parameters (module-language-settings->prefab-module-settings settings) + module-language-parallel-lock-client)))) (define/override (get-one-line-summary) (string-constant module-language-one-line-summary)) @@ -327,13 +316,20 @@ (raise-hopeless-exception e "invalid module text"))]) (super-thunk))]) - (when (eof-object? expr) (raise-hopeless-syntax-error)) + (when (eof-object? expr) + (raise-hopeless-syntax-error (string-append + "There must be a valid module in the\n" + "definitions window. Try starting your program with\n" + "\n" + " #lang racket\n" + "\n" + "and clicking ‘Run’."))) (let ([more (super-thunk)]) (unless (eof-object? more) (raise-hopeless-syntax-error "there can only be one expression in the definitions window" more))) - (transform-module path expr))) + (transform-module path expr raise-hopeless-syntax-error))) (define modspec (or path `',(syntax-e name))) (define (check-interactive-language) (unless (memq '#%top-interaction (namespace-mapped-symbols)) @@ -341,7 +337,7 @@ #f #f ; no error message, just a suffix (format "~s does not support a REPL (no #%top-interaction)" (syntax->datum lang))))) - ;; We're about to send the module expression to drscheme now, the rest + ;; We're about to send the module expression to drracket now, the rest ;; of the setup is done in `front-end/finished-complete-program' below, ;; so use `repl-init-thunk' to store an appropriate continuation for ;; this setup. Once we send the expression, we'll be called again only @@ -516,16 +512,8 @@ (define (raise-hopeless-syntax-error . error-args) (with-handlers ([exn:fail? raise-hopeless-exception]) (apply raise-syntax-error '|Module Language| - (if (null? error-args) - (list (string-append - "There must be a valid module in the\n" - "definitions window. Try starting your program with\n" - "\n" - " #lang racket\n" - "\n" - "and clicking ‘Run’.")) - error-args)))) - + error-args))) + ;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void)) (define (module-language-config-panel parent) (define new-parent @@ -742,30 +730,6 @@ (send save-stacktrace-on-check-box set-value (module-language-settings-full-trace? settings)) (update-buttons)])) - ;; transform-module : (union #f path) syntax - ;; -> (values syntax[name-of-module] syntax[lang-of-module] syntax[module]) - ;; = User = - (define (transform-module filename stx) - (define-values (mod name lang body) - (syntax-case stx () - [(module name lang . body) - (eq? 'module (syntax-e #'module)) - (values #'module #'name #'lang #'body)] - [_ (raise-hopeless-syntax-error - (string-append "only a module expression is allowed, either\n" - " #lang \n or\n" - " (module ...)\n") - stx)])) - (define name* (syntax-e name)) - (unless (symbol? name*) - (raise-hopeless-syntax-error "bad syntax in name position of module" - stx name)) - (when filename (check-filename-matches filename name* stx)) - (let* (;; rewrite the module to use the racket/base version of `module' - [mod (datum->syntax #'here 'module mod)] - [expr (datum->syntax stx `(,mod ,name ,lang . ,body) stx stx)]) - (values name lang expr))) - ;; get-filename : port -> (union string #f) ;; extracts the file the definitions window is being saved in, if any. (define (get-filename port) @@ -786,34 +750,506 @@ filename))))))] [else #f]))) - ;; check-filename-matches : path datum syntax -> void - (define (check-filename-matches filename datum unexpanded-stx) - (when #f ; we don't check filename matching anymore - (let-values ([(base name dir?) (split-path filename)]) - (let ([expected (string->symbol - (path->string (path-replace-suffix name #"")))]) - (unless (equal? expected datum) - (raise-hopeless-syntax-error - (format - "module name doesn't match saved filename, got ~s and expected ~s" - datum - expected) - unexpanded-stx)))))) + (define-local-member-name + show-bkg-running + frame-show-bkg-running + restart-place + set-expand-error + update-frame-expand-error + expand-error-next + expand-error-prev) + (define module-language-online-expand-tab-mixin + (mixin (drracket:unit:tab<%>) () + (inherit get-frame) + (define bkg-label "") + (define bkg-colors '()) + (define bkg-state 'nothing) + + (define/public (add-bkg-running-color id color label) + (set! bkg-colors + (sort + (cons (list id color label) bkg-colors) + string<=? #:key (compose symbol->string car)))) + + (define/public (remove-bkg-running-color id) + (set! bkg-colors (filter (λ (x) (not (eq? (car x) id))) bkg-colors)) + (send (get-frame) frame-show-bkg-running (get-colors) (get-label))) + + (define/public (get-bkg-running) + (values (get-colors) (get-label))) + + (define/public (show-bkg-running state label) + (set! bkg-state state) + (set! bkg-label label) + (send (get-frame) frame-show-bkg-running (get-colors) (get-label))) + + (define/private (get-colors) + (case bkg-state + [(running) (list "blue")] + [(nothing) (if (null? bkg-colors) + #f + (map (λ (x) (list-ref x 1)) bkg-colors))] + [(failed) (list "red")] + [else (error 'show-bkg-running "unknown state ~s\n" bkg-state)])) + + (define/private (get-label) + (if (eq? bkg-state 'nothing) + (if (null? bkg-colors) + #f + (map (λ (x) (list-ref x 2)) bkg-colors)) + (list bkg-label))) + + (super-new))) + + (define module-language-online-expand-frame-mixin + (mixin (frame:basic<%> frame:info<%> drracket:unit:frame<%>) () + (inherit get-info-panel get-current-tab) + + (define expand-error-parent-panel #f) + (define expand-error-panel #f) + (define expand-error-message #f) + (define expand-error-button-parent-panel #f) + (define expand-error-single-child #f) + (define expand-error-multiple-child #f) + + (define colors #f) + (define tooltip-labels #f) + + (super-new) + + (define/override (make-root-area-container cls parent) + (set! expand-error-parent-panel + (super make-root-area-container vertical-panel% parent)) + (define root (make-object cls expand-error-parent-panel)) + (set! expand-error-panel + (new horizontal-panel% + [stretchable-height #f] + [parent expand-error-parent-panel])) + + (set! expand-error-message (new message% [parent expand-error-panel] [stretchable-width #t] [label "hi"])) + (set! expand-error-button-parent-panel + (new vertical-panel% + [stretchable-width #f] + [stretchable-height #f] + [parent expand-error-panel])) + (set! expand-error-single-child + (new button% + [parent expand-error-button-parent-panel] + [stretchable-width #t] + [label sc-jump-to-error] + [callback (λ (b evt) (send (send (get-current-tab) get-defs) expand-error-next))])) + (set! expand-error-multiple-child + (new horizontal-panel% [parent expand-error-button-parent-panel])) + (new button% + [label "<"] + [callback (λ (b evt) (send (send (get-current-tab) get-defs) expand-error-prev))] + [parent expand-error-multiple-child]) + (new message% + [parent expand-error-multiple-child] + [label sc-jump-to-error]) + (new button% + [label ">"] + [callback (λ (b evt) (send (send (get-current-tab) get-defs) expand-error-next))] + [parent expand-error-multiple-child]) + (send expand-error-button-parent-panel change-children (λ (l) (list expand-error-single-child))) + (send expand-error-parent-panel change-children (λ (l) (remq expand-error-panel l))) + root) + + (define expand-error-msg #f) + (define expand-error-srcloc-count 0) + + (define/public (set-expand-error msg srcloc-count) + (unless (and (equal? expand-error-msg msg) + (equal? expand-error-srcloc-count srcloc-count)) + (set! expand-error-msg msg) + (set! expand-error-srcloc-count srcloc-count) + (cond + [expand-error-msg + (send expand-error-message set-label expand-error-msg) + (send expand-error-parent-panel change-children + (λ (l) (append (remq expand-error-panel l) (list expand-error-panel)))) + (send expand-error-button-parent-panel change-children + (λ (l) (cond + [(= srcloc-count 0) '()] + [(= srcloc-count 1) + (list expand-error-single-child)] + [else + (list expand-error-multiple-child)])))] + [else + (send expand-error-parent-panel change-children + (λ (l) (remq expand-error-panel l)))]))) + + (define/augment (on-tab-change from-tab to-tab) + (send (send to-tab get-defs) restart-place) + (send (send to-tab get-defs) update-frame-expand-error) + (inner (void) on-tab-change from-tab to-tab)) + + (define/override (on-activate active?) + (define defs (send (get-current-tab) get-defs)) + (when active? + (send defs restart-place)) + (super on-activate active?)) + + (define/public (frame-show-bkg-running new-colors labels) + (unless (equal? tooltip-labels labels) + (set! tooltip-labels labels) + (update-tooltip)) + (unless (equal? new-colors colors) + (set! colors new-colors) + (send running-canvas refresh))) + + (define tooltip-frame #f) + (define/private (show-tooltip) + (cond + [tooltip-labels + (unless tooltip-frame + (set! tooltip-frame + (new (class frame% + (define/override (on-subwindow-event r evt) + (cond + [(send evt button-down?) + (hide-tooltip) + #t] + [else #f])) + (super-new [style '(no-resize-border no-caption float)] + [label ""] + [stretchable-width #f] + [stretchable-height #f] )))) + (new yellow-message% [parent tooltip-frame])) + (send (car (send tooltip-frame get-children)) set-lab tooltip-labels) + (send tooltip-frame reflow-container) + (define-values (rx ry) (send running-canvas client->screen 0 0)) + (send tooltip-frame move (- rx (send tooltip-frame get-width)) (- ry (send tooltip-frame get-height))) + (send tooltip-frame show #t)] + [else + (when tooltip-frame + (send tooltip-frame show #f))])) + (define/private (update-tooltip) + (when tooltip-frame + (cond + [tooltip-labels + (when (send tooltip-frame is-shown?) + ;; just call this, as it updates the tooltip label already + (show-tooltip))] + [else + (send tooltip-frame show #f)]))) + (define/private (hide-tooltip) + (when tooltip-frame + (send tooltip-frame show #f))) + + (define running-canvas + (new (class canvas% + (inherit get-dc popup-menu refresh) + (define/override (on-paint) + (let ([dc (get-dc)]) + (when colors + (send dc set-smoothing 'aligned) + (send dc set-pen "black" 1 'transparent) + (define len (length colors)) + (for ([color (in-list colors)] + [i (in-naturals)]) + (send dc set-brush color 'solid) + (send dc draw-arc 0 0 10 10 + (* 2 pi (/ i len)) + (* 2 pi (/ (+ i 1) len))))))) + (define cb-proc (λ (sym new-val) + (set! colors #f) + (refresh))) + (preferences:add-callback 'drracket:online-compilation cb-proc #t) + (define/override (on-event evt) + (cond + [(send evt button-down?) + (define menu (new popup-menu%)) + (define on? (preferences:get 'drracket:online-compilation)) + (new menu-item% + [parent menu] + [label (if on? + "Disable online compilation" + "Enable online compilation")] + [callback + (λ args + (preferences:set 'drracket:online-compilation (not on?)))]) + (popup-menu menu (send evt get-x) (send evt get-y))] + [(send evt entering?) + (show-tooltip)] + [(send evt leaving?) + (hide-tooltip)])) + (super-new [style '(transparent)] + [parent (get-info-panel)] + [stretchable-width #f] + [stretchable-height #f] + [min-width 10] + [min-height 10])))))) + + (define yellow-message% + (class canvas% + (inherit get-dc refresh get-client-size + min-width min-height + get-parent) + (define labels '("")) + (define/public (set-lab _ls) + (unless (equal? labels _ls) + (set! labels _ls) + (update-size) + (refresh))) + (define/private (update-size) + (define dc (get-dc)) + (send dc set-font small-control-font) + (define-values (w h _1 _2) (send dc get-text-extent (car labels))) + (send (get-parent) begin-container-sequence) + (min-width (+ 5 (inexact->exact (ceiling w)))) + (min-height (+ 5 (* (length labels) (inexact->exact (ceiling h))))) + (send (get-parent) end-container-sequence) + (send (get-parent) reflow-container)) + (define/override (on-paint) + (define dc (get-dc)) + (send dc set-font small-control-font) + (define-values (w h) (get-client-size)) + (define-values (tw th _1 _2) (send dc get-text-extent (car labels))) + (send dc set-pen "black" 1 'transparent) + (send dc set-brush "LemonChiffon" 'solid) + (send dc set-pen "black" 1 'solid) + (send dc draw-rectangle 0 0 (- w 1) (- h 1)) + (for ([label (in-list labels)] + [i (in-naturals)]) + (send dc draw-text label 2 (+ 2 (* i th))))) + (super-new [stretchable-width #f] [stretchable-height #f]))) + + (define expanding-place + (and (>= (processor-count) 1) + (dynamic-place expanding-place.rkt 'start))) + (define place-initialized? #f) + (define pending-thread #f) + + (define (send-to-place editor-contents filename prefab-module-settings show-results) + (when expanding-place + (unless place-initialized? + (set! place-initialized? #t) + (place-channel-put expanding-place module-language-compile-lock) + (place-channel-put 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))))) + (set! pending-thread + (thread (λ () + (define-values (pc-in pc-out) (place-channel)) + (define to-send + (vector-immutable editor-contents + filename + pc-in + prefab-module-settings)) + (place-channel-put expanding-place to-send) + (define res (place-channel-get pc-out)) + (when res + (let ([t (current-thread)]) + (queue-callback + (λ () + (when (eq? t pending-thread) + (set! pending-thread #f) + (show-results res))))))))))) + + (define (stop-place-running) + (when expanding-place + (when pending-thread + (place-channel-put expanding-place 'abort) + (set! pending-thread #f)))) + + (define module-language-online-expand-text-mixin + (mixin (text:basic<%> + drracket:unit:definitions-text<%> + drracket:module-language-tools:definitions-text<%>) () + (inherit last-position find-first-snip get-top-level-window get-filename + get-tab highlight-range get-canvas + set-position get-start-position get-end-position) + + (define compilation-out-of-date? #f) + + (define tmr (new timer% [notify-callback (lambda () (send-off))])) + + (define cb-proc (λ (sym new-val) + (when new-val + (queue-callback (λ () (buffer-modified)))))) + (preferences:add-callback 'drracket:online-compilation cb-proc #t) + + (define/private (buffer-modified) + (let ([tlw (get-top-level-window)]) + (when expanding-place + (when (in-module-language tlw) + (send (get-tab) show-bkg-running 'nothing #f) + (stop-place-running) + (set! compilation-out-of-date? #t) + (when (preferences:get 'drracket:online-compilation) + (when (eq? (send tlw get-current-tab) (get-tab)) + (send tmr stop) + (send tmr start 250 #t))))))) + + (define/public (restart-place) + (stop-place-running) + (when compilation-out-of-date? + (send tmr start 250 #t))) + + (define/private (send-off) + (define tlw (get-top-level-window)) + ;; make sure the frame's current tab is still this one + ;; (we may get #f for the tlw when the tab has been switched) + (when (and tlw (eq? (send tlw get-current-tab) (get-tab))) + (define settings (in-module-language tlw)) + (when settings + (define-values (editor-contents filename) (fetch-data-to-send)) + (when editor-contents + (send-to-place editor-contents + filename + (module-language-settings->prefab-module-settings settings) + (λ (res) (show-results res))) + (when status-line-open? + (clear-old-error) + (set! clear-old-error void) + (reset-frame-expand-error)) + (send (get-tab) show-bkg-running 'running sc-online-expansion-running))))) + + (define/private (fetch-data-to-send) + (define str (make-string (last-position) #\space)) + (let/ec k + (let loop ([s (find-first-snip)] + [i 0]) + (cond + [(not s) (void)] + [(is-a? s string-snip%) + (define size (send s get-count)) + (send s get-text! str 0 size i) + (loop (send s next) (+ i size))] + [else + (send (get-tab) show-bkg-running 'failed sc-only-raw-text-files-supported) + (k #f #f)])) + (define fn (let* ([b (box #f)] + [n (get-filename b)]) + (and (not (unbox b)) + n))) + (values str fn))) + + (define status-line-open? #f) + (define clear-old-error void) + + (define error-message-str #f) + (define error-message-srclocs '()) + (define/private (reset-frame-expand-error) + (set! error-message-str #f) + (set! error-message-srclocs '()) + (update-frame-expand-error)) + (define/public (update-frame-expand-error) + (send (send (get-tab) get-frame) set-expand-error + error-message-str + (length error-message-srclocs))) + + (define/public (expand-error-next) + (define candidates (filter (λ (error-message-srcloc) + (> (- (vector-ref error-message-srcloc 0) 1) + (get-end-position))) + error-message-srclocs)) + (cond + [(null? candidates) + (unless (null? error-message-srclocs) + (jump-to (car error-message-srclocs)))] + [else + (jump-to (car candidates))])) + + (define/public (expand-error-prev) + (define candidates (filter (λ (error-message-srcloc) + (< (+ (vector-ref error-message-srcloc 0) + (vector-ref error-message-srcloc 1) + -1) + (get-start-position))) + error-message-srclocs)) + (cond + [(null? candidates) + (unless (null? error-message-srclocs) + (jump-to (last error-message-srclocs)))] + [else + (jump-to (last candidates))])) + + (define/private (jump-to vec) + (set-position (- (vector-ref vec 0) 1)) + (define cnvs (get-canvas)) + (when cnvs (send cnvs focus))) + + (define/private (show-results res) + (set! compilation-out-of-date? #f) + (case (vector-ref res 0) + [(exn) + (define tlw (send (get-tab) get-frame)) + (send (get-tab) show-bkg-running 'nothing #f) + (clear-old-error) + (set! error-message-str (vector-ref res 1)) + (set! error-message-srclocs (vector-ref res 2)) + (set! clear-old-error + (for/fold ([clear void]) + ([range (in-list (vector-ref res 2))]) + (define pos (vector-ref range 0)) + (define span (vector-ref range 1)) + (define clear-next (highlight-range (- pos 1) (+ pos span -1) "Gold" #f 'high)) + (lambda () (clear) (clear-next)))) + (update-frame-expand-error)] + [(access-violation) + (send (get-tab) show-bkg-running 'failed (gui-utils:format-literal-label "~a" (vector-ref res 1))) + (clear-old-error) + (set! clear-old-error void) + (reset-frame-expand-error)] + [(abnormal-termination) + (send (get-tab) show-bkg-running 'failed sc-abnormal-termination) + (clear-old-error) + (set! clear-old-error void) + (reset-frame-expand-error)] + [(no-errors) + (send (get-tab) show-bkg-running 'nothing #f) + (clear-old-error) + (set! clear-old-error void) + (reset-frame-expand-error)] + [(handler-results) + (clear-old-error) + (set! clear-old-error void) + (reset-frame-expand-error) + ;; inform the installed handlers that something has come back + (for ([key-val (in-list (vector-ref res 1))]) + (define that-key (list-ref key-val 0)) + (define val (list-ref key-val 1)) + (for ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))]) + (define this-key (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h) + (drracket:module-language-tools:online-expansion-handler-id o-e-h))) + (when (equal? this-key that-key) + ((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h) this val)))) + (send (get-tab) show-bkg-running 'nothing #f)] + [else + (error 'module-language.rkt "unknown response from the expanding place: ~s\n" res)])) + + (define/override (move-to-new-language) + ;; this is here to get things running for the initital tab in a new frame + (super move-to-new-language) + (buffer-modified)) + + (define/augment (after-insert start end) + (buffer-modified) + (inner (void) after-insert start end)) + + (define/augment (after-delete start end) + (buffer-modified) + (inner (void) after-delete start end)) + + (define/augment (after-load-file success?) + (buffer-modified) + (inner (void) after-load-file success?)) + + (super-new))) + + (define module-language-put-file-mixin (mixin (text:basic<%>) () (inherit get-text last-position get-character get-top-level-window) + (define/override (put-file directory default-name) (let ([tlw (get-top-level-window)]) - (if (and tlw - (is-a? tlw drracket:unit:frame<%>)) - (let* ([definitions-text (send tlw get-definitions-text)] - [module-language? - (is-a? (drracket:language-configuration:language-settings-language - (send definitions-text get-next-settings)) - module-language<%>)] - [module-default-filename - (and module-language? (get-module-filename))]) + (if (in-module-language tlw) + (let ([module-default-filename (get-module-filename)]) (super put-file directory module-default-filename)) (super put-file directory default-name)))) @@ -875,7 +1311,17 @@ (super-new))) + (define module-language-compile-lock (make-compile-lock)) (define module-language-parallel-lock-client (compile-lock->parallel-lock-client - (make-compile-lock)))) + module-language-compile-lock)) + + ;; in-module-language : top-level-window<%> -> module-language-settings or #f + (define (in-module-language tlw) + (and tlw + (is-a? tlw drracket:unit:frame<%>) + (let ([settings (send (send tlw get-definitions-text) get-next-settings)]) + (and (is-a? (drracket:language-configuration:language-settings-language settings) + module-language<%>) + (drracket:language-configuration:language-settings-settings settings)))))) diff --git a/collects/drracket/private/multi-file-search.rkt b/collects/drracket/private/multi-file-search.rkt index 02d80be4aa..95a70af866 100644 --- a/collects/drracket/private/multi-file-search.rkt +++ b/collects/drracket/private/multi-file-search.rkt @@ -10,7 +10,8 @@ "drsig.rkt") (import [prefix drracket:frame: drracket:frame^] - [prefix drracket:unit: drracket:unit^]) + [prefix drracket:unit: drracket:unit^] + [prefix drracket: drracket:interface^]) (export drracket:multi-file-search^) ;; multi-file-search : -> void diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index 36e8f01043..7a92d35c56 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -79,17 +79,18 @@ TODO (parameterize-break #f (current-break-parameterization))) (define-unit rep@ - (import (prefix drracket:init: drracket:init^) - (prefix drracket:language-configuration: drracket:language-configuration/internal^) - (prefix drracket:language: drracket:language^) - (prefix drracket:app: drracket:app^) - (prefix drracket:frame: drracket:frame^) - (prefix drracket:unit: drracket:unit^) - (prefix drracket:text: drracket:text^) - (prefix drracket:help-desk: drracket:help-desk^) - (prefix drracket:debug: drracket:debug^) + (import [prefix drracket:init: drracket:init^] + [prefix drracket:language-configuration: drracket:language-configuration/internal^] + [prefix drracket:language: drracket:language^] + [prefix drracket:app: drracket:app^] + [prefix drracket:frame: drracket:frame^] + [prefix drracket:unit: drracket:unit^] + [prefix drracket:text: drracket:text^] + [prefix drracket:help-desk: drracket:help-desk^] + [prefix drracket:debug: drracket:debug^] [prefix drracket:eval: drracket:eval^] - [prefix drracket:module-language: drracket:module-language^]) + [prefix drracket:module-language: drracket:module-language/int^] + [prefix drracket: drracket:interface^]) (export (rename drracket:rep^ [-text% text%] [-text<%> text<%>])) @@ -141,51 +142,6 @@ TODO insert-prompt get-context)) - - (define context<%> - (interface () - ensure-rep-shown ;; (interactions-text -> void) - ;; make the rep visible in the frame - - repl-submit-happened ;; (-> boolean) - ;; notify the context that an evaluation is about to - ;; happen in the REPL (so it can show a warning about - ;; the language/etc is out of sync if neccessary). - - enable-evaluation ;; (-> void) - ;; make the context enable all methods of evaluation - ;; (disable buttons, menus, etc) - - disable-evaluation ;; (-> void) - ;; make the context disable all methods of evaluation - ;; (disable buttons, menus, etc) - - set-breakables ;; (union thread #f) (union custodian #f) -> void - ;; the context might initiate breaks or kills to - ;; the thread passed to this function - - get-breakables ;; -> (values (union thread #f) (union custodian #f)) - ;; returns the last values passed to set-breakables. - - reset-offer-kill ;; (-> void) - ;; the next time the break button is pushed, it will only - ;; break. (if the break button is clicked twice without - ;; this method being called in between, it will offer to - ;; kill the user's program) - - update-running ;; (boolean -> void) - ;; a callback to indicate that the repl may have changed its running state - ;; use the repls' get-in-evaluation? method to find out what the current state is. - - clear-annotations ;; (-> void) - ;; clear any error highlighting context - - get-directory ;; (-> (union #f string[existing directory])) - ;; returns the directory that should be the default for - ;; the `current-directory' and `current-load-relative-directory' - ;; parameters in the repl. - )) - (define sized-snip<%> (interface ((class->interface snip%)) ;; get-character-width : -> number @@ -553,7 +509,7 @@ TODO (define/public (set-definitions-text dt) (set! definitions-text dt)) (define/public (get-definitions-text) definitions-text) - (unless (is-a? context context<%>) + (unless (is-a? context drracket:rep:context<%>) (error 'drracket:rep:text% "expected an object that implements drracket:rep:context<%> as initialization argument, got: ~e" context)) diff --git a/collects/drracket/private/syncheck/annotate.rkt b/collects/drracket/private/syncheck/annotate.rkt index 6668e960a2..17211b3164 100644 --- a/collects/drracket/private/syncheck/annotate.rkt +++ b/collects/drracket/private/syncheck/annotate.rkt @@ -1,19 +1,15 @@ #lang racket/base (require racket/class - racket/gui/base - framework "intf.rkt") (provide color color-range find-source-editor - find-source-editor/defs - get-defs-text) + find-source-editor/defs) ;; color : syntax[original] str -> void ;; colors the syntax with style-name's style (define (color stx style-name mode) (let ([source (find-source-editor stx)]) - (when (and (is-a? source text%) - (syntax-position stx) + (when (and (syntax-position stx) (syntax-span stx)) (let ([pos (- (syntax-position stx) 1)] [span (syntax-span stx)]) @@ -22,56 +18,17 @@ ;; color-range : text start finish style-name ;; colors a range in the text based on `style-name' (define (color-range source start finish style-name mode) - (let ([style (send (send source get-style-list) - find-named-style - style-name)]) - (apply-style/remember source start finish style mode))) + (define defs (current-annotations)) + (when defs + (send defs syncheck:color-range source start finish style-name mode))) ;; find-source-editor : stx -> editor or false (define (find-source-editor stx) - (let ([defs-text (get-defs-text)]) + (let ([defs-text (current-annotations)]) (and defs-text (find-source-editor/defs stx defs-text)))) ;; find-source-editor : stx text -> editor or false (define (find-source-editor/defs stx defs-text) - (cond - [(not (syntax-source stx)) #f] - [(and (symbol? (syntax-source stx)) - (text:lookup-port-name (syntax-source stx))) - => values] - [else - (let txt-loop ([text defs-text]) - (cond - [(and (is-a? text text:basic<%>) - (send text port-name-matches? (syntax-source stx))) - text] - [else - (let snip-loop ([snip (send text find-first-snip)]) - (cond - [(not snip) - #f] - [(and (is-a? snip editor-snip%) - (send snip get-editor)) - (or (txt-loop (send snip get-editor)) - (snip-loop (send snip next)))] - [else - (snip-loop (send snip next))]))]))])) -;; get-defs-text : -> text or false -(define (get-defs-text) - (currently-processing-definitions-text)) + (send defs-text syncheck:find-source-object stx)) -;; apply-style/remember : (is-a?/c editor<%>) number number style% symbol -> void -(define (apply-style/remember ed start finish style mode) - (let ([outermost (find-outermost-editor ed)]) - (and (is-a? outermost syncheck-text<%>) - (send outermost syncheck:apply-style/remember ed start finish style mode)))) - -(define (find-outermost-editor ed) - (let loop ([ed ed]) - (let ([admin (send ed get-admin)]) - (if (is-a? admin editor-snip-editor-admin<%>) - (let* ([enclosing-snip (send admin get-snip)] - [enclosing-snip-admin (send enclosing-snip get-admin)]) - (loop (send enclosing-snip-admin get-editor))) - ed)))) diff --git a/collects/drracket/private/syncheck/colors.rkt b/collects/drracket/private/syncheck/colors.rkt index 2b03e92319..0d01de5cca 100644 --- a/collects/drracket/private/syncheck/colors.rkt +++ b/collects/drracket/private/syncheck/colors.rkt @@ -1,8 +1,4 @@ #lang racket/base -(require string-constants/string-constant - framework - racket/class - racket/gui/base) (provide (all-defined-out)) (define cs-my-obligation-color "my obligations") @@ -13,10 +9,14 @@ (define lexically-bound-variable-style-pref 'drracket:check-syntax:lexically-bound) (define imported-variable-style-pref 'drracket:check-syntax:imported) (define set!d-variable-style-pref 'drracket:check-syntax:set!d) +(define unused-require-style-pref 'drracket:check-syntax:unused-require) +(define free-variable-style-pref 'drracket:check-syntax:free-variable) (define lexically-bound-variable-style-name (symbol->string lexically-bound-variable-style-pref)) (define imported-variable-style-name (symbol->string imported-variable-style-pref)) (define set!d-variable-style-name (symbol->string set!d-variable-style-pref)) +(define unused-require-style-name (symbol->string unused-require-style-pref)) +(define free-variable-style-name (symbol->string free-variable-style-pref)) (define my-obligation-style-pref 'drracket:check-syntax:my-obligation-style-pref) (define their-obligation-style-pref 'drracket:check-syntax:their-obligation-style-pref) @@ -28,65 +28,3 @@ (define unk-obligation-style-name (symbol->string unk-obligation-style-pref)) (define both-obligation-style-name (symbol->string both-obligation-style-pref)) -(define error-style-name (scheme:short-sym->style-name 'error)) -;(define constant-style-name (scheme:short-sym->style-name 'constant)) - -(define (syncheck-add-to-preferences-panel parent) - (color-prefs:build-color-selection-panel parent - lexically-bound-variable-style-pref - lexically-bound-variable-style-name - (string-constant cs-lexical-variable)) - (color-prefs:build-color-selection-panel parent - imported-variable-style-pref - imported-variable-style-name - (string-constant cs-imported-variable)) - (color-prefs:build-color-selection-panel parent - set!d-variable-style-pref - set!d-variable-style-name - (string-constant cs-set!d-variable)) - (color-prefs:build-color-selection-panel parent - my-obligation-style-pref - my-obligation-style-name - cs-my-obligation-color) - (color-prefs:build-color-selection-panel parent - their-obligation-style-pref - their-obligation-style-name - cs-their-obligation-color) - (color-prefs:build-color-selection-panel parent - unk-obligation-style-pref - unk-obligation-style-name - cs-unk-obligation-color) - (color-prefs:build-color-selection-panel parent - both-obligation-style-pref - both-obligation-style-name - cs-both-obligation-color)) - -(color-prefs:register-color-preference lexically-bound-variable-style-pref - lexically-bound-variable-style-name - (make-object color% 81 112 203) - (make-object color% 50 163 255)) -(color-prefs:register-color-preference set!d-variable-style-pref - set!d-variable-style-name - (send the-color-database find-color "firebrick") - (send the-color-database find-color "pink")) -(color-prefs:register-color-preference imported-variable-style-pref - imported-variable-style-name - (make-object color% 68 0 203) - (make-object color% 166 0 255)) -(color-prefs:register-color-preference my-obligation-style-pref - my-obligation-style-name - (send the-color-database find-color "firebrick") - (send the-color-database find-color "pink")) -(color-prefs:register-color-preference their-obligation-style-pref - their-obligation-style-name - (make-object color% 0 116 0) - (send the-color-database find-color "limegreen")) -(color-prefs:register-color-preference unk-obligation-style-pref - unk-obligation-style-name - (send the-color-database find-color "black") - (send the-color-database find-color "white")) -(color-prefs:register-color-preference both-obligation-style-pref - both-obligation-style-name - (make-object color% 139 142 28) - (send the-color-database find-color "khaki")) - diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 6010e49c60..8b9b7f12e3 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -19,12 +19,16 @@ If the namespace does not, they are colored the unbound color. (require string-constants racket/unit + racket/match racket/contract racket/class racket/list racket/promise racket/pretty racket/dict + racket/set + racket/runtime-path + racket/place data/interval-map drracket/tool syntax/toplevel @@ -41,10 +45,12 @@ If the namespace does not, they are colored the unbound color. net/uri-codec browser/external (for-syntax racket/base) + (only-in ffi/unsafe register-finalizer) "../../syncheck-drracket-button.rkt" "intf.rkt" "colors.rkt" - "traversals.rkt") + "traversals.rkt" + "annotate.rkt") (provide tool@) (define orig-output-port (current-output-port)) @@ -64,11 +70,90 @@ If the namespace does not, they are colored the unbound color. (define cs-mode-menu-show-client-obligations (string-constant cs-mode-menu-show-client-obligations)) (define cs-mode-menu-show-syntax (string-constant cs-mode-menu-show-syntax)) +(define cs-syncheck-running "Check Syntax Running") + (preferences:set-default 'drracket:syncheck-mode 'default-mode (λ (x) (memq x '(default-mode my-obligations-mode client-obligations-mode)))) +(define (syncheck-add-to-preferences-panel parent) + (color-prefs:build-color-selection-panel parent + lexically-bound-variable-style-pref + lexically-bound-variable-style-name + (string-constant cs-lexical-variable)) + (color-prefs:build-color-selection-panel parent + imported-variable-style-pref + imported-variable-style-name + (string-constant cs-imported-variable)) + (color-prefs:build-color-selection-panel parent + set!d-variable-style-pref + set!d-variable-style-name + (string-constant cs-set!d-variable)) + (color-prefs:build-color-selection-panel parent + unused-require-style-pref + unused-require-style-name + (string-constant cs-unused-require)) + (color-prefs:build-color-selection-panel parent + free-variable-style-pref + free-variable-style-name + (string-constant cs-free-variable)) + + (color-prefs:build-color-selection-panel parent + my-obligation-style-pref + my-obligation-style-name + cs-my-obligation-color) + (color-prefs:build-color-selection-panel parent + their-obligation-style-pref + their-obligation-style-name + cs-their-obligation-color) + (color-prefs:build-color-selection-panel parent + unk-obligation-style-pref + unk-obligation-style-name + cs-unk-obligation-color) + (color-prefs:build-color-selection-panel parent + both-obligation-style-pref + both-obligation-style-name + cs-both-obligation-color)) + +(color-prefs:register-color-preference lexically-bound-variable-style-pref + lexically-bound-variable-style-name + (make-object color% 81 112 203) + (make-object color% 50 163 255)) +(color-prefs:register-color-preference set!d-variable-style-pref + set!d-variable-style-name + (send the-color-database find-color "firebrick") + (send the-color-database find-color "pink")) +(color-prefs:register-color-preference unused-require-style-pref + unused-require-style-name + (send the-color-database find-color "red") + (send the-color-database find-color "pink")) +(color-prefs:register-color-preference free-variable-style-pref + free-variable-style-name + (send the-color-database find-color "red") + (send the-color-database find-color "pink")) + +(color-prefs:register-color-preference imported-variable-style-pref + imported-variable-style-name + (make-object color% 68 0 203) + (make-object color% 166 0 255)) +(color-prefs:register-color-preference my-obligation-style-pref + my-obligation-style-name + (send the-color-database find-color "firebrick") + (send the-color-database find-color "pink")) +(color-prefs:register-color-preference their-obligation-style-pref + their-obligation-style-name + (make-object color% 0 116 0) + (send the-color-database find-color "limegreen")) +(color-prefs:register-color-preference unk-obligation-style-pref + unk-obligation-style-name + (send the-color-database find-color "black") + (send the-color-database find-color "white")) +(color-prefs:register-color-preference both-obligation-style-pref + both-obligation-style-name + (make-object color% 139 142 28) + (send the-color-database find-color "khaki")) + (define tool@ (unit (import drracket:tool^) @@ -201,6 +286,7 @@ If the namespace does not, they are colored the unbound color. (when (and st (is-a? st drracket:unit:definitions-text<%>)) (let ([tab (send st get-tab)]) + (send (send tab get-frame) set-syncheck-running-mode #f) (send tab syncheck:clear-error-message) (send tab syncheck:clear-highlighting)))))) @@ -217,12 +303,12 @@ If the namespace does not, they are colored the unbound color. (let* ([cursor-arrow (make-object cursor% 'arrow)]) (class* super% (syncheck-text<%>) (inherit set-cursor get-admin invalidate-bitmap-cache set-position - get-pos/text position-location + get-pos/text get-pos/text-dc-location position-location get-canvas last-position dc-location-to-editor-location find-position begin-edit-sequence end-edit-sequence highlight-range unhighlight-range paragraph-end-position first-line-currently-drawn-specially?) - + ;; arrow-records : (U #f hash[text% => arrow-record]) ;; arrow-record = interval-map[(listof arrow-entry)] ;; arrow-entry is one of @@ -418,6 +504,27 @@ If the namespace does not, they are colored the unbound color. (hash-set! style-mapping mode (cons (list txt start finish style) (hash-ref style-mapping mode '()))))) + (define/public (syncheck:color-range source start finish style-name mode) + (when (is-a? source text%) + (define (apply-style/remember ed start finish style mode) + (let ([outermost (find-outermost-editor ed)]) + (and (is-a? outermost syncheck-text<%>) + (send outermost syncheck:apply-style/remember ed start finish style mode)))) + + (define (find-outermost-editor ed) + (let loop ([ed ed]) + (let ([admin (send ed get-admin)]) + (if (is-a? admin editor-snip-editor-admin<%>) + (let* ([enclosing-snip (send admin get-snip)] + [enclosing-snip-admin (send enclosing-snip get-admin)]) + (loop (send enclosing-snip-admin get-editor))) + ed)))) + + (let ([style (send (send source get-style-list) + find-named-style + style-name)]) + (apply-style/remember source start finish style mode)))) + ;; add-to-cleanup/apply-style : (is-a?/c text%) number number style% symbol -> boolean (define/private (add-to-cleanup/apply-style txt start finish style) (cond @@ -429,15 +536,142 @@ If the namespace does not, they are colored the unbound color. #t] [else #f])) - (define/public (syncheck:add-menu text start-pos end-pos key make-menu) + (define/public (syncheck:add-require-open-menu text start-pos end-pos file) + (define (make-require-open-menu file) + (λ (menu) + (let-values ([(base name dir?) (split-path file)]) + (instantiate menu-item% () + (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 tag) + (syncheck:add-menu + text start-pos end-pos id + (λ (menu) + (instantiate menu-item% () + (parent menu) + (label (gui-utils:format-literal-label "~a" the-label)) + (callback + (λ (x y) + (let* ([url (path->url path)] + [url2 (if tag + (make-url (url-scheme url) + (url-user url) + (url-host url) + (url-port url) + (url-path-absolute? url) + (url-path url) + (url-query url) + tag) + url)]) + (send-url (url->string url2))))))))) + + (define/public (syncheck:add-rename-menu id-as-sym to-be-renamed/poss name-dup?) + (define (make-menu menu) + (let ([name-to-offer (format "~a" id-as-sym)]) + (instantiate menu-item% () + (parent menu) + (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)]) + (rename-callback name-to-offer + frame-parent))))))) + + ;; rename-callback : string + ;; (and/c syncheck-text<%> definitions-text<%>) + ;; (list source number number) + ;; (listof id-set) + ;; (union #f (is-a?/c top-level-window<%>)) + ;; -> void + ;; callback for the rename popup menu item + (define (rename-callback name-to-offer parent) + (let ([new-str + (fw:keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (string-constant cs-rename-id) + (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) + parent + name-to-offer)))]) + (when new-str + (define new-sym (format "~s" (string->symbol new-str))) + (define dup-name? (name-dup? new-sym)) + + (define do-renaming? + (or (not dup-name?) + (equal? + (message-box/custom + (string-constant check-syntax) + (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) + new-sym) + (string-constant cs-rename-anyway) + (string-constant cancel) + #f + parent + '(stop default=2)) + 1))) + + (when do-renaming? + (unless (null? to-be-renamed/poss) + (let ([txts (list this)]) + (define positions-to-rename + (remove-duplicates + (sort to-be-renamed/poss + > + #:key cadr))) + (begin-edit-sequence) + (for ([info (in-list positions-to-rename)]) + (define source-editor (list-ref info 0)) + (define start (list-ref info 1)) + (define end (list-ref info 2)) + (when (is-a? source-editor text%) + (unless (memq source-editor txts) + (send source-editor begin-edit-sequence) + (set! txts (cons source-editor txts))) + (send source-editor delete start end #f) + (send source-editor insert new-sym start start #f))) + (invalidate-bitmap-cache) + (for ([txt (in-list txts)]) + (send txt end-edit-sequence)))))))) + + + ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) + (define (find-menu-parent menu) + (let loop ([menu menu]) + (cond + [(is-a? menu menu-bar%) (send menu get-frame)] + [(is-a? menu popup-menu%) + (let ([target (send menu get-popup-target)]) + (cond + [(is-a? target editor<%>) + (let ([canvas (send target get-canvas)]) + (and canvas + (send canvas get-top-level-window)))] + [(is-a? target window<%>) + (send target get-top-level-window)] + [else #f]))] + [(is-a? menu menu-item<%>) (loop (send menu get-parent))] + [else #f]))) + + (for ([loc (in-list to-be-renamed/poss)]) + (define source (list-ref loc 0)) + (define start (list-ref loc 1)) + (define fin (list-ref loc 2)) + (syncheck:add-menu source start fin id-as-sym make-menu))) + + (define/private (syncheck:add-menu text start-pos end-pos key make-menu) (when arrow-records (when (and (<= 0 start-pos end-pos (last-position))) - (add-to-range/key text start-pos end-pos make-menu key #t)))) + (add-to-range/key text start-pos end-pos make-menu key (and key #t))))) - (define/public (syncheck:add-background-color text color start fin key) + (define/public (syncheck:add-background-color text start fin color) (when arrow-records (when (is-a? text text:basic<%>) - (add-to-range/key text start fin (make-colored-region color text start fin) key #f)))) + (add-to-range/key text start fin (make-colored-region color text start fin) #f #f)))) ;; syncheck:add-arrow : symbol text number number text number number boolean -> void ;; pre: start-editor, end-editor are embedded in `this' (or are `this') @@ -445,13 +679,13 @@ If the namespace does not, they are colored the unbound color. end-text end-pos-left end-pos-right actual? level) (when arrow-records - (let* ([arrow (make-var-arrow #f #f #f #f - start-text start-pos-left start-pos-right - end-text end-pos-left end-pos-right - actual? level)]) - (when (add-to-bindings-table - start-text start-pos-left start-pos-right - end-text end-pos-left end-pos-right) + (when (add-to-bindings-table + start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right) + (let ([arrow (make-var-arrow #f #f #f #f + start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right + actual? level)]) (add-to-range/key start-text start-pos-left start-pos-right arrow #f #f) (add-to-range/key end-text end-pos-left end-pos-right arrow #f #f))))) @@ -469,8 +703,9 @@ If the namespace does not, they are colored the unbound color. ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void (define/public (syncheck:add-mouse-over-status text pos-left pos-right str) - (when arrow-records - (add-to-range/key text pos-left pos-right str #f #f))) + (let ([str (gui-utils:format-literal-label "~a" str)]) + (when arrow-records + (add-to-range/key text pos-left pos-right str #f #f)))) ;; add-to-range/key : text number number any any boolean -> void ;; adds `key' to the range `start' - `end' in the editor @@ -634,7 +869,18 @@ If the namespace does not, they are colored the unbound color. (for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text tail-arrow-to-pos tail-arrow-to-text)) + (define last-known-mouse-x #f) + (define last-known-mouse-y #f) (define/override (on-event event) + + (cond + [(send event leaving?) + (set! last-known-mouse-x #f) + (set! last-known-mouse-y #f)] + [else + (set! last-known-mouse-x (send event get-x)) + (set! last-known-mouse-y (send event get-y))]) + (if arrow-records (cond [(send event leaving?) @@ -650,36 +896,7 @@ If the namespace does not, they are colored the unbound color. (super on-event event)] [(or (send event moving?) (send event entering?)) - (let-values ([(pos text) (get-pos/text event)]) - (cond - [(and pos (is-a? text text%)) - (unless (and (equal? pos cursor-location) - (eq? cursor-text text)) - (set! cursor-location pos) - (set! cursor-text text) - - (let* ([arrow-record (hash-ref arrow-records cursor-text #f)] - [eles (and arrow-record (interval-map-ref arrow-record cursor-location null))]) - - (unless (equal? cursor-eles eles) - (set! cursor-eles eles) - (update-docs-background eles) - (when eles - (update-status-line eles) - (for ([ele (in-list eles)]) - (cond [(arrow? ele) - (update-arrow-poss ele)])) - (invalidate-bitmap-cache)))))] - [else - (update-docs-background #f) - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line 'drracket:check-syntax:mouse-over #f))) - (when (or cursor-location cursor-text) - (set! cursor-location #f) - (set! cursor-text #f) - (set! cursor-eles #f) - (invalidate-bitmap-cache))])) + (syncheck:update-drawn-arrows) (super on-event event)] [(send event button-down? 'right) (define menu @@ -694,6 +911,40 @@ If the namespace does not, they are colored the unbound color. (super on-event event)])] [else (super on-event event)]) (super on-event event))) + + (define/public (syncheck:update-drawn-arrows) + (let-values ([(pos text) (if (and last-known-mouse-x last-known-mouse-y) + (get-pos/text-dc-location last-known-mouse-x last-known-mouse-y) + (values #f #f))]) + (cond + [(and pos (is-a? text text%)) + (unless (and (equal? pos cursor-location) + (eq? cursor-text text)) + (set! cursor-location pos) + (set! cursor-text text) + + (let* ([arrow-record (hash-ref arrow-records cursor-text #f)] + [eles (and arrow-record (interval-map-ref arrow-record cursor-location null))]) + + (unless (equal? cursor-eles eles) + (set! cursor-eles eles) + (update-docs-background eles) + (when eles + (update-status-line eles) + (for ([ele (in-list eles)]) + (cond [(arrow? ele) + (update-arrow-poss ele)])) + (invalidate-bitmap-cache)))))] + [else + (update-docs-background #f) + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drracket:check-syntax:mouse-over #f))) + (when (or cursor-location cursor-text) + (set! cursor-location #f) + (set! cursor-text #f) + (set! cursor-eles #f) + (invalidate-bitmap-cache))]))) (define/public (syncheck:build-popup-menu pos text) (and pos @@ -1002,7 +1253,31 @@ If the namespace does not, they are colored the unbound color. (for ((txt (in-list edit-sequences))) (send txt end-edit-sequence)))) - + + (define/public (syncheck:find-source-object stx) + (cond + [(not (syntax-source stx)) #f] + [(and (symbol? (syntax-source stx)) + (text:lookup-port-name (syntax-source stx))) + => values] + [else + (let txt-loop ([text this]) + (cond + [(and (is-a? text text:basic<%>) + (send text port-name-matches? (syntax-source stx))) + text] + [else + (let snip-loop ([snip (send text find-first-snip)]) + (cond + [(not snip) + #f] + [(and (is-a? snip editor-snip%) + (send snip get-editor)) + (or (txt-loop (send snip get-editor)) + (snip-loop (send snip next)))] + [else + (snip-loop (send snip next))]))]))])) + (super-new))))) (define syncheck-frame<%> @@ -1095,6 +1370,96 @@ If the namespace does not, they are colored the unbound color. (list check-syntax-button) '()))))) + ;; 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...) + ;; - 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 + ;; a box is passed in + (define/public (set-syncheck-running-mode mode) + (cond + [(not mode) + (when (box? current-syncheck-running-mode) + (set-box! current-syncheck-running-mode #f)) + (set! current-syncheck-running-mode #f) + #t] + [(box? mode) + (cond + [(eq? current-syncheck-running-mode 'button) + #f] + [(eq? mode current-syncheck-running-mode) + ;; this shouldn't happen, I think + #t] + [else + (when (box? current-syncheck-running-mode) + (set-box! current-syncheck-running-mode #f)) + (set! current-syncheck-running-mode mode) + #t])] + [(eq? 'button mode) + (when (box? current-syncheck-running-mode) + (set-box! current-syncheck-running-mode #f)) + (set! current-syncheck-running-mode mode) + #t] + [else + (error 'set-syncheck-running-mode "unknown new mode ~s\n" mode)])) + + (define current-syncheck-running-mode #f) + + (define/public (replay-compile-comp-trace defs-text val) + (define bx (box #t)) + (when (set-syncheck-running-mode bx) + (send (send defs-text get-tab) add-bkg-running-color 'syncheck "forestgreen" cs-syncheck-running) + (send defs-text syncheck:init-arrows) + (let loop ([val val] + [i 0]) + (cond + [(null? val) + (send defs-text syncheck:update-drawn-arrows) + (send (send defs-text get-tab) remove-bkg-running-color 'syncheck) + (set-syncheck-running-mode #f)] + [(= i 500) + (queue-callback + (λ () + (when (unbox bx) + (loop (cdr val) 0))) + #f)] + [else + (process-trace-element defs-text (car val)) + (loop (cdr val) (+ i 1))])))) + + (define/private (process-trace-element defs-text x) + ;; using 'defs-text' all the time is wrong in the case of embedded editors, + ;; but they already don't work and we've arranged for them to not appear here .... + (match x + [`(syncheck:add-arrow ,start-text ,start-pos-left ,start-pos-right + ,end-text ,end-pos-left ,end-pos-right + ,actual? ,level) + (send defs-text syncheck:add-arrow + defs-text start-pos-left start-pos-right + defs-text end-pos-left end-pos-right + actual? level)] + [`(syncheck:add-tail-arrow ,from-text ,from-pos ,to-text ,to-pos) + (send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)] + [`(syncheck:add-mouse-over-status ,text ,pos-left ,pos-right ,str) + (send defs-text syncheck:add-mouse-over-status defs-text pos-left pos-right str)] + [`(syncheck:add-background-color ,text ,color ,start ,fin) + (send defs-text syncheck:add-background-color defs-text color start fin)] + [`(syncheck:add-jump-to-definition ,text ,start ,end ,id ,filename) + (send defs-text syncheck:add-jump-to-definition defs-text start end id filename)] + [`(syncheck:add-require-open-menu ,text ,start-pos ,end-pos ,file) + (send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)] + [`(syncheck:add-docs-menu ,text ,start-pos ,end-pos ,key ,the-label ,path ,tag) + (send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path tag)] + [`(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) + (define (name-dup? name) (place-channel-put/get name-dup-pc (list name-dup-id name))) + (define to-be-renamed/poss/fixed + (for/list ([lst (in-list to-be-renamed/poss)]) + (list defs-text (list-ref lst 1) (list-ref lst 2)))) + (send defs-text syncheck:add-rename-menu id-as-sym to-be-renamed/poss/fixed + name-dup?)])) + (define/augment (enable-evaluation) (send check-syntax-button enable #t) (send mode-menu-item1 enable #t) @@ -1224,165 +1589,212 @@ If the namespace does not, they are colored the unbound color. (open-status-line 'drracket:check-syntax:status) (update-status-line 'drracket:check-syntax:status status-init) (ensure-rep-hidden) - (let-values ([(expanded-expression expansion-completed) (make-traversal)]) - (let* ([definitions-text (get-definitions-text)] - [interactions-text (get-interactions-text)] - [drs-eventspace (current-eventspace)] - [the-tab (get-current-tab)]) - (let-values ([(old-break-thread old-custodian) (send the-tab get-breakables)]) - (let* ([user-namespace #f] - [user-directory #f] - [user-custodian #f] - [normal-termination? #f] - - [show-error-report/tab - (λ () ; =drs= - (send the-tab turn-on-error-report) - (send (send the-tab get-error-report-text) scroll-to-position 0) - (when (eq? (get-current-tab) the-tab) - (show-error-report)))] - [cleanup - (λ () ; =drs= - (send the-tab set-breakables old-break-thread old-custodian) - (send the-tab enable-evaluation) - (close-status-line 'drracket:check-syntax:status) - - ;; do this with some lag ... not great, but should be okay. - (let ([err-port (send (send the-tab get-error-report-text) get-err-port)]) - (thread - (λ () - (flush-output err-port) - (queue-callback - (λ () - (unless (= 0 (send (send the-tab get-error-report-text) last-position)) - (show-error-report/tab))))))))] - [kill-termination - (λ () - (unless normal-termination? - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () - (send the-tab syncheck:clear-highlighting) - (cleanup) - (custodian-shutdown-all user-custodian))))))] - [error-display-semaphore (make-semaphore 0)] - [uncaught-exception-raised - (λ () ;; =user= - (set! normal-termination? #t) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () ;; =drs= - (yield error-display-semaphore) ;; let error display go first - (send the-tab syncheck:clear-highlighting) - (cleanup) - (custodian-shutdown-all user-custodian)))))] - [error-port (send (send the-tab get-error-report-text) get-err-port)] - [output-port (send (send the-tab get-error-report-text) get-out-port)] - [init-proc - (λ () ; =user= - (send the-tab set-breakables (current-thread) (current-custodian)) - (set-directory definitions-text) - (current-error-port error-port) - (current-output-port output-port) - (error-display-handler - (λ (msg exn) ;; =user= - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () ;; =drs= - - ;; this has to come first or else the positioning - ;; computations in the highlight-errors/exn method - ;; will be wrong by the size of the error report box - (show-error-report/tab) - - ;; a call like this one also happens in - ;; drracket:debug:error-display-handler/stacktrace - ;; but that call won't happen here, because - ;; the rep is not in the current-rep parameter - (send interactions-text highlight-errors/exn exn)))) - - (drracket:debug:error-display-handler/stacktrace - msg - exn - '() - #:definitions-text definitions-text) - - (semaphore-post error-display-semaphore))) - - (error-print-source-location #f) ; need to build code to render error first - (uncaught-exception-handler - (let ([oh (uncaught-exception-handler)]) - (λ (exn) - (uncaught-exception-raised) - (oh exn)))) - (update-status-line 'drracket:check-syntax:status status-expanding-expression) - (set! user-custodian (current-custodian)) - (set! user-directory (current-directory)) ;; set by set-directory above - (set! user-namespace (current-namespace)))]) - (send the-tab disable-evaluation) ;; this locks the editor, so must be outside. - - (define definitions-text-copy - (new (class text:basic% - ;; overriding get-port-name like this ensures - ;; that the resulting syntax objects are connected - ;; to the actual definitions-text, not this copy - (define/override (get-port-name) - (send definitions-text get-port-name)) - (super-new)))) - (define settings (send definitions-text get-next-settings)) - (define module-language? - (is-a? (drracket:language-configuration:language-settings-language settings) - drracket:module-language:module-language<%>)) - (send definitions-text copy-self-to definitions-text-copy) - (with-lock/edit-sequence - definitions-text-copy + (define definitions-text (get-definitions-text)) + (define interactions-text (get-interactions-text)) + (define drs-eventspace (current-eventspace)) + (define the-tab (get-current-tab)) + (define-values (old-break-thread old-custodian) (send the-tab get-breakables)) + + ;; set by the init-proc + (define expanded-expression void) + (define expansion-completed void) + (define user-custodian #f) + + (define normal-termination? #f) + + (define show-error-report/tab + (λ () ; =drs= + (send the-tab turn-on-error-report) + (send (send the-tab get-error-report-text) scroll-to-position 0) + (when (eq? (get-current-tab) the-tab) + (show-error-report)))) + (define cleanup + (λ () ; =drs= + (send the-tab set-breakables old-break-thread old-custodian) + (send the-tab enable-evaluation) + (set-syncheck-running-mode #f) + (close-status-line 'drracket:check-syntax:status) + + ;; do this with some lag ... not great, but should be okay. + (let ([err-port (send (send the-tab get-error-report-text) get-err-port)]) + (thread + (λ () + (flush-output err-port) + (queue-callback + (λ () + (unless (= 0 (send (send the-tab get-error-report-text) last-position)) + (show-error-report/tab))))))))) + (define kill-termination + (λ () + (unless normal-termination? + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback (λ () - (send the-tab clear-annotations) - (send the-tab reset-offer-kill) - (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)) - settings - (not module-language?) - init-proc - kill-termination - (λ (sexp loop) ; =user= - (cond - [(eof-object? sexp) - (set! normal-termination? #t) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () ; =drs= - (with-lock/edit-sequence - definitions-text - (λ () - (parameterize ([currently-processing-definitions-text definitions-text]) - (expansion-completed user-namespace user-directory) - (send (send (get-current-tab) get-defs) set-syncheck-mode mode) - (update-menu-status (get-current-tab)) - (send definitions-text syncheck:sort-bindings-table)))) - (cleanup) - (custodian-shutdown-all user-custodian))))] - [else + (send the-tab syncheck:clear-highlighting) + (cleanup) + (custodian-shutdown-all user-custodian))))))) + (define error-display-semaphore (make-semaphore 0)) + (define uncaught-exception-raised + (λ () ;; =user= + (set! normal-termination? #t) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ;; =drs= + (yield error-display-semaphore) ;; let error display go first + (send the-tab syncheck:clear-highlighting) + (cleanup) + (custodian-shutdown-all user-custodian)))))) + (define error-port (send (send the-tab get-error-report-text) get-err-port)) + (define output-port (send (send the-tab get-error-report-text) get-out-port)) + (define init-proc + (λ () ; =user= + (send the-tab set-breakables (current-thread) (current-custodian)) + (set-directory definitions-text) + (current-error-port error-port) + (current-output-port output-port) + (error-display-handler + (λ (msg exn) ;; =user= + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ;; =drs= + + ;; this has to come first or else the positioning + ;; computations in the highlight-errors/exn method + ;; will be wrong by the size of the error report box + (show-error-report/tab) + + ;; a call like this one also happens in + ;; drracket:debug:error-display-handler/stacktrace + ;; but that call won't happen here, because + ;; the rep is not in the current-rep parameter + (send interactions-text highlight-errors/exn exn)))) + + (drracket:debug:error-display-handler/stacktrace + msg + exn + '() + #:definitions-text definitions-text) + + (semaphore-post error-display-semaphore))) + + (error-print-source-location #f) ; need to build code to render error first + (uncaught-exception-handler + (let ([oh (uncaught-exception-handler)]) + (λ (exn) + (uncaught-exception-raised) + (oh exn)))) + (update-status-line 'drracket:check-syntax:status status-expanding-expression) + (set!-values (expanded-expression expansion-completed) + (make-traversal (current-namespace) + (current-directory))) ;; set by set-directory above + (set! user-custodian (current-custodian)))) + + (set-syncheck-running-mode 'button) + (send the-tab disable-evaluation) ;; this locks the editor, so must be outside. + (define definitions-text-copy + (new (class text:basic% + ;; overriding get-port-name like this ensures + ;; that the resulting syntax objects are connected + ;; to the actual definitions-text, not this copy + (define/override (get-port-name) + (send definitions-text get-port-name)) + (super-new)))) + (define settings (send definitions-text get-next-settings)) + (define module-language? + (is-a? (drracket:language-configuration:language-settings-language settings) + drracket:module-language:module-language<%>)) + (send definitions-text copy-self-to definitions-text-copy) + (with-lock/edit-sequence + definitions-text-copy + (λ () + (send the-tab clear-annotations) + (send the-tab reset-offer-kill) + (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)) + settings + (not module-language?) + init-proc + kill-termination + (λ (sexp loop) ; =user= + (cond + [(eof-object? sexp) + (set! normal-termination? #t) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ; =drs= + (with-lock/edit-sequence + definitions-text + (λ () + (parameterize ([current-annotations definitions-text]) + (expansion-completed)) + (send (send (get-current-tab) get-defs) set-syncheck-mode mode) + (update-menu-status (get-current-tab)) + (send definitions-text syncheck:sort-bindings-table))) + (cleanup) + (custodian-shutdown-all user-custodian))))] + [else + (open-status-line 'drracket:check-syntax:status) + (unless module-language? + (update-status-line 'drracket:check-syntax:status status-eval-compile-time) + (eval-compile-time-part-of-top-level sexp)) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ; =drs= + (with-lock/edit-sequence + definitions-text + (λ () (open-status-line 'drracket:check-syntax:status) - (unless module-language? - (update-status-line 'drracket:check-syntax:status status-eval-compile-time) - (eval-compile-time-part-of-top-level sexp)) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () ; =drs= - (with-lock/edit-sequence - definitions-text - (λ () - (open-status-line 'drracket:check-syntax:status) - (update-status-line 'drracket:check-syntax:status status-coloring-program) - (parameterize ([currently-processing-definitions-text definitions-text]) - (expanded-expression user-namespace user-directory sexp jump-to-id)) - (close-status-line 'drracket:check-syntax:status)))))) - (update-status-line 'drracket:check-syntax:status status-expanding-expression) - (close-status-line 'drracket:check-syntax:status) - (loop)]))))))))))])) + (update-status-line 'drracket:check-syntax:status status-coloring-program) + (parameterize ([current-annotations definitions-text]) + (expanded-expression sexp (if jump-to-id (make-visit-id jump-to-id) void))) + (close-status-line 'drracket:check-syntax:status)))))) + (update-status-line 'drracket:check-syntax:status status-expanding-expression) + (close-status-line 'drracket:check-syntax:status) + (loop)]))))))])) + + (define (make-visit-id jump-to-id) + (λ (vars) + (when jump-to-id + (for ([id (in-list (syntax->list vars))]) + (let ([binding (identifier-binding id 0)]) + (when (pair? binding) + (let ([nominal-source-id (list-ref binding 3)]) + (when (eq? nominal-source-id jump-to-id) + (let ([stx id]) + (let ([src (find-source-editor stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (when (and (is-a? src text%) + pos + span) + (send src begin-edit-sequence) + + ;; try to scroll so stx's location is + ;; near the top of the visible region + (let ([admin (send src get-admin)]) + (when admin + (let ([wb (box 0.0)] + [hb (box 0.0)] + [xb (box 0.0)] + [yb (box 0.0)]) + (send admin get-view #f #f wb hb) + (send src position-location (- pos 1) xb yb #t #f #t) + (let ([w (unbox wb)] + [h (unbox hb)] + [x (unbox xb)] + [y (unbox yb)]) + (send src scroll-editor-to + (max 0 (- x (* .1 w))) + (max 0 (- y (* .1 h))) + w h + #t + 'none))))) + + (send src set-position (- pos 1) (+ pos span -1)) + (send src end-edit-sequence)))))))))))) + ;; set-directory : text -> void ;; sets the current-directory and current-load-relative-directory @@ -1506,4 +1918,14 @@ If the namespace does not, they are colored the unbound color. (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-unit-frame unit-frame-mixin #f) - (drracket:get/extend:extend-tab tab-mixin))) + (drracket:get/extend:extend-tab tab-mixin) + + (drracket:module-language-tools:add-online-expansion-handler + compile-comp.rkt + 'go + (λ (defs-text val) (send (send (send defs-text get-canvas) get-top-level-window) + replay-compile-comp-trace + defs-text + val))))) + +(define-runtime-path compile-comp.rkt "online-comp.rkt") diff --git a/collects/drracket/private/syncheck/intf.rkt b/collects/drracket/private/syncheck/intf.rkt index 98fe5b527f..70c190e6e8 100644 --- a/collects/drracket/private/syncheck/intf.rkt +++ b/collects/drracket/private/syncheck/intf.rkt @@ -1,18 +1,24 @@ #lang racket/base (require racket/class racket/promise - setup/xref - scribble/xref) + setup/xref) (define-local-member-name syncheck:init-arrows syncheck:clear-arrows syncheck:arrows-visible? - syncheck:add-menu + + syncheck:find-source-object + syncheck:add-background-color + syncheck:add-docs-menu + syncheck:color-range + syncheck:add-require-open-menu + syncheck:add-rename-menu syncheck:add-arrow syncheck:add-tail-arrow syncheck:add-mouse-over-status syncheck:add-jump-to-definition + syncheck:sort-bindings-table syncheck:jump-to-next-bound-occurrence syncheck:jump-to-binding-occurrence @@ -37,16 +43,24 @@ get-syncheck-mode update-menu-status) -(define syncheck-text<%> +(define syncheck-annotations<%> (interface () - syncheck:init-arrows - syncheck:clear-arrows - syncheck:arrows-visible? - syncheck:add-menu + syncheck:find-source-object + syncheck:add-background-color + syncheck:add-require-open-menu + syncheck:add-docs-menu + syncheck:add-rename-menu syncheck:add-arrow syncheck:add-tail-arrow syncheck:add-mouse-over-status syncheck:add-jump-to-definition + syncheck:color-range)) + +(define syncheck-text<%> + (interface (syncheck-annotations<%>) + syncheck:init-arrows + syncheck:clear-arrows + syncheck:arrows-visible? syncheck:sort-bindings-table syncheck:get-bindings-table syncheck:jump-to-next-bound-occurrence @@ -56,7 +70,7 @@ ;; use this to communicate the frame being ;; syntax checked w/out having to add new ;; parameters to all of the functions -(define currently-processing-definitions-text (make-parameter #f)) +(define current-annotations (make-parameter #f)) (define xref (if (getenv "PLTDRXREFDELAY") (begin @@ -69,19 +83,41 @@ (delay/idle (load-collections-xref)))) (define (get-xref) (force xref)) +(define annotations-mixin + (mixin () (syncheck-annotations<%>) + (define/public (syncheck:find-source-object stx) #f) + (define/public (syncheck:add-background-color source start end color) (void)) + (define/public (syncheck:add-require-open-menu source color start end key) (void)) + (define/public (syncheck:add-rename-menu text start-pos end-pos key id-as-sym id-sets rename-ht get-ids) (void)) + (define/public (syncheck:add-docs-menu text start-pos end-pos key the-label path tag) (void)) + (define/public (syncheck:add-arrow start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right + actual? level) + (void)) + (define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) (void)) + (define/public (syncheck:add-mouse-over-status text pos-left pos-right str) (void)) + (define/public (syncheck:add-jump-to-definition text start end id filename) (void)) + (define/public (syncheck:color-range source start finish style-name mode) (void)) + (super-new))) + (provide syncheck-text<%> - currently-processing-definitions-text + syncheck-annotations<%> + current-annotations + annotations-mixin get-xref ;; methods syncheck:init-arrows syncheck:clear-arrows syncheck:arrows-visible? - syncheck:add-menu syncheck:add-arrow syncheck:add-tail-arrow syncheck:add-mouse-over-status syncheck:add-jump-to-definition + syncheck:add-docs-menu + syncheck:add-require-open-menu + syncheck:add-rename-menu + syncheck:add-background-color syncheck:sort-bindings-table syncheck:jump-to-next-bound-occurrence syncheck:jump-to-binding-occurrence @@ -92,6 +128,8 @@ ;syncheck:error-report-visible? ;; test suite uses this one. ;syncheck:get-bindings-table ;; test suite uses this one. syncheck:clear-error-message + syncheck:color-range + syncheck:find-source-object hide-error-report get-error-report-text diff --git a/collects/drracket/private/syncheck/online-comp.rkt b/collects/drracket/private/syncheck/online-comp.rkt new file mode 100644 index 0000000000..a4733f5cc5 --- /dev/null +++ b/collects/drracket/private/syncheck/online-comp.rkt @@ -0,0 +1,63 @@ +#lang racket/base +(require racket/class + racket/place + "traversals.rkt" + "intf.rkt") +(provide go) + +(define obj% + (class (annotations-mixin object%) + (init-field src) + (define trace '()) + + (define-values (remote local) (place-channel)) + (define table (make-hash)) + (thread + (λ () + (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)) + (define id (list-ref id/name 0)) + (define name (list-ref id/name 1)) + (define res ((hash-ref table id) name)) + (place-channel-put local res))))) + + (define/override (syncheck:find-source-object stx) + (and (equal? src (syntax-source stx)) + src)) + (define-syntax-rule + (log name) + (define/override (name . args) + (set! trace (cons (cons 'name args) trace)))) + + ; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up + ; (log syncheck:add-mouse-over-status) ;; we don't log these as they require space in the window + (log syncheck:add-arrow) + (log syncheck:add-tail-arrow) + (log syncheck:add-background-color) + (log syncheck:add-require-open-menu) + (log syncheck:add-docs-menu) + (log syncheck:add-jump-to-definition) + (define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?) + (define id (hash-count table)) + (hash-set! table id dup-name?) + (set! trace (cons (list 'syncheck:add-rename-menu id-as-sym to-be-renamed/poss remote id) + trace))) + + (define/public (get-trace) (reverse trace)) + (super-new))) + +(void (get-xref)) ;; do this now so that it doesn't get killed during a call to 'go' + +(define (go expanded path the-source) + (define obj (new obj% [src the-source])) + (define-values (expanded-expression expansion-completed) + (make-traversal (current-namespace) + (if path + (let-values ([(base name dir) (split-path path)]) + base) + (current-directory)))) + (parameterize ([current-annotations obj]) + (expanded-expression expanded) + (expansion-completed)) + (send obj get-trace)) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index 88c2e08225..029859fbf8 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -6,30 +6,15 @@ "contract-traversal.rkt" string-constants racket/unit - racket/contract + racket/set racket/class racket/list - racket/pretty - drracket/tool - syntax/toplevel syntax/boundmap - mrlib/switchable-button - (prefix-in drracket:arrow: drracket/arrow) - (prefix-in fw: framework/framework) - mred - framework - setup/xref scribble/xref scribble/manual-struct - net/url - net/uri-codec - browser/external - (for-syntax racket/base) - "../../syncheck-drracket-button.rkt") + (for-syntax racket/base)) - -(provide make-traversal) - +(provide make-traversal) ; @@ -51,13 +36,13 @@ - ;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void) - ;; (namespace string[directory] -> void)) + ;; make-traversal : namespace string[directory] -> (values (syntax (union #f syntax) -> void) + ;; (-> void)) ;; returns a pair of functions that close over some state that ;; represents the top-level of a single program. The first value ;; is called once for each top-level expression and the second ;; value is called once, after all expansion is complete. - (define (make-traversal) + (define (make-traversal user-namespace user-directory) (let* ([tl-low-binders (make-id-set)] [tl-high-binders (make-id-set)] [tl-low-varrefs (make-id-set)] @@ -73,7 +58,7 @@ [tl-require-for-templates (make-hash)] [tl-require-for-labels (make-hash)] [expanded-expression - (λ (user-namespace user-directory sexp jump-to-id) + (λ (sexp [visit-id void]) (parameterize ([current-load-relative-directory user-directory]) (let ([is-module? (syntax-case sexp (module) [(module . rest) #t] @@ -95,7 +80,7 @@ [require-for-templates (make-hash)] [require-for-labels (make-hash)]) (annotate-basic sexp - user-namespace user-directory jump-to-id + user-namespace user-directory visit-id low-binders high-binders varrefs high-varrefs varsets high-varsets @@ -121,7 +106,7 @@ (annotate-contracts sexp low-binders binding-inits))] [else (annotate-basic sexp - user-namespace user-directory jump-to-id + user-namespace user-directory visit-id tl-low-binders tl-high-binders tl-low-varrefs tl-high-varrefs tl-low-varsets tl-high-varsets @@ -133,7 +118,7 @@ tl-require-for-templates tl-require-for-labels)]))))] [expansion-completed - (λ (user-namespace user-directory) + (λ () (parameterize ([current-load-relative-directory user-directory]) (annotate-variables user-namespace user-directory @@ -164,7 +149,7 @@ ;; hash-table[require-spec -> syntax] (three of them) ;; -> void (define (annotate-basic sexp - user-namespace user-directory jump-to-id + user-namespace user-directory visit-id low-binders high-binders low-varrefs high-varrefs low-varsets high-varsets @@ -174,16 +159,7 @@ requires require-for-syntaxes require-for-templates require-for-labels) (let ([tail-ht (make-hasheq)] - [maybe-jump - (λ (vars) - (when jump-to-id - (for-each (λ (id) - (let ([binding (identifier-binding id 0)]) - (when (pair? binding) - (let ([nominal-source-id (list-ref binding 3)]) - (when (eq? nominal-source-id jump-to-id) - (jump-to id)))))) - (syntax->list vars))))]) + [maybe-jump (λ (vars) (visit-id vars))]) (let level-loop ([sexp sexp] [high-level? #f]) @@ -491,10 +467,7 @@ require-for-templates require-for-labels) - (let ([rename-ht - ;; hash-table[(list source number number) -> (listof syntax)] - (make-hash)] - [unused-requires (make-hash)] + (let ([unused-requires (make-hash)] [unused-require-for-syntaxes (make-hash)] [unused-require-for-templates (make-hash)] [unused-require-for-labels (make-hash)] @@ -528,8 +501,7 @@ (λ (var varsets) (when (syntax-original? var) (color-variable var 0 varsets) - (document-variable var 0) - (record-renamable-var rename-ht var)))]) + (document-variable var 0)))]) (for-each (λ (vars) (for-each (λ (var) (handle-var-bind var high-varsets)) vars)) @@ -546,7 +518,6 @@ (when (syntax-original? var) (document-variable var index)) (connect-identifier var - rename-ht binders unused/phases requires/phases @@ -568,7 +539,6 @@ (lambda (var) ;; no color variable (connect-identifier var - rename-ht low-binders unused/phases requires/phases @@ -577,7 +547,6 @@ user-directory #f) (connect-identifier var - rename-ht high-binders unused/phases requires/phases @@ -586,7 +555,6 @@ user-directory #f) (connect-identifier var - rename-ht template-binders ;; dummy; always empty unused/phases requires/phases @@ -595,7 +563,6 @@ user-directory #f) (connect-identifier var - rename-ht label-binders ;; dummy; always empty unused/phases requires/phases @@ -610,7 +577,7 @@ (λ (vars) (for-each (λ (var) - (color/connect-top rename-ht user-namespace user-directory low-binders var)) + (color/connect-top user-namespace user-directory low-binders var)) vars)) (get-idss low-tops)) @@ -618,7 +585,7 @@ (λ (vars) (for-each (λ (var) - (color/connect-top rename-ht user-namespace user-directory high-binders var)) + (color/connect-top user-namespace user-directory high-binders var)) vars)) (get-idss high-tops)) @@ -627,22 +594,25 @@ (color-unused require-for-syntaxes unused-require-for-syntaxes) (color-unused requires unused-requires) - (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu k rename-ht id-sets))))) - - - ;; record-renamable-var : rename-ht syntax -> void - (define (record-renamable-var rename-ht stx) - (let ([key (list (syntax-source stx) (syntax-position stx) (syntax-span stx))]) - (hash-set! rename-ht - key - (cons stx (hash-ref rename-ht key '()))))) + (make-rename-menus id-sets))) ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void (define (color-unused requires unused) (hash-for-each unused (λ (k v) - (for-each (λ (stx) (color stx error-style-name 'default-mode)) + (for-each (λ (stx) + (define defs-text (current-annotations)) + (define source-editor (find-source-editor stx)) + (when (and defs-text source-editor) + (define pos (syntax-position stx)) + (define span (syntax-span stx)) + (when (and pos span) + (define start (- pos 1)) + (define fin (+ start span)) + (send defs-text syncheck:add-background-color + source-editor start fin "firebrick"))) + (color stx unused-require-style-name 'default-mode)) (hash-ref requires k))))) ;; connect-identifier : syntax @@ -656,14 +626,12 @@ ;; boolean ;; -> void ;; adds arrows and rename menus for binders/bindings - (define (connect-identifier var rename-ht all-binders + (define (connect-identifier var all-binders unused/phases requires/phases phase-level user-namespace user-directory actual?) (connect-identifier/arrow var all-binders unused/phases requires/phases - phase-level user-namespace user-directory actual?) - (when (and actual? (get-ids all-binders var)) - (record-renamable-var rename-ht var))) + phase-level user-namespace user-directory actual?)) ;; id-level : integer-or-#f-or-'lexical identifier -> symbol (define (id-level phase-level id) @@ -723,7 +691,7 @@ source-id filename)))) (add-mouse-over var - (fw:gui-utils:format-literal-label + (format (string-constant cs-mouse-over-import) (syntax-e var) req-path)) @@ -775,7 +743,7 @@ [else #f])))) ;; color/connect-top : namespace directory id-set syntax -> void - (define (color/connect-top rename-ht user-namespace user-directory binders var) + (define (color/connect-top user-namespace user-directory binders var) (let ([top-bound? (or (get-ids binders var) (parameterize ([current-namespace user-namespace]) @@ -784,8 +752,8 @@ #t)))]) (if top-bound? (color var lexically-bound-variable-style-name 'default-mode) - (color var error-style-name 'default-mode)) - (connect-identifier var rename-ht binders #f #f 0 user-namespace user-directory #t))) + (color var free-variable-style-name 'default-mode)) + (connect-identifier var binders #f #f 0 user-namespace user-directory #t))) ;; color-variable : syntax phase-level module-identifier-mapping -> void (define (color-variable var phase-level varsets) @@ -818,7 +786,7 @@ (define (connect-syntaxes from to actual? level) (let ([from-source (find-source-editor from)] [to-source (find-source-editor to)] - [defs-text (get-defs-text)]) + [defs-text (current-annotations)]) (when (and from-source to-source defs-text) (let ([pos-from (syntax-position from)] [span-from (syntax-span from)] @@ -840,7 +808,7 @@ ;; this area shows up in the status line. (define (add-mouse-over stx str) (let* ([source (find-source-editor stx)] - [defs-text (get-defs-text)]) + [defs-text (current-annotations)]) (when (and defs-text source (syntax-position stx) @@ -856,7 +824,7 @@ ;; to the definition of the id. (define (add-jump-to-definition stx id filename) (let ([source (find-source-editor stx)] - [defs-text (get-defs-text)]) + [defs-text (current-annotations)]) (when (and source defs-text (syntax-position stx) @@ -870,19 +838,6 @@ id filename))))) - ;; find-syncheck-text : text% -> (union #f (is-a?/c syncheck-text<%>)) - (define (find-syncheck-text text) - (let loop ([text text]) - (cond - [(is-a? text syncheck-text<%>) text] - [else - (let ([admin (send text get-admin)]) - (and (is-a? admin editor-snip-editor-admin<%>) - (let* ([enclosing-editor-snip (send admin get-snip)] - [editor-snip-admin (send enclosing-editor-snip get-admin)] - [enclosing-editor (send editor-snip-admin get-editor)]) - (loop enclosing-editor))))]))) - ;; annotate-tail-position/last : (listof syntax) -> void (define (annotate-tail-position/last orig-stx stxs tail-ht) (unless (null? stxs) @@ -909,10 +864,10 @@ (λ (require-spec) (when (syntax-original? require-spec) (let ([source (find-source-editor require-spec)]) - (when (and (is-a? source text%) + (when (and source (syntax-position require-spec) (syntax-span require-spec)) - (let ([defs-text (get-defs-text)]) + (let ([defs-text (current-annotations)]) (when defs-text (let* ([start (- (syntax-position require-spec) 1)] [end (+ start (syntax-span require-spec))] @@ -920,11 +875,8 @@ user-namespace user-directory)]) (when file - (send defs-text syncheck:add-menu - source - start end - #f - (make-require-open-menu file))))))))))) + (send defs-text syncheck:add-require-open-menu + source start end file)))))))))) ;; get-require-filename : sexp-or-module-path-index namespace string[directory] -> filename or #f ;; finds the filename corresponding to the require in stx @@ -955,16 +907,6 @@ (k rkt-path/f)) ss-path)))))) - ;; make-require-open-menu : path -> menu -> void - (define (make-require-open-menu file) - (λ (menu) - (let-values ([(base name dir?) (split-path file)]) - (instantiate menu-item% () - (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)))) - ;; possible-suffixes : (listof string) ;; these are the suffixes that are checked for the reverse ;; module-path mapping. @@ -1106,40 +1048,6 @@ [(box? stx-e) (loop (unbox stx-e) (unbox datum))] [else (void)]))]))))) - - ;; jump-to : syntax -> void - (define (jump-to stx) - (let ([src (find-source-editor stx)] - [pos (syntax-position stx)] - [span (syntax-span stx)]) - (when (and (is-a? src text%) - pos - span) - (send src begin-edit-sequence) - - ;; try to scroll so stx's location is - ;; near the top of the visible region - (let ([admin (send src get-admin)]) - (when admin - (let ([wb (box 0.0)] - [hb (box 0.0)] - [xb (box 0.0)] - [yb (box 0.0)]) - (send admin get-view #f #f wb hb) - (send src position-location (- pos 1) xb yb #t #f #t) - (let ([w (unbox wb)] - [h (unbox hb)] - [x (unbox xb)] - [y (unbox yb)]) - (send src scroll-editor-to - (max 0 (- x (* .1 w))) - (max 0 (- y (* .1 h))) - w h - #t - 'none))))) - - (send src set-position (- pos 1) (+ pos span -1)) - (send src end-edit-sequence)))) ;; hash-table[syntax -o> (listof syntax)] -> void (define (add-tail-ht-links tail-ht) @@ -1189,7 +1097,7 @@ (define (add-tail-ht-link from-stx to-stx) (let* ([to-src (find-source-editor to-stx)] [from-src (find-source-editor from-stx)] - [defs-text (get-defs-text)]) + [defs-text (current-annotations)]) (when (and to-src from-src defs-text) (let ([from-pos (syntax-position from-stx)] [to-pos (syntax-position to-stx)]) @@ -1202,7 +1110,7 @@ (define (add-tail-link? from-stx to-stx) (let* ([to-src (find-source-editor to-stx)] [from-src (find-source-editor from-stx)] - [defs-text (get-defs-text)]) + [defs-text (current-annotations)]) (and to-src from-src defs-text (let ([from-pos (syntax-position from-stx)] [to-pos (syntax-position to-stx)]) @@ -1230,7 +1138,7 @@ ;; document-variable : stx[identifier,original] phase-level -> void (define (document-variable stx phase-level) - (let ([defs-text (currently-processing-definitions-text)]) + (let ([defs-text (current-annotations)]) (when defs-text (let ([binding-info (identifier-binding stx phase-level)]) (when (and (pair? binding-info) @@ -1238,50 +1146,36 @@ (syntax-span stx)) (let* ([start (- (syntax-position stx) 1)] [fin (+ start (syntax-span stx))] - [source-editor (find-source-editor stx)] - [xref (get-xref)]) - (when (and xref source-editor) - (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)]) - (when definition-tag - (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) - (when path - (let ([index-entry (xref-tag->index-entry xref definition-tag)]) - (when index-entry - (send defs-text syncheck:add-background-color - source-editor "navajowhite" start fin (syntax-e stx)) - (send defs-text syncheck:add-menu - source-editor - start - fin - (syntax-e stx) - (λ (menu) - (instantiate menu-item% () - (parent menu) - (label (build-docs-label (entry-desc index-entry))) - (callback - (λ (x y) - (let* ([url (path->url path)] - [url2 (if tag - (make-url (url-scheme url) - (url-user url) - (url-host url) - (url-port url) - (url-path-absolute? url) - (url-path url) - (url-query url) - tag) - url)]) - (send-url (url->string url2))))))))))))))))))))) + [source-editor (find-source-editor stx)]) + (when source-editor + (let ([xref (get-xref)]) + (when xref + (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)]) + (when definition-tag + (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) + (when path + (let ([index-entry (xref-tag->index-entry xref definition-tag)]) + (when index-entry + (send defs-text syncheck:add-background-color + source-editor start fin "navajowhite") + (send defs-text syncheck:add-docs-menu + source-editor + start + fin + (syntax-e stx) + (build-docs-label (entry-desc index-entry)) + path + tag)))))))))))))))) (define (build-docs-label desc) (let ([libs (exported-index-desc-from-libs desc)]) (cond [(null? libs) - (fw:gui-utils:format-literal-label + (format (string-constant cs-view-docs) (exported-index-desc-name desc))] [else - (fw:gui-utils:format-literal-label + (format (string-constant cs-view-docs-from) (format (string-constant cs-view-docs) @@ -1310,141 +1204,44 @@ ; ;;; - ;; make-rename-menu : (list source number number) rename-ht (listof id-set) -> void - (define (make-rename-menu key rename-ht id-sets) - (let* ([source (list-ref key 0)] - [pos (list-ref key 1)] - [span (list-ref key 2)] - [defs-text (currently-processing-definitions-text)] - [example-id - ;; we know that there is at least one there b/c that's how make-rename-menu is called - (car (hash-ref rename-ht key))] - [id-as-sym (syntax-e example-id)]) - + ;; make-rename-menus : (listof id-set) -> void + (define (make-rename-menus id-sets) + (define id-to-sets (make-module-identifier-mapping)) + (let ([defs-text (current-annotations)]) (when defs-text - (let ([source-editor (find-source-editor example-id)]) - (when (is-a? source-editor text%) - (let* ([start (- pos 1)] - [fin (+ start span)]) - (send defs-text syncheck:add-menu - source-editor - start - fin - id-as-sym - (λ (menu) - (let ([name-to-offer (format "~a" id-as-sym)]) - (instantiate menu-item% () - (parent menu) - (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)]) - (rename-callback name-to-offer - defs-text - key - id-sets - rename-ht - frame-parent)))))))))))))) - - ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) - (define (find-menu-parent menu) - (let loop ([menu menu]) - (cond - [(is-a? menu menu-bar%) (send menu get-frame)] - [(is-a? menu popup-menu%) - (let ([target (send menu get-popup-target)]) - (cond - [(is-a? target editor<%>) - (let ([canvas (send target get-canvas)]) - (and canvas - (send canvas get-top-level-window)))] - [(is-a? target window<%>) - (send target get-top-level-window)] - [else #f]))] - [(is-a? menu menu-item<%>) (loop (send menu get-parent))] - [else #f]))) - - ;; rename-callback : string - ;; (and/c syncheck-text<%> definitions-text<%>) - ;; (list source number number) - ;; (listof id-set) - ;; rename-ht - ;; (union #f (is-a?/c top-level-window<%>)) - ;; -> void - ;; callback for the rename popup menu item - (define (rename-callback name-to-offer defs-text key id-sets rename-ht parent) - (let ([new-str - (fw:keymap:call/text-keymap-initializer - (λ () - (get-text-from-user - (string-constant cs-rename-id) - (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) - parent - name-to-offer)))]) - (when new-str - (define new-sym (format "~s" (string->symbol new-str))) - (define src-locs (make-hash)) - (define all-stxs (make-hash)) - (let loop ([key key]) - (unless (hash-ref src-locs key #f) - (hash-set! src-locs key #t) - (for ([stx (in-list (hash-ref rename-ht key))]) - (for ([id-set (in-list id-sets)]) - (for ([stx (in-list (or (get-ids id-set stx) '()))]) - (hash-set! all-stxs stx #t) - (loop (list (syntax-source stx) - (syntax-position stx) - (syntax-span stx)))))))) - (define to-be-renamed (hash-map all-stxs (λ (k v) k))) - (define do-renaming? - (or (not (name-duplication? to-be-renamed id-sets new-sym)) - (equal? - (message-box/custom - (string-constant check-syntax) - (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) - new-sym) - (string-constant cs-rename-anyway) - (string-constant cancel) - #f - parent - '(stop default=2)) - 1))) - (when do-renaming? - (unless (null? to-be-renamed) - (let ([txts (list defs-text)]) - (define positions-to-rename - (remove-duplicates - (sort (map (λ (stx) (list (find-source-editor/defs stx defs-text) - (syntax-position stx) - (syntax-span stx))) - to-be-renamed) - > - #:key cadr))) - (send defs-text begin-edit-sequence) - (for ([info (in-list positions-to-rename)]) - (define source-editor (list-ref info 0)) - (define position (list-ref info 1)) - (define span (list-ref info 2)) - (when (is-a? source-editor text%) - (unless (memq source-editor txts) - (send source-editor begin-edit-sequence) - (set! txts (cons source-editor txts))) - (let* ([start (- position 1)] - [end (+ start span)]) - (send source-editor delete start end #f) - (send source-editor insert new-sym start start #f)))) - (send defs-text invalidate-bitmap-cache) - (for ([txt (in-list txts)]) - (send txt end-edit-sequence)))))))) - - ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean - ;; returns #t if the name chosen would be the same as another name in this scope. - (define (name-duplication? to-be-renamed id-sets new-str) - (let ([new-ids (map (λ (id) (datum->syntax id (string->symbol new-str))) - to-be-renamed)]) - (for*/or ([id-set (in-list id-sets)] - [new-id (in-list new-ids)]) - (get-ids id-set new-id)))) + (for ([id-set (in-list id-sets)]) + (for-each-ids + id-set + (λ (vars) + (for ([var (in-list vars)]) + (define ed (find-source-editor var)) + (when ed + (define pos (syntax-position var)) + (define span (syntax-span var)) + (define start (- pos 1)) + (define fin (+ start span)) + (define loc (list ed start fin)) + (module-identifier-mapping-put! + id-to-sets + var + (set-add (module-identifier-mapping-get id-to-sets var set) + loc))))))) + (module-identifier-mapping-for-each + id-to-sets + (λ (id locs) + (define (name-dup? new-str) + (and (for/or ([id-set (in-list id-sets)]) + (for/or ([id (in-list (or (get-ids id-set id) '()))]) + (let ([new-id (datum->syntax id (string->symbol new-str))]) + (for/or ([id-set (in-list id-sets)]) + (get-ids id-set new-id))))) + #t)) + (define loc-lst (set->list locs)) + (define id-as-sym (syntax-e id)) + (send defs-text syncheck:add-rename-menu + id-as-sym + loc-lst + name-dup?)))))) ;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original]) ;; removes duplicates, based on the source locations of the identifiers @@ -1507,3 +1304,6 @@ (define (for-each-ids mapping f) (module-identifier-mapping-for-each mapping (λ (x y) (f y)))) + + + \ No newline at end of file diff --git a/collects/drracket/private/tools-drs.rkt b/collects/drracket/private/tools-drs.rkt index 9169c31384..af38db671c 100644 --- a/collects/drracket/private/tools-drs.rkt +++ b/collects/drracket/private/tools-drs.rkt @@ -36,7 +36,8 @@ This file sets up the right lexical environment to invoke the tools that want to [prefix drscheme:modes: drracket:modes^] [prefix drscheme:tracing: drracket:tracing^] [prefix drscheme:module-language: drracket:module-language^] - [prefix drscheme:module-language-tools: drracket:module-language-tools^]) + [prefix drscheme:module-language-tools: drracket:module-language-tools^] + [prefix drscheme: drracket:interface^]) (export drracket:tools-drs^) (define-syntax (wrap-tool-inputs stx) diff --git a/collects/drracket/private/tools.rkt b/collects/drracket/private/tools.rkt index 38124c60c4..2abde7253e 100644 --- a/collects/drracket/private/tools.rkt +++ b/collects/drracket/private/tools.rkt @@ -30,7 +30,8 @@ [prefix drracket:tracing: drracket:tracing^] [prefix drracket:module-language: drracket:module-language^] [prefix drracket:module-language-tools: drracket:module-language-tools^] - [prefix drracket:tools-drs: drracket:tools-drs^]) + [prefix drracket:tools-drs: drracket:tools-drs^] + [prefix drracket: drracket:interface^]) (export drracket:tools^) ;; An installed-tool is @@ -451,6 +452,7 @@ ;; run-phases : -> void (define (run-phases phase1-extras phase2-extras) + (drracket:module-language-tools:no-more-online-expansion-handlers) (let* ([after-phase1 (run-one-phase 'phase1 (string-constant tool-error-phase1) successfully-loaded-tool-phase1 diff --git a/collects/drracket/private/tracing.rkt b/collects/drracket/private/tracing.rkt index 77064a6317..0e27e4f2a5 100644 --- a/collects/drracket/private/tracing.rkt +++ b/collects/drracket/private/tracing.rkt @@ -18,7 +18,8 @@ (import [prefix drracket:frame: drracket:frame^] [prefix drracket:rep: drracket:rep^] [prefix drracket:init: drracket:init^] - [prefix drracket:unit: drracket:unit^]) + [prefix drracket:unit: drracket:unit^] + [prefix drracket: drracket:interface^]) (export drracket:tracing^) (define-local-member-name diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index ef9ff03eda..2248ff574e 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -12,517 +12,484 @@ module browser threading seems wrong. |# - (require racket/contract - racket/unit - racket/class - racket/path - racket/port - racket/list - string-constants - framework - mrlib/name-message - mrlib/bitmap-label - mrlib/include-bitmap - mrlib/switchable-button - mrlib/cache-image-snip - (prefix-in image-core: mrlib/image-core) - mrlib/include-bitmap - mrlib/close-icon - net/sendurl - net/url - - "drsig.rkt" - "auto-language.rkt" - "insert-large-letters.rkt" - "get-defs.rkt" - (prefix-in drracket:arrow: "../arrow.rkt") - - mred - (prefix-in mred: mred) - - mzlib/date) - - (provide unit@) - - (define module-browser-progress-constant (string-constant module-browser-progress)) - (define status-compiling-definitions (string-constant module-browser-compiling-defns)) - (define show-lib-paths (string-constant module-browser-show-lib-paths/short)) - (define show-planet-paths (string-constant module-browser-show-planet-paths/short)) - (define refresh (string-constant module-browser-refresh)) +(require racket/contract + racket/unit + racket/class + racket/path + racket/port + racket/list + string-constants + framework + mrlib/name-message + mrlib/bitmap-label + mrlib/include-bitmap + mrlib/switchable-button + mrlib/cache-image-snip + (prefix-in image-core: mrlib/image-core) + mrlib/include-bitmap + mrlib/close-icon + net/sendurl + net/url + + "drsig.rkt" + "auto-language.rkt" + "insert-large-letters.rkt" + "get-defs.rkt" + "local-member-names.rkt" + (prefix-in drracket:arrow: "../arrow.rkt") + + mred + (prefix-in mred: mred) + + mzlib/date) - (define define-button-long-label "(define ...)") +(provide unit@) + +(define module-browser-progress-constant (string-constant module-browser-progress)) +(define status-compiling-definitions (string-constant module-browser-compiling-defns)) +(define show-lib-paths (string-constant module-browser-show-lib-paths/short)) +(define show-planet-paths (string-constant module-browser-show-planet-paths/short)) +(define refresh (string-constant module-browser-refresh)) + +(define define-button-long-label "(define ...)") + +(define oprintf + (let ([op (current-output-port)]) + (λ args + (apply fprintf op args)))) + +;; code copied from framework/private/frame.rkt +(define checkout-or-nightly? + (or (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) + (directory-exists? (collection-path "repo-time-stamp"))) + (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) + (let ([fw (collection-path "framework")]) + (directory-exists? (build-path fw 'up 'up ".git")))))) + +(define-unit unit@ + (import [prefix help-desk: drracket:help-desk^] + [prefix drracket:app: drracket:app^] + [prefix drracket:frame: drracket:frame^] + [prefix drracket:text: drracket:text^] + [prefix drracket:rep: drracket:rep^] + [prefix drracket:language-configuration: drracket:language-configuration/internal^] + [prefix drracket:language: drracket:language^] + [prefix drracket:get/extend: drracket:get/extend^] + [prefix drracket:module-overview: drracket:module-overview^] + [prefix drracket:tools: drracket:tools^] + [prefix drracket:init: drracket:init^] + [prefix drracket:module-language: drracket:module-language/int^] + [prefix drracket:module-language-tools: drracket:module-language-tools^] + [prefix drracket:modes: drracket:modes^] + [prefix drracket:debug: drracket:debug^] + [prefix drracket: drracket:interface^]) + (export (rename drracket:unit^ [-frame% frame%])) + (init-depend drracket:module-language/int^) + + (define-struct teachpack-callbacks + (get-names ;; settings -> (listof string) + add ;; settings path -> settings + remove ;; string[returned from teachpack-names] settings -> settings + remove-all ;; settings -> settings + )) - (define oprintf - (let ([op (current-output-port)]) - (λ args - (apply fprintf op args)))) + ;; get rid of set-user-teachpack-cache method - ;; code copied from framework/private/frame.rkt - (define checkout-or-nightly? - (or (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) - (directory-exists? (collection-path "repo-time-stamp"))) - (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) - (let ([fw (collection-path "framework")]) - (directory-exists? (build-path fw 'up 'up ".git")))))) + (keymap:add-to-right-button-menu + (let ([old (keymap:add-to-right-button-menu)]) + (λ (menu text event) + (old menu text event) + (when (and (is-a? text text%) + (or (is-a? text (get-definitions-text%)) + (is-a? text drracket:rep:text%)) + (is-a? event mouse-event%)) + + (let ([add-sep + (let ([added? #f]) + (λ () + (unless added? + (set! added? #t) + (new separator-menu-item% [parent menu]))))]) + + (add-search-help-desk-menu-item text menu + (let-values ([(x y) + (send text dc-location-to-editor-location + (send event get-x) + (send event get-y))]) + (send text find-position x y)) + add-sep) + + (when (is-a? text editor:basic<%>) + (let-values ([(pos text) (send text get-pos/text event)]) + (when (and pos (is-a? text text%)) + (send text split-snip pos) + (send text split-snip (+ pos 1)) + (let ([snip (send text find-snip pos 'after-or-none)]) + (when (or (is-a? snip image-snip%) + (is-a? snip image-core:image%) + (is-a? snip cache-image-snip%)) + (add-sep) + (new menu-item% + [parent menu] + [label (string-constant save-image)] + [callback + (λ (_1 _2) + (let ([fn (put-file #f + (send text get-top-level-window) + #f "untitled.png" "png")]) + (when fn + (let ([kind (filename->kind fn)]) + (cond + [kind + (cond + [(or (is-a? snip image-snip%) + (is-a? snip cache-image-snip%)) + (send (send snip get-bitmap) save-file fn kind)] + [else + (image-core:save-image-as-bitmap snip fn kind)])] + [else + (message-box + (string-constant drscheme) + "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm")])))))])))))) + + (void)))))) - (define-unit unit@ - (import [prefix help-desk: drracket:help-desk^] - [prefix drracket:app: drracket:app^] - [prefix drracket:frame: drracket:frame^] - [prefix drracket:text: drracket:text^] - [prefix drracket:rep: drracket:rep^] - [prefix drracket:language-configuration: drracket:language-configuration/internal^] - [prefix drracket:language: drracket:language^] - [prefix drracket:get/extend: drracket:get/extend^] - [prefix drracket:module-overview: drracket:module-overview^] - [prefix drracket:tools: drracket:tools^] - [prefix drracket:init: drracket:init^] - [prefix drracket:module-language: drracket:module-language^] - [prefix drracket:module-language-tools: drracket:module-language-tools^] - [prefix drracket:modes: drracket:modes^] - [prefix drracket:debug: drracket:debug^]) - (export (rename drracket:unit^ - [-frame% frame%] - [-frame<%> frame<%>])) - - (define-local-member-name - get-visible-defs - set-visible-defs - set-focus-d/i - get-i - set-i - insert-auto-text) - (define tab<%> - (interface (drracket:rep:context<%>) - get-frame - get-defs - get-ints - get-visible-defs - set-visible-defs - set-visible-ints - set-focus-d/i - get-i - set-i - break-callback - is-current-tab? - get-enabled - on-close - can-close? - toggle-log)) - - (define definitions-text<%> - (interface () - begin-metadata-changes - end-metadata-changes - get-tab - get-next-settings - after-set-next-settings - set-needs-execution-message)) - - (define-struct teachpack-callbacks - (get-names ;; settings -> (listof string) - add ;; settings path -> settings - remove ;; string[returned from teachpack-names] settings -> settings - remove-all ;; settings -> settings - )) - - ;; get rid of set-user-teachpack-cache method - - (keymap:add-to-right-button-menu - (let ([old (keymap:add-to-right-button-menu)]) - (λ (menu text event) - (old menu text event) - (when (and (is-a? text text%) - (or (is-a? text (get-definitions-text%)) - (is-a? text drracket:rep:text%)) - (is-a? event mouse-event%)) - - (let ([add-sep - (let ([added? #f]) - (λ () - (unless added? - (set! added? #t) - (new separator-menu-item% [parent menu]))))]) - - (add-search-help-desk-menu-item text menu - (let-values ([(x y) - (send text dc-location-to-editor-location - (send event get-x) - (send event get-y))]) - (send text find-position x y)) - add-sep) - - (when (is-a? text editor:basic<%>) - (let-values ([(pos text) (send text get-pos/text event)]) - (when (and pos (is-a? text text%)) - (send text split-snip pos) - (send text split-snip (+ pos 1)) - (let ([snip (send text find-snip pos 'after-or-none)]) - (when (or (is-a? snip image-snip%) - (is-a? snip image-core:image%) - (is-a? snip cache-image-snip%)) - (add-sep) - (new menu-item% - [parent menu] - [label (string-constant save-image)] - [callback - (λ (_1 _2) - (let ([fn (put-file #f - (send text get-top-level-window) - #f "untitled.png" "png")]) - (when fn - (let ([kind (filename->kind fn)]) - (cond - [kind - (cond - [(or (is-a? snip image-snip%) - (is-a? snip cache-image-snip%)) - (send (send snip get-bitmap) save-file fn kind)] - [else - (image-core:save-image-as-bitmap snip fn kind)])] - [else - (message-box - (string-constant drscheme) - "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm")])))))])))))) - - (void)))))) - - (define (add-search-help-desk-menu-item text menu position [add-sep void]) - (let* ([end (send text get-end-position)] - [start (send text get-start-position)]) - (unless (= 0 (send text last-position)) - (let* ([str (if (= end start) - (find-symbol text position) - (send text get-text start end))] - ;; almost the same code as "search-help-desk" in "rep.rkt" - [l (send text get-canvas)] - [l (and l (send l get-top-level-window))] - [l (and l (is-a? l -frame<%>) (send l get-definitions-text))] - [l (and l (send l get-next-settings))] - [l (and l (drracket:language-configuration:language-settings-language l))] - [ctxt (and l (send l capability-value 'drscheme:help-context-term))] - [name (and l (send l get-language-name))]) - (unless (string=? str "") - (add-sep) - (let ([short-str (shorten-str str 50)]) - (make-object menu-item% - (gui-utils:format-literal-label - (string-constant search-help-desk-for) - (if (equal? short-str str) - str - (string-append short-str "..."))) - menu - (λ x (help-desk:help-desk str (list ctxt name)))) - (void))))))) - - (define (filename->kind fn) - (let ([ext (filename-extension fn)]) - (and ext - (let ([sym (string->symbol (bytes->string/utf-8 ext))]) - (ormap (λ (pr) (and (eq? sym (car pr)) (cadr pr))) - allowed-extensions))))) - - (define allowed-extensions '((png png) - (jpg jpeg) - (xbm xbm) - (xpm xpm))) - - - - ;; find-symbol : number -> string - ;; finds the symbol around the position `pos' (approx) - (define (find-symbol text pos) - (cond - [(is-a? text scheme:text<%>) - (let* ([before (send text get-backward-sexp pos)] - [before+ (and before (send text get-forward-sexp before))] - [after (send text get-forward-sexp pos)] - [after- (and after (send text get-backward-sexp after))]) - - (define (get-tokens start end) - (let loop ([i start]) - (cond - [(and (< i end) - (< i (send text last-position))) - (define-values (tstart tend) (send text get-token-range i)) - (cons (list (send text classify-position i) tstart tend) - (loop tend))] - [else '()]))) - - ;; find-searchable-tokens : number number -> (or/c #f (list symbol number number)) - (define (find-searchable-tokens start end) - (define tokens (get-tokens start end)) - (define raw-tokens (map (λ (x) (list-ref x 0)) tokens)) + (define (add-search-help-desk-menu-item text menu position [add-sep void]) + (let* ([end (send text get-end-position)] + [start (send text get-start-position)]) + (unless (= 0 (send text last-position)) + (let* ([str (if (= end start) + (find-symbol text position) + (send text get-text start end))] + ;; almost the same code as "search-help-desk" in "rep.rkt" + [l (send text get-canvas)] + [l (and l (send l get-top-level-window))] + [l (and l (is-a? l drracket:unit:frame<%>) (send l get-definitions-text))] + [l (and l (send l get-next-settings))] + [l (and l (drracket:language-configuration:language-settings-language l))] + [ctxt (and l (send l capability-value 'drscheme:help-context-term))] + [name (and l (send l get-language-name))]) + (unless (string=? str "") + (add-sep) + (let ([short-str (shorten-str str 50)]) + (make-object menu-item% + (gui-utils:format-literal-label + (string-constant search-help-desk-for) + (if (equal? short-str str) + str + (string-append short-str "..."))) + menu + (λ x (help-desk:help-desk str (list ctxt name)))) + (void))))))) + + (define (filename->kind fn) + (let ([ext (filename-extension fn)]) + (and ext + (let ([sym (string->symbol (bytes->string/utf-8 ext))]) + (ormap (λ (pr) (and (eq? sym (car pr)) (cadr pr))) + allowed-extensions))))) + + (define allowed-extensions '((png png) + (jpg jpeg) + (xbm xbm) + (xpm xpm))) + + + + ;; find-symbol : number -> string + ;; finds the symbol around the position `pos' (approx) + (define (find-symbol text pos) + (cond + [(is-a? text scheme:text<%>) + (let* ([before (send text get-backward-sexp pos)] + [before+ (and before (send text get-forward-sexp before))] + [after (send text get-forward-sexp pos)] + [after- (and after (send text get-backward-sexp after))]) + + (define (get-tokens start end) + (let loop ([i start]) (cond - [(equal? raw-tokens '(symbol)) - (car tokens)] - [(equal? raw-tokens '(constant symbol)) - (cadr tokens)] - [else #f])) - - (define searchable-token - (or (and before before+ - (<= before pos before+) - (find-searchable-tokens before before+)) - (and after after- - (<= after- pos after) - (find-searchable-tokens after- after)))) - (if searchable-token + [(and (< i end) + (< i (send text last-position))) + (define-values (tstart tend) (send text get-token-range i)) + (cons (list (send text classify-position i) tstart tend) + (loop tend))] + [else '()]))) + + ;; find-searchable-tokens : number number -> (or/c #f (list symbol number number)) + (define (find-searchable-tokens start end) + (define tokens (get-tokens start end)) + (define raw-tokens (map (λ (x) (list-ref x 0)) tokens)) + (cond + [(equal? raw-tokens '(symbol)) + (car tokens)] + [(equal? raw-tokens '(constant symbol)) + (cadr tokens)] + [else #f])) + + (define searchable-token + (or (and before before+ + (<= before pos before+) + (find-searchable-tokens before before+)) + (and after after- + (<= after- pos after) + (find-searchable-tokens after- after)))) + (if searchable-token (send text get-text (list-ref searchable-token 1) (list-ref searchable-token 2)) ""))] + [else + (send text split-snip pos) + (send text split-snip (+ pos 1)) + (let ([snip (send text find-snip pos 'after)]) + (if (is-a? snip string-snip%) + (let* ([before + (let loop ([i (- pos 1)] + [chars null]) + (if (< i 0) + chars + (let ([char (send text get-character i)]) + (if (non-letter? char) + chars + (loop (- i 1) + (cons char chars))))))] + [after + (let loop ([i pos]) + (if (< i (send text last-position)) + (let ([char (send text get-character i)]) + (if (non-letter? char) + null + (cons char (loop (+ i 1))))) + null))]) + (apply string (append before after))) + ""))])) + + ;; non-letter? : char -> boolean + ;; returns #t if the character belongs in a symbol (approx) and #f it is + ;; a divider between symbols (approx) + (define (non-letter? x) + (or (char-whitespace? x) + (memq x '(#\` #\' #\, #\; #\" + #\{ #\( #\[ #\] #\) #\})))) + (define (shorten-str str len) + (if ((string-length str) . <= . len) + str + (substring str 0 len))) + + + ; + ; + ; + ; ;;; ; ; ; ; + ; ; ; ; + ; ; ; ; ; + ; ;;;; ; ; ;;; ;;; ;;;; ; ;;; ; ;; ;; ; ; ;;; ; ;;; ;; ; + ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; + ; ; ; ;;;;; ;;; ;; ; ;;; ; ; ;; ; ; ;;;;; ; ;;; ;; ; + ; ; + ; ; ; + ; ;;;; + + (define (get-fraction-from-user parent) + (let* ([dlg (make-object dialog% (string-constant enter-fraction))] + [hp (make-object horizontal-panel% dlg)] + [_1 (make-object message% (string-constant whole-part) hp)] + [whole (make-object text-field% #f hp void)] + [vp (make-object vertical-panel% hp)] + [hp2 (make-object horizontal-panel% vp)] + [num (make-object text-field% #f hp2 void)] + [num-m (make-object message% (string-constant numerator) hp2)] + [hp3 (make-object horizontal-panel% vp)] + [den (make-object text-field% #f hp3 void)] + [den-m (make-object message% (string-constant denominator) hp3)] + [bp (make-object horizontal-panel% dlg)] + [ok? #f] + [validate-number + (λ () + (let ([num-s (string->number (send num get-value))] + [den-s (string->number (send den get-value))] + [whole-s (if (string=? (send whole get-value) "") + 0 + (string->number (send whole get-value)))]) + (cond + [(or (not whole-s) (not (integer? whole-s))) + (string-constant insert-number/bad-whole-part)] + [(or (not num-s) (not (integer? num-s)) (< num-s 0)) + (string-constant insert-number/bad-numerator)] + [(or (not den-s) (not (integer? den-s)) (<= den-s 0)) + (string-constant insert-number/bad-denominator)] + [else + (if (< whole-s 0) + (- whole-s (/ num-s den-s)) + (+ whole-s (/ num-s den-s)))])))] + [ok-callback + (λ () + (let ([v (validate-number)]) + (cond + [(number? v) + (set! ok? #t) + (send dlg show #f)] + [else + (message-box + (string-constant drscheme) + v + dlg)])))] + [cancel-callback + (λ () (send dlg show #f))]) + (let-values ([(ok cancel) + (gui-utils:ok/cancel-buttons + bp + (λ (x y) (ok-callback)) + (λ (x y) (cancel-callback)))]) + (let ([mw (max (send den-m get-width) (send num-m get-width))]) + (send den-m min-width mw) + (send num-m min-width mw)) + (send bp set-alignment 'right 'center) + (send dlg show #t) + (and ok? + (let ([v (validate-number)]) + (and (number? v) + v)))))) + + ;; create-executable : (instanceof drracket:unit:frame<%>) -> void + (define (create-executable frame) + (let* ([definitions-text (send frame get-definitions-text)] + [program-filename (send definitions-text get-filename)]) + (cond + [(not program-filename) + (message-box (string-constant create-executable-title) + (string-constant must-save-before-executable) + frame)] [else - (send text split-snip pos) - (send text split-snip (+ pos 1)) - (let ([snip (send text find-snip pos 'after)]) - (if (is-a? snip string-snip%) - (let* ([before - (let loop ([i (- pos 1)] - [chars null]) - (if (< i 0) - chars - (let ([char (send text get-character i)]) - (if (non-letter? char) - chars - (loop (- i 1) - (cons char chars))))))] - [after - (let loop ([i pos]) - (if (< i (send text last-position)) - (let ([char (send text get-character i)]) - (if (non-letter? char) - null - (cons char (loop (+ i 1))))) - null))]) - (apply string (append before after))) - ""))])) - - ;; non-letter? : char -> boolean - ;; returns #t if the character belongs in a symbol (approx) and #f it is - ;; a divider between symbols (approx) - (define (non-letter? x) - (or (char-whitespace? x) - (memq x '(#\` #\' #\, #\; #\" - #\{ #\( #\[ #\] #\) #\})))) - (define (shorten-str str len) - (if ((string-length str) . <= . len) - str - (substring str 0 len))) - - - ; - ; - ; - ; ;;; ; ; ; ; - ; ; ; ; - ; ; ; ; ; - ; ;;;; ; ; ;;; ;;; ;;;; ; ;;; ; ;; ;; ; ; ;;; ; ;;; ;; ; - ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; - ; ; ; ;;;;; ;;; ;; ; ;;; ; ; ;; ; ; ;;;;; ; ;;; ;; ; - ; ; - ; ; ; - ; ;;;; - - (define (get-fraction-from-user parent) - (let* ([dlg (make-object dialog% (string-constant enter-fraction))] - [hp (make-object horizontal-panel% dlg)] - [_1 (make-object message% (string-constant whole-part) hp)] - [whole (make-object text-field% #f hp void)] - [vp (make-object vertical-panel% hp)] - [hp2 (make-object horizontal-panel% vp)] - [num (make-object text-field% #f hp2 void)] - [num-m (make-object message% (string-constant numerator) hp2)] - [hp3 (make-object horizontal-panel% vp)] - [den (make-object text-field% #f hp3 void)] - [den-m (make-object message% (string-constant denominator) hp3)] - [bp (make-object horizontal-panel% dlg)] - [ok? #f] - [validate-number - (λ () - (let ([num-s (string->number (send num get-value))] - [den-s (string->number (send den get-value))] - [whole-s (if (string=? (send whole get-value) "") - 0 - (string->number (send whole get-value)))]) - (cond - [(or (not whole-s) (not (integer? whole-s))) - (string-constant insert-number/bad-whole-part)] - [(or (not num-s) (not (integer? num-s)) (< num-s 0)) - (string-constant insert-number/bad-numerator)] - [(or (not den-s) (not (integer? den-s)) (<= den-s 0)) - (string-constant insert-number/bad-denominator)] - [else - (if (< whole-s 0) - (- whole-s (/ num-s den-s)) - (+ whole-s (/ num-s den-s)))])))] - [ok-callback - (λ () - (let ([v (validate-number)]) - (cond - [(number? v) - (set! ok? #t) - (send dlg show #f)] - [else - (message-box - (string-constant drscheme) - v - dlg)])))] - [cancel-callback - (λ () (send dlg show #f))]) - (let-values ([(ok cancel) - (gui-utils:ok/cancel-buttons - bp - (λ (x y) (ok-callback)) - (λ (x y) (cancel-callback)))]) - (let ([mw (max (send den-m get-width) (send num-m get-width))]) - (send den-m min-width mw) - (send num-m min-width mw)) - (send bp set-alignment 'right 'center) - (send dlg show #t) - (and ok? - (let ([v (validate-number)]) - (and (number? v) - v)))))) - - ;; create-executable : (instanceof drracket:unit:frame<%>) -> void - (define (create-executable frame) - (let* ([definitions-text (send frame get-definitions-text)] - [program-filename (send definitions-text get-filename)]) - (cond - [(not program-filename) - (message-box (string-constant create-executable-title) - (string-constant must-save-before-executable) - frame)] - [else - (when (or (not (send definitions-text is-modified?)) - (gui-utils:get-choice - (string-constant definitions-not-saved) - (string-constant yes) - (string-constant no) - (string-constant drscheme) - #f - frame)) - (let ([settings (send definitions-text get-next-settings)]) - (send (drracket:language-configuration:language-settings-language settings) - create-executable - (drracket:language-configuration:language-settings-settings settings) - frame - program-filename)))]))) - - (define execute-bitmap (make-object bitmap% (collection-file-path "run.png" "icons") 'png/mask)) - (define break-bitmap (make-object bitmap% (collection-file-path "break.png" "icons") 'png/mask)) - (define save-bitmap (make-object bitmap% (collection-file-path "save.png" "icons") 'png/mask)) - - (define-values (get-program-editor-mixin add-to-program-editor-mixin) - (let* ([program-editor-mixin - (mixin (editor:basic<%> (class->interface text%)) () - (init-rest args) - (inherit get-top-level-window) - - (define/private (reset-highlighting) - (let ([f (get-top-level-window)]) - (when (and f - (is-a? f -frame<%>)) - (let ([interactions-text (send f get-interactions-text)]) - (when (object? interactions-text) - (send interactions-text reset-highlighting)))))) - - (define/augment (after-insert x y) - (reset-highlighting) - (inner (void) after-insert x y)) - - (define/augment (after-delete x y) - (reset-highlighting) - (inner (void) after-delete x y)) - - (apply super-make-object args))] - [get-program-editor-mixin - (λ () - (drracket:tools:only-in-phase 'drracket:unit:get-program-editor-mixin 'phase2 'init-complete) - program-editor-mixin)] - [add-to-program-editor-mixin - (λ (mixin) - (drracket:tools:only-in-phase 'drracket:unit:add-to-program-editor-mixin 'phase1) - (let ([old program-editor-mixin]) - (set! program-editor-mixin (λ (x) (mixin (old x))))))]) - (values get-program-editor-mixin - add-to-program-editor-mixin))) - - ;; this sends a message to its frame when it gets the focus - (define make-searchable-canvas% - (λ (%) - (class % - (inherit get-top-level-window) - (define/override (on-focus on?) - (when on? - (send (get-top-level-window) make-searchable this)) - (super on-focus on?)) - (super-new)))) - - (define interactions-canvas% - (class (make-searchable-canvas% + (when (or (not (send definitions-text is-modified?)) + (gui-utils:get-choice + (string-constant definitions-not-saved) + (string-constant yes) + (string-constant no) + (string-constant drscheme) + #f + frame)) + (let ([settings (send definitions-text get-next-settings)]) + (send (drracket:language-configuration:language-settings-language settings) + create-executable + (drracket:language-configuration:language-settings-settings settings) + frame + program-filename)))]))) + + (define execute-bitmap (make-object bitmap% (collection-file-path "run.png" "icons") 'png/mask)) + (define break-bitmap (make-object bitmap% (collection-file-path "break.png" "icons") 'png/mask)) + (define save-bitmap (make-object bitmap% (collection-file-path "save.png" "icons") 'png/mask)) + + (define-values (get-program-editor-mixin add-to-program-editor-mixin) + (let* ([program-editor-mixin + (mixin (editor:basic<%> (class->interface text%)) () + (init-rest args) + (inherit get-top-level-window) + + (define/private (reset-highlighting) + (let ([f (get-top-level-window)]) + (when (and f + (is-a? f drracket:unit:frame<%>)) + (let ([interactions-text (send f get-interactions-text)]) + (when (object? interactions-text) + (send interactions-text reset-highlighting)))))) + + (define/augment (after-insert x y) + (reset-highlighting) + (inner (void) after-insert x y)) + + (define/augment (after-delete x y) + (reset-highlighting) + (inner (void) after-delete x y)) + + (apply super-make-object args))] + [get-program-editor-mixin + (λ () + (drracket:tools:only-in-phase 'drracket:unit:get-program-editor-mixin 'phase2 'init-complete) + program-editor-mixin)] + [add-to-program-editor-mixin + (λ (mixin) + (drracket:tools:only-in-phase 'drracket:unit:add-to-program-editor-mixin 'phase1) + (let ([old program-editor-mixin]) + (set! program-editor-mixin (λ (x) (mixin (old x))))))]) + (values get-program-editor-mixin + add-to-program-editor-mixin))) + + ;; this sends a message to its frame when it gets the focus + (define make-searchable-canvas% + (λ (%) + (class % + (inherit get-top-level-window) + (define/override (on-focus on?) + (when on? + (send (get-top-level-window) make-searchable this)) + (super on-focus on?)) + (super-new)))) + + (define interactions-canvas% + (class (make-searchable-canvas% + (canvas:info-mixin + (canvas:wide-snip-mixin (canvas:info-mixin - (canvas:wide-snip-mixin - (canvas:info-mixin - canvas:color%)))) - (init [style '()]) - (super-new (style (cons 'auto-hscroll style))))) - - - (define definitions-canvas% - (class (make-searchable-canvas% (canvas:delegate-mixin (canvas:info-mixin canvas:color%))) - (init [style '()]) - (super-new (style (cons 'auto-hscroll style))))) - - ; - ; - ; - ; ; ;;; ; ; - ; ; ; ; - ; ; ; ; ; ; - ; ;; ; ;;; ;;;;;;; ; ;; ; ;;;; ; ;;; ; ;; ;;; ;;;; ;;; ; ; ;;;; - ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; - ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;;;;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;; ; ;;;; ; ; ; ; ; ;; ; ;;; ; ; ;;; ;; ;;;; ; ; ;; - ; - ; - ; - - - (define get-definitions-text% - (let ([definitions-text% #f]) - (λ () - (drracket:tools:only-in-phase 'phase2 'init-complete) - (unless definitions-text% - (set! definitions-text% (make-definitions-text%))) - definitions-text%))) - - (define (show-line-numbers?) - (preferences:get 'drracket:show-line-numbers?)) - - (define (make-definitions-text%) - (let ([definitions-super% - (text:line-numbers-mixin - (text:first-line-mixin - (drracket:module-language:module-language-put-file-mixin - (scheme:text-mixin - (color:text-mixin - (drracket:rep:drs-bindings-keymap-mixin - (mode:host-text-mixin - (text:delegate-mixin - (text:foreground-color-mixin - (drracket:rep:drs-autocomplete-mixin - (λ (x) x) - (text:normalize-paste-mixin - text:info%)))))))))))]) - ((get-program-editor-mixin) - (class* definitions-super% (definitions-text<%>) + canvas:color%)))) + (init [style '()]) + (super-new (style (cons 'auto-hscroll style))))) + + + (define definitions-canvas% + (class (make-searchable-canvas% (canvas:delegate-mixin (canvas:info-mixin canvas:color%))) + (init [style '()]) + (super-new (style (cons 'auto-hscroll style))))) + + ; + ; + ; + ; ; ;;; ; ; + ; ; ; ; + ; ; ; ; ; ; + ; ;; ; ;;; ;;;;;;; ; ;; ; ;;;; ; ;;; ; ;; ;;; ;;;; ;;; ; ; ;;;; + ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; + ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;;;;; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ;;;; ; ; ; ; ; ;; ; ;;; ; ; ;;; ;; ;;;; ; ; ;; + ; + ; + ; + + + (define get-definitions-text% + (let ([definitions-text% #f]) + (λ () + (drracket:tools:only-in-phase 'phase2 'init-complete) + (unless definitions-text% + (set! definitions-text% (make-definitions-text%))) + definitions-text%))) + + (define (show-line-numbers?) + (preferences:get 'drracket:show-line-numbers?)) + + (define (make-definitions-text%) + (let ([definitions-super% + (text:line-numbers-mixin + (text:first-line-mixin + (drracket:module-language:module-language-put-file-mixin + (scheme:text-mixin + (color:text-mixin + (drracket:rep:drs-bindings-keymap-mixin + (mode:host-text-mixin + (text:delegate-mixin + (text:foreground-color-mixin + (drracket:rep:drs-autocomplete-mixin + (λ (x) x) + (text:normalize-paste-mixin + text:info%)))))))))))]) + ((get-program-editor-mixin) + (class* definitions-super% (drracket:unit:definitions-text<%>) (inherit get-top-level-window is-locked? lock while-unlocked highlight-first-line is-printing?) @@ -581,7 +548,9 @@ module browser threading seems wrong. (let* ([lang (drracket:language-configuration:language-settings-language next-settings)] [settings (drracket:language-configuration:language-settings-settings next-settings)] [name-mod (send lang get-reader-module)]) - (when name-mod ;; the reader-module method's result is used a test of whether or not the get-metadata method is used for this language + (when name-mod + ;; the reader-module method's result is used a test of whether or + ;; not the get-metadata method is used for this language (let ([metadata (send lang get-metadata (filename->modname filename) settings)]) (begin-edit-sequence #f) (begin-metadata-changes) @@ -650,7 +619,7 @@ module browser threading seems wrong. (inner (void) on-lexer-valid valid?) (let ([f (get-top-level-window)]) (when (and f - (is-a? f -frame<%>)) + (is-a? f drracket:unit:frame<%>)) (send f set-color-status! valid?)))) (define/override (get-can-close-parent) @@ -663,7 +632,7 @@ module browser threading seems wrong. (λ () (let ([f (get-top-level-window)]) (when (and f - (is-a? f -frame<%>)) + (is-a? f drracket:unit:frame<%>)) (send f update-save-button)))))) (define/override set-filename (case-lambda @@ -672,7 +641,7 @@ module browser threading seems wrong. (super set-filename fn tmp?) (let ([f (get-top-level-window)]) (when (and f - (is-a? f -frame<%>)) + (is-a? f drracket:unit:frame<%>)) (send f update-save-message)))])) (field @@ -703,7 +672,7 @@ module browser threading seems wrong. (change-mode-to-match) (let ([f (get-top-level-window)]) (when (and f - (is-a? f -frame<%>)) + (is-a? f drracket:unit:frame<%>)) (send f language-changed))) (highlight-first-line @@ -757,7 +726,7 @@ module browser threading seems wrong. already-warned-state) (define/pubment (already-warned) (set! already-warned-state #t)) - + ;; the really-modified? flag determines if there ;; is a modification that is not the insertion of the auto-text (define really-modified? #f) @@ -765,7 +734,7 @@ module browser threading seems wrong. ;; when this flag is #t, edits to the buffer do not count as ;; user's edits and so the yellow warning does not appear (define ignore-edits? #f) - + (define/augment (after-insert x y) (unless ignore-edits? (set! really-modified? #t) @@ -792,7 +761,7 @@ module browser threading seems wrong. (define/override (on-paint before dc left top right bottom dx dy draw-caret) (super on-paint before dc left top right bottom dx dy draw-caret) - + ;; [Disabled] For printing, put date and filename in the top margin: (when (and #f before (is-printing?)) (let ([h (box 0)] @@ -840,7 +809,7 @@ module browser threading seems wrong. [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) (values (/ (+ xl xr) 2) (/ (+ yl yr) 2))))) - + (define/public (still-untouched?) (and (or (= (last-position) 0) (not really-modified?)) (not (is-modified?)) @@ -889,258 +858,3777 @@ module browser threading seems wrong. drracket:module-language:module-language<%>)) (inherit set-max-undo-history) (set-max-undo-history 'forever))))) - - ;; is-lang-line? : string -> boolean - ;; given the first line in the editor, this returns #t if it is a #lang line. - (define (is-lang-line? l) - (let ([m (regexp-match #rx"^#(!|(lang ))([-+_/a-zA-Z0-9]+)(.|$)" l)]) - (and m - (let ([lang-name (list-ref m 3)] - [last-char (list-ref m 4)]) - (and (not (char=? #\/ (string-ref lang-name 0))) - (not (char=? #\/ (string-ref lang-name (- (string-length lang-name) 1)))) - (or (string=? "" last-char) - (char-whitespace? (string-ref last-char 0)))))))) - - ;; test cases for is-lang-line? - #; - (printf "~s\n" - (list (is-lang-line? "#lang x") - (is-lang-line? "#lang racket") - (is-lang-line? "#lang racket ") - (not (is-lang-line? "#lang racketα")) - (not (is-lang-line? "#lang racket/ ")) - (not (is-lang-line? "#lang /racket ")) - (is-lang-line? "#lang rac/ket ") - (is-lang-line? "#lang r6rs") - (is-lang-line? "#!r6rs") - (is-lang-line? "#!r6rs ") - (not (is-lang-line? "#!/bin/sh")))) - - (define (get-module-language/settings) - (let* ([module-language - (and (preferences:get 'drracket:switch-to-module-language-automatically?) - (ormap - (λ (lang) - (and (is-a? lang drracket:module-language:module-language<%>) - lang)) - (drracket:language-configuration:get-languages)))] - [module-language-settings - (let ([prefs-setting (preferences:get - drracket:language-configuration:settings-preferences-symbol)]) + + ;; is-lang-line? : string -> boolean + ;; given the first line in the editor, this returns #t if it is a #lang line. + (define (is-lang-line? l) + (let ([m (regexp-match #rx"^#(!|(lang ))([-+_/a-zA-Z0-9]+)(.|$)" l)]) + (and m + (let ([lang-name (list-ref m 3)] + [last-char (list-ref m 4)]) + (and (not (char=? #\/ (string-ref lang-name 0))) + (not (char=? #\/ (string-ref lang-name (- (string-length lang-name) 1)))) + (or (string=? "" last-char) + (char-whitespace? (string-ref last-char 0)))))))) + + ;; test cases for is-lang-line? + #; + (printf "~s\n" + (list (is-lang-line? "#lang x") + (is-lang-line? "#lang racket") + (is-lang-line? "#lang racket ") + (not (is-lang-line? "#lang racketα")) + (not (is-lang-line? "#lang racket/ ")) + (not (is-lang-line? "#lang /racket ")) + (is-lang-line? "#lang rac/ket ") + (is-lang-line? "#lang r6rs") + (is-lang-line? "#!r6rs") + (is-lang-line? "#!r6rs ") + (not (is-lang-line? "#!/bin/sh")))) + + (define (get-module-language/settings) + (let* ([module-language + (and (preferences:get 'drracket:switch-to-module-language-automatically?) + (ormap + (λ (lang) + (and (is-a? lang drracket:module-language:module-language<%>) + lang)) + (drracket:language-configuration:get-languages)))] + [module-language-settings + (let ([prefs-setting (preferences:get + drracket:language-configuration:settings-preferences-symbol)]) + (cond + [(eq? (drracket:language-configuration:language-settings-language prefs-setting) + module-language) + (drracket:language-configuration:language-settings-settings prefs-setting)] + [else + (and module-language + (send module-language default-settings))]))]) + (values module-language module-language-settings))) + + + + + ; + ; + ; + ; + ; ;;; ;;;;;;; + ; ;;; ;;; + ; ;; ;;; ;;;; ;;;;; ;;; ;;; ;; ;;;; + ; ;;;;;;; ;; ;;;;;;;; ;;; ;;;;;;; ;; ;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;;;;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;;;;;; ;;;;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;;; + ; ;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; + ; + ; + ; + ; + + ;; get-pos : text mouse-event% -> (union #f number) + (define (get-pos text event) + (let*-values ([(event-x event-y) + (values (send event get-x) + (send event get-y))] + [(x y) (send text dc-location-to-editor-location + event-x + event-y)]) + (let* ([on-it? (box #f)] + [pos (send text find-position x y #f on-it?)]) + (and (unbox on-it?) + pos)))) + + (let ([old (keymap:add-to-right-button-menu)]) + (keymap:add-to-right-button-menu + (λ (menu editor event) + (when (is-a? editor text%) + (let* ([canvas (send editor get-canvas)] + [frame (and canvas (send canvas get-top-level-window))]) + (when (is-a? frame drracket:unit:frame<%>) + (let* ([language-settings (send (send frame get-definitions-text) get-next-settings)] + [new-language (drracket:language-configuration:language-settings-language language-settings)] + [capability-info (send new-language capability-value 'drscheme:define-popup)]) + (when capability-info + (let* ([current-pos (get-pos editor event)] + [current-word (and current-pos (get-current-word editor current-pos))] + [defn (and current-word + (ormap (λ (defn) (and (string=? current-word (defn-name defn)) + defn)) + (get-definitions (car capability-info) + #f + editor)))]) + (when defn + (new separator-menu-item% (parent menu)) + (new menu-item% + (parent menu) + (label (gui-utils:format-literal-label (string-constant jump-to-defn) (defn-name defn))) + (callback (λ (x y) + (send editor set-position (defn-start-pos defn)))))))))))) + (old menu editor event)))) + + ;; get-current-word : editor number -> string + ;; returns the string that is being clicked on + (define (get-current-word editor pos) + (let* ([search + (λ (dir offset) + (let loop ([pos pos]) (cond - [(eq? (drracket:language-configuration:language-settings-language prefs-setting) - module-language) - (drracket:language-configuration:language-settings-settings prefs-setting)] - [else - (and module-language - (send module-language default-settings))]))]) - (values module-language module-language-settings))) - - - - -; -; -; -; -; ;;; ;;;;;;; -; ;;; ;;; -; ;; ;;; ;;;; ;;;;; ;;; ;;; ;; ;;;; -; ;;;;;;; ;; ;;;;;;;; ;;; ;;;;;;; ;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;;;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;;;;;; ;;;;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;;; -; ;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; -; -; -; -; - - ;; get-pos : text mouse-event% -> (union #f number) - (define (get-pos text event) - (let*-values ([(event-x event-y) - (values (send event get-x) - (send event get-y))] - [(x y) (send text dc-location-to-editor-location - event-x - event-y)]) - (let* ([on-it? (box #f)] - [pos (send text find-position x y #f on-it?)]) - (and (unbox on-it?) - pos)))) - - (let ([old (keymap:add-to-right-button-menu)]) - (keymap:add-to-right-button-menu - (λ (menu editor event) - (when (is-a? editor text%) - (let* ([canvas (send editor get-canvas)] - [frame (and canvas (send canvas get-top-level-window))]) - (when (is-a? frame -frame<%>) - (let* ([language-settings (send (send frame get-definitions-text) get-next-settings)] - [new-language (drracket:language-configuration:language-settings-language language-settings)] - [capability-info (send new-language capability-value 'drscheme:define-popup)]) - (when capability-info - (let* ([current-pos (get-pos editor event)] - [current-word (and current-pos (get-current-word editor current-pos))] - [defn (and current-word - (ormap (λ (defn) (and (string=? current-word (defn-name defn)) - defn)) - (get-definitions (car capability-info) - #f - editor)))]) - (when defn - (new separator-menu-item% (parent menu)) - (new menu-item% - (parent menu) - (label (gui-utils:format-literal-label (string-constant jump-to-defn) (defn-name defn))) - (callback (λ (x y) - (send editor set-position (defn-start-pos defn)))))))))))) - (old menu editor event)))) - - ;; get-current-word : editor number -> string - ;; returns the string that is being clicked on - (define (get-current-word editor pos) - (let* ([search - (λ (dir offset) - (let loop ([pos pos]) - (cond - [(or (= pos 0) - (= pos (send editor last-position))) - pos] - [(memq (send editor get-character pos) '(#\space #\return #\newline #\( #\) #\[ #\] #\tab)) - (offset pos)] - [else (loop (dir pos))])))] - [before (search sub1 add1)] - [after (search add1 (λ (x) x))]) - (send editor get-text before after))) - - (define func-defs-canvas% - (class name-message% - (init-field frame) + [(or (= pos 0) + (= pos (send editor last-position))) + pos] + [(memq (send editor get-character pos) '(#\space #\return #\newline #\( #\) #\[ #\] #\tab)) + (offset pos)] + [else (loop (dir pos))])))] + [before (search sub1 add1)] + [after (search add1 (λ (x) x))]) + (send editor get-text before after))) + + (define func-defs-canvas% + (class name-message% + (init-field frame) + + (unless (is-a? frame drracket:unit:frame<%>) + (error 'func-defs-canvas "frame is not a drracket:unit:frame<%>")) + + (define sort-by-name? (preferences:get 'drracket:defns-popup-sort-by-name?)) + (define sorting-name (if sort-by-name? + (string-constant sort-by-position) + (string-constant sort-by-name))) + (define/private (change-sorting-order) + (set! sort-by-name? (not sort-by-name?)) + (preferences:set 'drracket:defns-popup-sort-by-name? sort-by-name?) + (set! sorting-name (if sort-by-name? + (string-constant sort-by-position) + (string-constant sort-by-name)))) + + (define define-popup-capability-info + (drracket:language:get-capability-default 'drscheme:define-popup)) + + (inherit set-message set-hidden?) + (define/public (language-changed new-language vertical?) + (set! define-popup-capability-info (send new-language capability-value 'drscheme:define-popup)) + (let ([define-name (get-define-popup-name define-popup-capability-info + vertical?)]) + (cond + [define-name + (set-message #f define-name) + (set-hidden? #f)] + [else + (set-hidden? #t)]))) + (define/override (fill-popup menu reset) + (when define-popup-capability-info + (let* ([text (send frame get-definitions-text)] + [unsorted-defns (get-definitions (car define-popup-capability-info) + (not sort-by-name?) + text)] + [defns (if sort-by-name? + (sort + unsorted-defns + (λ (x y) (string-ci<=? (defn-name x) (defn-name y)))) + unsorted-defns)]) + (make-object menu:can-restore-menu-item% sorting-name + menu + (λ (x y) + (change-sorting-order))) + (make-object separator-menu-item% menu) + (if (null? defns) + (send (make-object menu:can-restore-menu-item% + (string-constant no-definitions-found) + menu + void) + enable #f) + (let loop ([defns defns]) + (unless (null? defns) + (let* ([defn (car defns)] + [checked? + (let ([t-start (send text get-start-position)] + [t-end (send text get-end-position)] + [d-start (defn-start-pos defn)] + [d-end (defn-end-pos defn)]) + (or (<= t-start d-start t-end) + (<= t-start d-end t-end) + (<= d-start t-start t-end d-end)))] + [item + (make-object (if checked? + menu:can-restore-checkable-menu-item% + menu:can-restore-menu-item%) + (gui-utils:quote-literal-label (defn-name defn)) + + menu + (λ (x y) + (reset) + (send text set-position (defn-start-pos defn) (defn-start-pos defn)) + (let ([canvas (send text get-canvas)]) + (when canvas + (send canvas focus)))))]) + (when checked? + (send item check #t)) + (loop (cdr defns))))))))) + + (super-new (label "(define ...)") ;; this default is quickly changed + [string-constant-untitled (string-constant untitled)] + [string-constant-no-full-name-since-not-saved + (string-constant no-full-name-since-not-saved)]))) + + (define (set-box/f! b v) (when (box? b) (set-box! b v))) + + ; + ; + ; + ; + ; ;;;; + ; ;;; + ; ;;;; ;;; ;;;;;;; ;;; ;; ;;; ;;;; + ; ;;;; ;;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; + ; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; + ; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;; + ; + ; + ; + ; + + (define dragable/def-int-mixin + (mixin (panel:dragable<%>) () + (init-field unit-frame) + (inherit get-percentages) + (define/augment (after-percentage-change) + (let ([percentages (get-percentages)]) + (when (and (= 1 + (length (send unit-frame get-definitions-canvases)) + (length (send unit-frame get-interactions-canvases))) + (= 2 (length percentages))) + (preferences:set 'drracket:unit-window-size-percentage (car percentages)))) + (inner (void) after-percentage-change)) + (super-new))) + + (define vertical-dragable/def-int% (dragable/def-int-mixin panel:vertical-dragable%)) + (define horizontal-dragable/def-int% (dragable/def-int-mixin panel:horizontal-dragable%)) + + (define tab% + (class* object% (drracket:rep:context<%> drracket:unit:tab<%>) + (init-field frame + defs + i + defs-shown? + ints-shown?) + (define enabled? #t) + (field [ints #f] + [visible-defs #f] + [visible-ints #f] + [focus-d/i 'defs]) + + ;; only called to initialize this tab. + ;; the interactions editor should be invariant. + (define/public (set-ints i) (set! ints i)) + + (define/public-final (get-frame) frame) + (define/public-final (get-defs) defs) + (define/public-final (get-ints) ints) + (define/public-final (get-visible-defs) (values visible-defs defs-shown?)) + (define/public-final (set-visible-defs vd ds?) + (set! visible-defs vd) + (set! defs-shown? ds?)) + (define/public-final (get-visible-ints) (values visible-ints ints-shown?)) + (define/public-final (set-visible-ints vi is?) + (set! visible-ints vi) + (set! ints-shown? is?)) + (define/public-final (set-focus-d/i di) + (set! focus-d/i di)) + (define/public-final (get-focus-d/i) focus-d/i) + (define/public-final (get-i) i) + (define/public-final (set-i _i) (set! i _i)) + (define/public (disable-evaluation) + (set! enabled? #f) + (send defs lock #t) + (send ints lock #t) + (send frame disable-evaluation-in-tab this)) + (define/public (enable-evaluation) + (set! enabled? #t) + (send defs lock #f) + (send ints lock #f) + (send frame enable-evaluation-in-tab this)) + (define/public (get-enabled) enabled?) + + ;; current-execute-warning is a snapshot of the needs-execution-message + ;; that is taken each time repl submission happens, and it gets reset + ;; when "Run" is clicked. + (define current-execute-warning #f) + (define/pubment (repl-submit-happened) + (set! current-execute-warning (send defs get-needs-execution-message)) + (update-execute-warning-gui)) + (define/public (get-current-execute-warning) current-execute-warning) + (define/public (clear-execution-state) + (set! current-execute-warning #f) + (update-execute-warning-gui) + (send defs already-warned)) + (define/public (update-execute-warning-gui) + (when (is-current-tab?) + (send frame show/hide-warning-message + (get-current-execute-warning) + (λ () + ;; this callback might be run with a different tab ... + (send (send frame get-current-tab) clear-execution-state))))) + + (define/public (get-directory) + (let ([filename (send defs get-filename)]) + (if (and (path? filename) + (file-exists? filename)) + (let-values ([(base _1 _2) (split-path (normalize-path filename))]) + base) + #f))) + + (define/pubment (can-close?) + (and (send defs can-close?) + (send ints can-close?) + (inner #t can-close?))) + (define/pubment (on-close) + (send defs on-close) + (send ints on-close) + (inner (void) on-close)) + + ;; this should really do something local to the tab, but + ;; for now it doesn't. + (define/public (ensure-rep-shown rep) + (send frame ensure-rep-shown rep)) + + (field [thread-to-break-box (make-weak-box #f)] + [custodian-to-kill-box (make-weak-box #f)] + [offer-kill? #f]) + + ;; break-callback : -> void + (define/public (break-callback) + (let ([thread-to-break (weak-box-value thread-to-break-box)] + [custodian-to-kill (weak-box-value custodian-to-kill-box)]) + (cond + [(or (not thread-to-break) + (not custodian-to-kill)) + (bell)] + [offer-kill? + (if (user-wants-kill?) + (when thread-to-break + (break-thread thread-to-break)) + (when custodian-to-kill + (custodian-shutdown-all custodian-to-kill)))] + [else + (when thread-to-break + (break-thread thread-to-break)) + ;; only offer a kill the next time if + ;; something got broken. + (set! offer-kill? #t)]))) + + ;; user-wants-kill? : -> boolean + ;; handles events, so be sure to check state + ;; after calling to avoid race conditions. + (define/private (user-wants-kill?) + (gui-utils:get-choice + (string-constant kill-evaluation?) + (string-constant just-break) + (string-constant kill) + (string-constant kill?) + 'diallow-close + frame)) + + ;; reset-offer-kill + (define/public (reset-offer-kill) + (set! offer-kill? #f)) + + ;; get-breakables : -> (union #f thread) (union #f cust) -> void + (define/public (get-breakables) + (values (weak-box-value thread-to-break-box) (weak-box-value custodian-to-kill-box))) + + ;; set-breakables : (union #f thread) (union #f cust) -> void + (define/public (set-breakables thd cust) + (set! thread-to-break-box (make-weak-box thd)) + (set! custodian-to-kill-box (make-weak-box cust))) + + (define/pubment (clear-annotations) + (inner (void) clear-annotations) + (send ints reset-highlighting)) + + (define running? #f) + (define/public-final (is-running?) running?) + (define/public (update-running b?) + (set! running? b?) + (send frame update-running b?)) + + (define/public-final (is-current-tab?) (eq? this (send frame get-current-tab))) + + (define log-visible? #f) + (define/public-final (toggle-log) + (set! log-visible? (not log-visible?)) + (send frame show/hide-log log-visible?)) + (define/public-final (update-log) + (send frame show/hide-log log-visible?)) + (define/public-final (update-logger-window command) + (when (is-current-tab?) + (send frame update-logger-window command))) + + (define current-planet-status #f) + (define/public-final (new-planet-status a b) + (set! current-planet-status (cons a b)) + (update-planet-status)) + (define/public-final (clear-planet-status) + (set! current-planet-status #f) + (update-planet-status)) + (define/public-final (update-planet-status) + (send frame show-planet-status + (and current-planet-status + (car current-planet-status)) + (and current-planet-status + (cdr current-planet-status)))) + + (super-new))) + + ;; should only be called by the tab% object (and the class itself) + (define-local-member-name + disable-evaluation-in-tab + enable-evaluation-in-tab + update-toolbar-visibility + show/hide-log + show-planet-status) + + (define frame-mixin + (mixin (drracket:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>) + (drracket:unit:frame<%>) + (init filename) + (inherit set-label-prefix get-show-menu + get-menu% + get-area-container + update-info + get-file-menu + search-hidden? + unhide-search + hide-search + file-menu:get-close-item + file-menu:get-save-item + file-menu:get-save-as-item + file-menu:get-revert-item + file-menu:get-print-item) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; execute warning + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define execute-warning-panel #f) + (define execute-warning-parent-panel #f) + (define execute-warning-canvas #f) + (define/public-final (show/hide-warning-message msg hide-canvas) + (when (and execute-warning-parent-panel + execute-warning-panel) + (cond + [msg + (cond + [execute-warning-canvas + (send execute-warning-canvas set-message msg)] + [else + (set! execute-warning-canvas + (new execute-warning-canvas% + [stretchable-height #t] + [parent execute-warning-panel] + [message msg])) + (new close-icon% + [parent execute-warning-panel] + [bg-color "yellow"] + [callback (λ () (hide-canvas))])]) + (send execute-warning-parent-panel + change-children + (λ (l) (append (remq execute-warning-panel l) + (list execute-warning-panel))))] + [else + (when execute-warning-canvas + (send execute-warning-parent-panel + change-children + (λ (l) (remq execute-warning-panel l))) + (send execute-warning-canvas set-message #f))]))) + + + ;; bind the proc to a field + ;; so it stays alive as long + ;; as the frame stays alive + (define show-line-numbers-pref-fn + (let ([fn (lambda (pref value) (show-line-numbers! value))]) + (preferences:add-callback + 'drracket:show-line-numbers? + fn + #t) + fn)) + + (define/override (add-line-number-menu-items menu) + (define on? (preferences:get 'drracket:show-line-numbers?)) + (new separator-menu-item% [parent menu]) + (new checkable-menu-item% + [label (string-constant show-line-numbers-in-definitions)] + [parent menu] + [checked on?] + [callback + (λ (c dc) + (preferences:set 'drracket:show-line-numbers? (not on?)))]) + (super add-line-number-menu-items menu)) + + (define/private (show-line-numbers! show) + (for ([tab tabs]) + (define text (send tab get-defs)) + (send text show-line-numbers! show)) + (send definitions-canvas refresh)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; logging + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define logger-panel #f) + (define logger-parent-panel #f) + + ;; logger-gui-tab-panel: (or/c #f (is-a?/c tab-panel%)) + ;; this is #f when the GUI has not been built yet. After + ;; it becomes a tab-panel, it is always a tab-panel (altho the tab panel might not always be shown) + (define logger-gui-tab-panel #f) + (define logger-gui-canvas #f) + + ;; logger-gui-text: (or/c #f (is-a?/c tab-panel%)) + ;; this is #f when the GUI has not been built or when the logging panel is hidden + ;; in that case, the logging messages aren't begin saved in an editor anywhere + (define logger-gui-text #f) + + (define logger-menu-item #f) + + (define/public-final (show/hide-log show?) + (let ([p (preferences:get 'drracket:logging-size-percentage)]) + (begin-container-sequence) + (cond + [logger-gui-tab-panel + (send logger-parent-panel change-children + (λ (l) + (cond + [(or (and show? (member logger-panel l)) + (and (not show?) + (not (member logger-panel l)))) + ;; if things are already up to date, only update the logger text + (when show? + (update-logger-window #f)) + l] + [show? + (new-logger-text) + (send logger-gui-canvas set-editor logger-gui-text) + (update-logger-window #f) + (send logger-menu-item set-label (string-constant hide-log)) + (append (remq logger-panel l) (list logger-panel))] + [else + (send logger-menu-item set-label (string-constant show-log)) + (set! logger-gui-text #f) + (send logger-gui-canvas set-editor #f) + (remq logger-panel l)])))] + [else + (when show? ;; if we want to hide and it isn't built yet, do nothing + (set! logger-gui-tab-panel + (new tab-panel% + [choices (list (string-constant logging-all) + "fatal" "error" "warning" "info" "debug")] + [parent logger-panel] + [callback + (λ (tp evt) + (preferences:set 'drracket:logger-gui-tab-panel-level (send logger-gui-tab-panel get-selection)) + (update-logger-window #f))])) + (send logger-gui-tab-panel set-selection (preferences:get 'drracket:logger-gui-tab-panel-level)) + (new-logger-text) + (set! logger-gui-canvas + (new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text])) + (send logger-menu-item set-label (string-constant hide-log)) + (update-logger-window #f) + (send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))]) + (with-handlers ([exn:fail? void]) + (send logger-parent-panel set-percentages (list p (- 1 p)))) + (update-logger-button-label) + (end-container-sequence))) + + (define/private (log-shown?) + (and logger-gui-tab-panel + (member logger-panel (send logger-parent-panel get-children)))) + + (define/private (new-logger-text) + (set! logger-gui-text (new (text:hide-caret/selection-mixin text:basic%))) + (send logger-gui-text lock #t)) + + (define/public (update-logger-window command) + (when logger-gui-text + (let ([admin (send logger-gui-text get-admin)] + [canvas (send logger-gui-text get-canvas)]) + (when (and canvas admin) + (let ([logger-messages (send interactions-text get-logger-messages)] + [level (case (send logger-gui-tab-panel get-selection) + [(0) #f] + [(1) 'fatal] + [(2) 'error] + [(3) 'warning] + [(4) 'info] + [(5) 'debug])]) + (cond + [(and (pair? command) + (pair? logger-messages) + ;; just flush and redraw everything if there is one (or zero) logger messages + (pair? (cdr logger-messages))) + (let ([msg (cdr command)]) + (when (or (not level) + (eq? (vector-ref msg 0) level)) + (send logger-gui-text begin-edit-sequence) + (send logger-gui-text lock #f) + (case (car command) + [(add-line) (void)] + [(clear-last-and-add-line) + (send logger-gui-text delete + 0 + (send logger-gui-text paragraph-start-position 1))]) + (send logger-gui-text insert + "\n" + (send logger-gui-text last-position) + (send logger-gui-text last-position)) + (send logger-gui-text insert + (vector-ref msg 1) + (send logger-gui-text last-position) + (send logger-gui-text last-position)) + (send logger-gui-text end-edit-sequence) + (send logger-gui-text lock #t)))] + [else + (send logger-gui-text begin-edit-sequence) + (send logger-gui-text lock #f) + (send logger-gui-text erase) + + (let ([insert-one + (λ (x newline?) + (when (or (not level) + (eq? level (vector-ref x 0))) + (when newline? (send logger-gui-text insert "\n" 0 0)) + (send logger-gui-text insert (vector-ref x 1) 0 0)))]) + + (unless (null? logger-messages) + ;; skip the last newline in the buffer + (insert-one (car logger-messages) #f) + (for-each + (λ (x) (insert-one x #t)) + (cdr (send interactions-text get-logger-messages))))) + + (send logger-gui-text lock #t) + (send logger-gui-text end-edit-sequence)])))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; planet status + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define planet-status-parent-panel #f) + (define planet-status-panel #f) + (define planet-message #f) + (define planet-logger-button #f) + ;; local-member-name + (define/public (show-planet-status tag package) + (cond + [(and (not tag) + (not package) + (or (not planet-status-parent-panel) + (not (member planet-status-panel (send planet-status-parent-panel get-children))))) + ;; if there is no information and there is no GUI there, don't do anything + (void)] + [else + (when planet-status-panel + (unless planet-message + (new message% + [parent planet-status-panel] + [label drracket:debug:small-planet-bitmap]) + (set! planet-message (new message% [parent planet-status-panel] [label ""] [stretchable-width #t])) + (set! planet-logger-button + (new button% + [font small-control-font] + [parent planet-status-panel] + [label (string-constant show-log)] + [callback (λ (a b) (send current-tab toggle-log))])) + (update-logger-button-label) + (new close-icon% + [parent planet-status-panel] + [callback (λ () + (send planet-status-parent-panel change-children + (λ (l) + (remq planet-status-panel l))) + (send current-tab clear-planet-status))])) + (send planet-message set-label + (case tag + [(download) + (format (string-constant planet-downloading) package)] + [(install) + (format (string-constant planet-installing) package)] + [(docs-build) + (format (string-constant planet-docs-building) package)] + [(finish) + (format (string-constant planet-finished) package)] + [else + (string-constant planet-no-status)])) + (send planet-status-parent-panel change-children + (λ (l) + (if (memq planet-status-panel l) + l + (append (remq planet-status-panel l) (list planet-status-panel))))))])) + + (define/private (update-logger-button-label) + (when planet-logger-button + (send planet-logger-button set-label + (if (and logger-gui-text + (member logger-panel (send logger-parent-panel get-children))) + (string-constant hide-log) + (string-constant show-log))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; transcript + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + ;; transcript : (union #f string[directory-name]) + (field [transcript #f] + [definitions-transcript-counter 0] ;; number + [interactions-transcript-counter 0] ;; number + [transcript-parent-panel #f] ;; panel (unitialized short time only) + [transcript-panel #f] ;; panel (unitialized short time only) + [transcript-menu-item #f]) ;; menu-item (unitialized short time only) + ;; record-definitions : -> void + (define/private (record-definitions) + (when transcript + (set! definitions-transcript-counter (+ definitions-transcript-counter 1)) + (send definitions-text save-file + (build-path transcript (format "~a-definitions" (pad-two definitions-transcript-counter))) + 'copy))) + + ;; record-ineractions : -> void + (define/private (record-interactions) + (when transcript + (set! interactions-transcript-counter (+ interactions-transcript-counter 1)) + (send interactions-text save-file + (build-path transcript (format "~a-interactions" (pad-two interactions-transcript-counter))) + 'copy))) + + ;; pad-two : number -> string + ;; pads a number to two digits? + (define/private (pad-two n) + (cond + [(<= 0 n 9) (format "0~a" n)] + [else (format "~a" n)])) + + ;; start-transcript : -> void + ;; turns on the transcript and shows the transcript gui + (define/private (start-transcript) + (let ([transcript-directory (mred:get-directory + (string-constant please-choose-a-log-directory) + this)]) + (when (and transcript-directory + (ensure-empty transcript-directory)) + (send transcript-menu-item set-label (string-constant stop-logging)) + (set! transcript transcript-directory) + (set! definitions-transcript-counter 0) + (set! interactions-transcript-counter 0) + (build-transcript-panel) + (record-definitions)))) + + ;; stop-transcript : -> void + ;; turns off the transcript procedure + (define/private (stop-transcript) + (record-interactions) + (send transcript-menu-item set-label (string-constant log-definitions-and-interactions)) + (set! transcript #f) + (send transcript-panel change-children (λ (l) null))) + + ;; build-transcript-panel : -> void + ;; builds the contents of the transcript panel + (define/private (build-transcript-panel) + (define hp (make-object horizontal-panel% transcript-panel '(border))) + (make-object message% (string-constant logging-to) hp) + (send (make-object message% (path->string transcript) hp) stretchable-width #t) + (make-object button% (string-constant stop-logging) hp (λ (x y) (stop-transcript)))) + + ;; ensure-empty : string[directory] -> boolean + ;; if the transcript-directory is empty, just return #t + ;; if not, ask the user about emptying it. + ;; if they say yes, try to empty it. + ;; if that fails, report the error and return #f. + ;; if it succeeds, return #t. + ;; if they say no, return #f. + (define/private (ensure-empty transcript-directory) + (let ([dir-list (directory-list transcript-directory)]) + (or (null? dir-list) + (let ([query (message-box + (string-constant drscheme) + (gui-utils:format-literal-label (string-constant erase-log-directory-contents) + transcript-directory) + this + '(yes-no))]) + (cond + [(eq? query 'no) + #f] + [(eq? query 'yes) + (with-handlers ([exn:fail:filesystem? + (λ (exn) + (message-box + (string-constant drscheme) + (gui-utils:format-literal-label (string-constant error-erasing-log-directory) + (if (exn? exn) + (format "~a" (exn-message exn)) + (format "~s" exn))) + this) + #f)]) + (for-each (λ (file) (delete-file (build-path transcript-directory file))) + dir-list) + #t)]))))) + + (define/override (make-root-area-container cls parent) + (let* ([saved-p (preferences:get 'drracket:module-browser-size-percentage)] + [saved-p2 (preferences:get 'drracket:logging-size-percentage)] + [_module-browser-parent-panel + (super make-root-area-container + (make-two-way-prefs-dragable-panel% panel:horizontal-dragable% + 'drracket:module-browser-size-percentage) + parent)] + [_module-browser-panel (new vertical-panel% + (parent _module-browser-parent-panel) + (alignment '(left center)) + (stretchable-width #f))] + [planet-status-outer-panel (new vertical-panel% [parent _module-browser-parent-panel])] + [execute-warning-outer-panel (new vertical-panel% [parent planet-status-outer-panel])] + [logger-outer-panel (new (make-two-way-prefs-dragable-panel% panel:vertical-dragable% + 'drracket:logging-size-percentage) + [parent execute-warning-outer-panel])] + [trans-outer-panel (new vertical-panel% [parent logger-outer-panel])] + [root (make-object cls trans-outer-panel)]) + (set! module-browser-parent-panel _module-browser-parent-panel) + (set! module-browser-panel _module-browser-panel) + (send module-browser-parent-panel change-children (λ (l) (remq module-browser-panel l))) + (set! logger-parent-panel logger-outer-panel) + (set! logger-panel (new vertical-panel% [parent logger-parent-panel])) + (send logger-parent-panel change-children (lambda (x) (remq logger-panel x))) + + (set! execute-warning-parent-panel execute-warning-outer-panel) + (set! execute-warning-panel (new horizontal-panel% + [parent execute-warning-parent-panel] + [stretchable-height #f])) + (send execute-warning-parent-panel change-children (λ (l) (remq execute-warning-panel l))) + + (set! transcript-parent-panel (new horizontal-panel% + (parent trans-outer-panel) + (stretchable-height #f))) + (set! transcript-panel (make-object horizontal-panel% transcript-parent-panel)) + (set! planet-status-parent-panel (new vertical-panel% + [parent planet-status-outer-panel] + [stretchable-height #f])) + (set! planet-status-panel (new horizontal-panel% + [parent planet-status-parent-panel])) + (send planet-status-parent-panel change-children (λ (l) (remq planet-status-panel l))) + (unless (toolbar-shown?) + (send transcript-parent-panel change-children (λ (l) '()))) + (preferences:set 'drracket:module-browser-size-percentage saved-p) + (preferences:set 'drracket:logging-size-percentage saved-p2) + + root)) + + (inherit show-info hide-info is-info-hidden?) + (field [toolbar-state (preferences:get 'drracket:toolbar-state)] + [toolbar-top-menu-item #f] + [toolbar-left-menu-item #f] + [toolbar-right-menu-item #f] + [toolbar-hidden-menu-item #f] + [toolbar-menu #f]) + + ;; returns #t if the toolbar is visible, #f otherwise + (define/private (toolbar-shown?) (car toolbar-state)) + + (define/private (change-toolbar-state new-state) + (set! toolbar-state new-state) + (preferences:set 'drracket:toolbar-state new-state) + (update-toolbar-visibility)) + + (define/override (on-toolbar-button-click) (change-toolbar-state (cons (not (car toolbar-state)) (cdr toolbar-state)))) + (define/private (set-toolbar-left) (change-toolbar-state (cons #f 'left))) + (define/private (set-toolbar-right) (change-toolbar-state (cons #f 'right))) + (define/private (set-toolbar-top) (change-toolbar-state (cons #f 'top))) + (define/private (set-toolbar-hidden) (change-toolbar-state (cons #t (cdr toolbar-state)))) + + (define/public (update-toolbar-visibility) + (let* ([hidden? (toolbar-is-hidden?)] + [left? (toolbar-is-left?)] + [right? (toolbar-is-right?)] + [top? (toolbar-is-top?)]) + + (send toolbar-left-menu-item check left?) + (send toolbar-right-menu-item check right?) + (send toolbar-top-menu-item check top?) + (send toolbar-hidden-menu-item check hidden?) + + (cond + [hidden? + (hide-info) + (send top-outer-panel change-children (λ (l) '())) + (send transcript-parent-panel change-children (λ (l) '()))] + [top? (orient/show #t)] + [left? (orient/show #t)] + [right? (orient/show #f)])) + (update-defs/ints-resize-corner)) + + (define/private (toolbar-is-hidden?) + (car (preferences:get 'drracket:toolbar-state))) + (define/private (toolbar-is-top?) + (and (not (toolbar-is-hidden?)) + (eq? (cdr (preferences:get 'drracket:toolbar-state)) + 'top))) + (define/private (toolbar-is-right?) + (and (not (toolbar-is-hidden?)) + (eq? (cdr (preferences:get 'drracket:toolbar-state)) + 'right))) + (define/private (toolbar-is-left?) + (and (not (toolbar-is-hidden?)) + (eq? (cdr (preferences:get 'drracket:toolbar-state)) + 'left))) + + (define/private (orient/show bar-at-beginning?) + (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) + (begin-container-sequence) + (show-info) + + ;; orient the button panel and all panels inside it. + (let loop ([obj button-panel]) + (when (is-a? obj area-container<%>) + (when (or (is-a? obj vertical-panel%) + (is-a? obj horizontal-panel%)) + (unless (equal? (send obj get-orientation) (not vertical?)) + (send obj set-orientation (not vertical?)) + ;; have to be careful to avoid reversing the list when the orientation is already proper + (send obj change-children reverse))) + (for-each loop (send obj get-children)))) + + (orient) + + (send top-outer-panel stretchable-height vertical?) + (send top-outer-panel stretchable-width (not vertical?)) + (send top-panel set-orientation (not vertical?)) + (send toolbar/rest-panel set-orientation vertical?) + (send toolbar/rest-panel change-children + (λ (l) + (if bar-at-beginning? + (cons top-outer-panel (remq top-outer-panel l)) + (append (remq top-outer-panel l) (list top-outer-panel))))) + (send top-outer-panel change-children (λ (l) (list top-panel))) + (send transcript-parent-panel change-children (λ (l) (list transcript-panel))) + + (let* ([settings (send definitions-text get-next-settings)] + [language (drracket:language-configuration:language-settings-language settings)] + [name (get-define-popup-name (send language capability-value 'drscheme:define-popup) + vertical?)]) + (when name + (send func-defs-canvas set-message #f name))) + (send name-message set-short-title vertical?) + (send name-panel set-orientation (not vertical?)) + (if vertical? + (send name-panel set-alignment 'right 'top) + (send name-panel set-alignment 'left 'center)) + (end-container-sequence))) + + (define toolbar-buttons '()) + (define/public (register-toolbar-button b) + (set! toolbar-buttons (cons b toolbar-buttons)) + (orient)) + + (define/public (register-toolbar-buttons bs) + (set! toolbar-buttons (append bs toolbar-buttons)) + (orient)) + + (define/public (unregister-toolbar-button b) + (set! toolbar-buttons (remq b toolbar-buttons)) + (void)) + + (define/private (orient) + (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) + (for-each + (λ (obj) (send obj set-label-visible (not vertical?))) + toolbar-buttons)) - (unless (is-a? frame -frame<%>) - (error 'func-defs-canvas "frame is not a drracket:unit:frame<%>")) - - (define sort-by-name? (preferences:get 'drracket:defns-popup-sort-by-name?)) - (define sorting-name (if sort-by-name? - (string-constant sort-by-position) - (string-constant sort-by-name))) - (define/private (change-sorting-order) - (set! sort-by-name? (not sort-by-name?)) - (preferences:set 'drracket:defns-popup-sort-by-name? sort-by-name?) - (set! sorting-name (if sort-by-name? - (string-constant sort-by-position) - (string-constant sort-by-name)))) - - (define define-popup-capability-info - (drracket:language:get-capability-default 'drscheme:define-popup)) - - (inherit set-message set-hidden?) - (define/public (language-changed new-language vertical?) - (set! define-popup-capability-info (send new-language capability-value 'drscheme:define-popup)) - (let ([define-name (get-define-popup-name define-popup-capability-info - vertical?)]) + (let loop ([obj button-panel]) + (cond + [(is-a? obj area-container<%>) + (for-each loop (send obj get-children))] + [(is-a? obj switchable-button%) + (unless (memq obj toolbar-buttons) + (error 'register-toolbar-button "found a switchable-button% that is not registered, label ~s" + (send obj get-label)))] + [else (void)]))) + + (field [remove-show-status-line-callback + (preferences:add-callback + 'framework:show-status-line + (λ (p v) + (update-defs/ints-resize-corner/pref v)))]) + + (define/private (update-defs/ints-resize-corner) + (update-defs/ints-resize-corner/pref + (preferences:get 'framework:show-status-line))) + + (define/private (update-defs/ints-resize-corner/pref si-pref) + (let ([bottom-material? (and (not (car toolbar-state)) + si-pref)]) + (let loop ([cs definitions-canvases]) (cond - [define-name - (set-message #f define-name) - (set-hidden? #f)] + [(null? cs) (void)] + [(null? (cdr cs)) + (send (car cs) set-resize-corner (and (not bottom-material?) + (not interactions-shown?)))] [else - (set-hidden? #t)]))) - (define/override (fill-popup menu reset) - (when define-popup-capability-info - (let* ([text (send frame get-definitions-text)] - [unsorted-defns (get-definitions (car define-popup-capability-info) - (not sort-by-name?) - text)] - [defns (if sort-by-name? - (sort - unsorted-defns - (λ (x y) (string-ci<=? (defn-name x) (defn-name y)))) - unsorted-defns)]) - (make-object menu:can-restore-menu-item% sorting-name - menu - (λ (x y) - (change-sorting-order))) - (make-object separator-menu-item% menu) - (if (null? defns) - (send (make-object menu:can-restore-menu-item% - (string-constant no-definitions-found) - menu - void) - enable #f) - (let loop ([defns defns]) - (unless (null? defns) - (let* ([defn (car defns)] - [checked? - (let ([t-start (send text get-start-position)] - [t-end (send text get-end-position)] - [d-start (defn-start-pos defn)] - [d-end (defn-end-pos defn)]) - (or (<= t-start d-start t-end) - (<= t-start d-end t-end) - (<= d-start t-start t-end d-end)))] - [item - (make-object (if checked? - menu:can-restore-checkable-menu-item% - menu:can-restore-menu-item%) - (gui-utils:quote-literal-label (defn-name defn)) - - menu - (λ (x y) - (reset) - (send text set-position (defn-start-pos defn) (defn-start-pos defn)) - (let ([canvas (send text get-canvas)]) - (when canvas - (send canvas focus)))))]) - (when checked? - (send item check #t)) - (loop (cdr defns))))))))) + (send (car cs) set-resize-corner #f) + (loop (cdr cs))])) + (let loop ([cs interactions-canvases]) + (cond + [(null? cs) (void)] + [(null? (cdr cs)) + (send (car cs) set-resize-corner (and (not bottom-material?) + interactions-shown?))] + [else + (send (car cs) set-resize-corner #f) + (loop (cdr cs))])))) + + [define definitions-item #f] + [define interactions-item #f] + [define name-message #f] + [define save-button #f] + [define save-init-shown? #f] + + [define/private set-save-init-shown? (λ (x) (set! save-init-shown? x))] + + [define canvas-show-mode #f] + [define allow-split? #f] + [define forced-quit? #f] + [define search-canvas #f] + + (define/public (make-searchable canvas) + (update-info) + (set! search-canvas canvas)) + + (define was-locked? #f) + + (define/public-final (disable-evaluation-in-tab tab) + (when (eq? tab current-tab) + (disable-evaluation))) + + (define/pubment (disable-evaluation) + (when execute-menu-item + (send execute-menu-item enable #f)) + (send execute-button enable #f) + (inner (void) disable-evaluation)) + + (define/public-final (enable-evaluation-in-tab tab) + (when (eq? tab current-tab) + (enable-evaluation))) + + (define/pubment (enable-evaluation) + (when execute-menu-item + (send execute-menu-item enable #t)) + (send execute-button enable #t) + (inner (void) enable-evaluation)) + + (inherit set-label) + (inherit modified) + (define/public (update-save-button) + (let ([mod? (send definitions-text is-modified?)]) + (modified mod?) + (if save-button + (unless (eq? mod? (send save-button is-shown?)) + (send save-button show mod?)) + (set! save-init-shown? mod?)) + (update-tab-label current-tab))) + + (define/public (language-changed) + (let* ([settings (send definitions-text get-next-settings)] + [language (drracket:language-configuration:language-settings-language settings)]) + (send func-defs-canvas language-changed language (or (toolbar-is-left?) (toolbar-is-right?))) + (send language-message set-yellow/lang + (not (send definitions-text this-and-next-language-the-same?)) + (string-append (send language get-language-name) + (if (send language default-settings? + (drracket:language-configuration:language-settings-settings settings)) + "" + (string-append " " (string-constant custom))))) + (when (is-a? language-specific-menu menu%) + (let ([label (send language-specific-menu get-label)] + [new-label (send language capability-value 'drscheme:language-menu-title)]) + (unless (equal? label new-label) + (send language-specific-menu set-label new-label)))))) + + (define/public (get-language-menu) language-specific-menu) + + ;; update-save-message : -> void + ;; sets the save message. If input is #f, uses the frame's + ;; title. + (define/public (update-save-message) + (when name-message + (let ([filename (send definitions-text get-filename)]) + (send name-message set-message + (if filename #t #f) + (send definitions-text get-filename/untitled-name)))) + (update-tabs-labels)) + + (define/private (update-tabs-labels) + (for-each (λ (tab) (update-tab-label tab)) tabs) + (send tabs-panel set-selection (send current-tab get-i)) + (send (send tabs-panel get-parent) + change-children + (λ (l) + (cond + [(= (send tabs-panel get-number) 1) + (remq tabs-panel l)] + [else + (if (memq tabs-panel l) + l + (cons tabs-panel l))])))) + + (define/private (update-tab-label tab) + (let ([label (gui-utils:trim-string (get-defs-tab-label (send tab get-defs) tab) 200)]) + (unless (equal? label (send tabs-panel get-item-label (send tab get-i))) + (send tabs-panel set-item-label (send tab get-i) label)))) + + (define/public (get-tab-filename i) + (get-defs-tab-filename (send (list-ref tabs i) get-defs))) + + (define/private (get-defs-tab-label defs tab) + (let ([fn (send defs get-filename)] + [i-prefix (or (for/or ([i (in-list tabs)] + [n (in-naturals 1)] + #:when (<= n 9)) + (and (eq? i tab) + (format "~a: " n))) + "")]) + (add-modified-flag + defs + (string-append + i-prefix + (get-defs-tab-filename defs))))) + + (define/private (get-defs-tab-filename defs) + (let ([fn (send defs get-filename)]) + (if fn + (get-tab-label-from-filename fn) + (send defs get-filename/untitled-name)))) + + ;; tab-label-cache-valid : (listof path) + ;; If the current set of filenames in the tabs is the + ;; same set of filenames as in this list, then the + ;; tab-label-cache is valid; otherwise not + (define tab-label-cache-valid '()) + + ;; tab-label-cache : path -o> string + (define tab-label-cache (make-hasheq)) + + (define/private (get-tab-label-from-filename fn) + (define current-paths (map (lambda (tab) (send (send tab get-defs) get-filename)) + tabs)) + (unless (and (= (length tab-label-cache-valid) (length current-paths)) + (andmap eq? tab-label-cache-valid current-paths)) + (set! tab-label-cache-valid current-paths) + (set! tab-label-cache (make-hasheq))) + (hash-ref! tab-label-cache + fn + (lambda () (compute-tab-label-from-filename fn)))) + + (define/private (compute-tab-label-from-filename fn) + (let* ([take-n + (λ (n lst) + (let loop ([n n] + [lst lst]) + (cond + [(zero? n) null] + [(null? lst) null] + [else (cons (car lst) (loop (- n 1) (cdr lst)))])))] + [find-exp-diff + (λ (p1 p2) + (let loop ([p1 p1] + [p2 p2] + [i 1]) + (cond + [(or (null? p1) (null? p2)) i] + [else (let ([f1 (car p1)] + [f2 (car p2)]) + (if (equal? f1 f2) + (loop (cdr p1) (cdr p2) (+ i 1)) + i))])))] + [exp (reverse (explode-path (normalize-path/exists fn)))] + [other-exps + (filter + (λ (x) (and x + (not (equal? exp x)))) + (map (λ (other-tab) + (let ([fn (send (send other-tab get-defs) get-filename)]) + (and fn + (reverse (explode-path (normalize-path/exists fn)))))) + tabs))] + [size + (let loop ([other-exps other-exps] + [size 1]) + (cond + [(null? other-exps) size] + [else (let ([new-size (find-exp-diff (car other-exps) exp)]) + (loop (cdr other-exps) + (max new-size size)))]))]) + (path->string (apply build-path (reverse (take-n size exp)))))) + + (define/private (normalize-path/exists fn) + (if (file-exists? fn) + (normalize-path fn) + fn)) + + (define/private (add-modified-flag text string) + (if (send text is-modified?) + (let ([prefix (get-save-diamond-prefix)]) + (if prefix + (string-append prefix string) + string)) + string)) + + (define/private (get-save-diamond-prefix) + (let ([candidate-prefixes + ;; be sure asterisk is at the end of each list, + ;; since that's a relatively safe character + (case (system-type) + [(unix windows) '("★ " "◆ " "• " "* ")] + [else '("◆ " "★ " "• " "* ")])]) + (ormap + (lambda (candidate) + (and (andmap (λ (x) (send normal-control-font screen-glyph-exists? x #t)) + (string->list candidate)) + candidate)) + candidate-prefixes))) + + [define/override get-canvas% (λ () (drracket:get/extend:get-definitions-canvas))] + + (define/public (update-running running?) + (send running-canvas set-running running?)) + (define/public (ensure-defs-shown) + (unless definitions-shown? + (toggle-show/hide-definitions) + (update-shown))) + (define/public (ensure-rep-shown rep) + (unless (eq? rep interactions-text) + (let loop ([tabs tabs]) + (unless (null? tabs) + (let ([tab (car tabs)]) + (if (eq? (send tab get-ints) rep) + (change-to-tab tab) + (loop (cdr tabs))))))) + (unless interactions-shown? + (toggle-show/hide-interactions) + (update-shown))) + (define/public (ensure-rep-hidden) + (when interactions-shown? + (toggle-show/hide-interactions) + (update-shown))) + + (define/override (get-editor%) (drracket:get/extend:get-definitions-text)) + (define/public (still-untouched?) + (and (send definitions-text still-untouched?) + (let* ([prompt (send interactions-text get-prompt)] + [first-prompt-para + (let loop ([n 0]) + (cond + [(n . <= . (send interactions-text last-paragraph)) + (if (string=? + (send interactions-text get-text + (send interactions-text paragraph-start-position n) + (+ (send interactions-text paragraph-start-position n) + (string-length prompt))) + prompt) + n + (loop (+ n 1)))] + [else #f]))]) + (and first-prompt-para + (= first-prompt-para (send interactions-text last-paragraph)) + (equal? + (send interactions-text get-text + (send interactions-text paragraph-start-position first-prompt-para) + (send interactions-text paragraph-end-position first-prompt-para)) + (send interactions-text get-prompt)))))) + (define/public (change-to-file name) + (cond + [(and name (file-exists? name)) + (ensure-rep-hidden) + (send definitions-text begin-edit-sequence) + (send definitions-text load-file/gui-error name) + (send definitions-text end-edit-sequence) + (send language-message set-yellow #f)] + [name + (send definitions-text set-filename name)] + [else (send definitions-text clear)]) + (send definitions-canvas focus)) + + + + + + + ; + ; + ; + ; ; + ; ; + ; ; + ; ; ;; ;; ;;; ;; ; ;;; ;;; + ; ;; ;; ; ; ; ; ;; ; ; ; + ; ; ; ; ; ; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ;;;;;; ;; + ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ; + ; ; ; ; ;;; ;; ; ;;;; ;;; + ; + ; + ; + + + (define/private (add-modes-submenu edit-menu) + (new menu% + (parent edit-menu) + (label (string-constant mode-submenu-label)) + (demand-callback + (λ (menu) + (for-each (λ (item) (send item delete)) + (send menu get-items)) + (for-each (λ (mode) + (let* ([item + (new checkable-menu-item% + (label (drracket:modes:mode-name mode)) + (parent menu) + (callback + (λ (_1 _2) (send definitions-text set-current-mode mode))))]) + (when (send definitions-text is-current-mode? mode) + (send item check #t)))) + (drracket:modes:get-modes)))))) + + + + + ; + ; + ; + ; ; ; ; ; ; + ; ; ; ; ; + ; ; ; ; ; ; + ; ;;; ; ;; ; ; ;;;; ; ;;; ;;; ; ; ;;; ; ;; ;;; ;;; + ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ;; ;;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; + ; ;;; ; ;; ; ; ;; ; ;;; ;;; ; ; ;;;;; ; ;; ;;; ;;;; + ; ; ; ; + ; ; ; ; + ; ; ; + + + (inherit get-edit-target-window) + + (define/public (split) + (let ([canvas-to-be-split (get-edit-target-window)]) + (cond + [(memq canvas-to-be-split definitions-canvases) + (split-definitions canvas-to-be-split)] + [(memq canvas-to-be-split interactions-canvases) + (split-interactions canvas-to-be-split)] + [else (bell)]))) + + (define/private (split-definitions canvas-to-be-split) + (handle-split canvas-to-be-split + (λ (x) (set! definitions-canvases x)) + definitions-canvases + (drracket:get/extend:get-definitions-canvas) + definitions-text)) + + (define/private (split-interactions canvas-to-be-split) + (handle-split canvas-to-be-split + (λ (x) (set! interactions-canvases x)) + interactions-canvases + (drracket:get/extend:get-interactions-canvas) + interactions-text)) + + (define/private (handle-split canvas-to-be-split set-canvases! canvases canvas% text) + (let-values ([(ox oy ow oh cursor-y) + (get-visible-region canvas-to-be-split)]) + (let ([orig-percentages (send resizable-panel get-percentages)] + [orig-canvases (send resizable-panel get-children)] + [new-canvas (new canvas% + (parent resizable-panel) + (editor text) + (style '()))]) + + (set-canvases! + (let loop ([canvases canvases]) + (cond + [(null? canvases) (error 'split "couldn't split; didn't find canvas")] + [else + (let ([canvas (car canvases)]) + (if (eq? canvas canvas-to-be-split) + (list* new-canvas + canvas + (cdr canvases)) + (cons canvas (loop (cdr canvases)))))]))) + + (update-shown) + + ;; with-handlers prevents bad calls to set-percentages + ;; might still leave GUI in bad state, however. + (with-handlers ([exn:fail? (λ (x) (void))]) + (send resizable-panel set-percentages + (let loop ([canvases orig-canvases] + [percentages orig-percentages]) + (cond + [(null? canvases) + (error 'split "couldn't split; didn't find canvas")] + [(null? percentages) + (error 'split "wrong number of percentages: ~s ~s" + orig-percentages + (send resizable-panel get-children))] + [else (let ([canvas (car canvases)]) + (if (eq? canvas-to-be-split canvas) + (list* (/ (car percentages) 2) + (/ (car percentages) 2) + (cdr percentages)) + (cons + (car percentages) + (loop (cdr canvases) + (cdr percentages)))))])))) + + (set-visible-region new-canvas ox oy ow oh cursor-y) + (set-visible-region canvas-to-be-split ox oy ow oh cursor-y) + + (send new-canvas focus)))) + + ;; split-demand : menu-item -> void + ;; enables the menu-item if splitting is allowed, disables otherwise + (define/private (split-demand item) + (let ([canvas-to-be-split (get-edit-target-window)]) + (send item enable + (or (memq canvas-to-be-split definitions-canvases) + (memq canvas-to-be-split interactions-canvases))))) + + ;; collapse-demand : menu-item -> void + ;; enables the menu-item if collapsing is allowed, disables otherwise + (define/private (collapse-demand item) + (let ([canvas-to-be-split (get-edit-target-window)]) + (cond + [(memq canvas-to-be-split definitions-canvases) + (send item enable (2 . <= . (length definitions-canvases)))] + [(memq canvas-to-be-split interactions-canvases) + (send item enable (2 . <= . (length interactions-canvases)))] + [else + (send item enable #f)]))) + + ;; get-visible-region : editor-canvas -> number number number number (union #f number) + ;; calculates the visible region of the editor in this editor-canvas, returning + ;; four numbers for the x, y, width and height of the visible region + ;; also, the last two booleans indiciate if the beginning and the end + ;; of the selection was visible before the split, respectively. + (define/private (get-visible-region canvas) + (send canvas call-as-primary-owner + (λ () + (let* ([text (send canvas get-editor)] + [admin (send text get-admin)] + [start (send text get-start-position)] + [end (send text get-end-position)]) + (let-values ([(x y w h) (get-visible-area admin)]) + (let ([ysb (box 0)]) + (send text position-location (send text get-start-position) #f ysb) + (values x y w h + (and (= start end) + (<= y (unbox ysb) (+ y h)) + (unbox ysb))))))))) + + ;; set-visible-region : editor-canvas number number number number (union #f number) -> void + ;; sets the visible region of the text displayed by the editor canvas + ;; to be the middle of the region (vertically) specified by x, y, w, and h. + ;; if start-visible? and/or end-visible? are true, some special handling + ;; is done to try to keep the start and end visible, with precendence + ;; given to start if both are #t. + (define/private (set-visible-region canvas x y w h cursor-y) + (send canvas call-as-primary-owner + (λ () + (let* ([text (send canvas get-editor)] + [admin (send text get-admin)] + [nwb (box 0)] + [nhb (box 0)]) + (send admin get-view #f #f nwb nhb) + (let* ([nw (unbox nwb)] + [nh (unbox nhb)] + + [nx x] + [raw-y (- (+ y (/ h 2)) (/ nh 2))] + [ny (if (and cursor-y + (not (<= raw-y cursor-y (+ raw-y nh)))) + (- cursor-y (/ nh 2)) + raw-y)]) + (send canvas scroll-to nx ny nw nh #t) + (void)))))) + + ;; get-visible-area : admin -> number number number number + ;; returns the visible area for this admin + (define/private (get-visible-area admin) + (let ([bx (box 0)] + [by (box 0)] + [bw (box 0)] + [bh (box 0)]) + (send admin get-view bx by bw bh) + (values (unbox bx) + (unbox by) + (unbox bw) + (unbox bh)))) + + (define/public (collapse) + (let* ([target (get-edit-target-window)]) + (cond + [(memq target definitions-canvases) + (collapse-definitions target)] + [(memq target interactions-canvases) + (collapse-interactions target)] + [else (bell)]))) + + (define/private (collapse-definitions target) + (handle-collapse + target + (λ () definitions-canvases) + (λ (c) (set! definitions-canvases c)))) + + (define/private (collapse-interactions target) + (handle-collapse + target + (λ () interactions-canvases) + (λ (c) (set! interactions-canvases c)))) + + (define/private (handle-collapse target get-canvases set-canvases!) + (if (= 1 (length (get-canvases))) + (bell) + (let* ([old-percentages (send resizable-panel get-percentages)] + [soon-to-be-bigger-canvas #f] + [percentages + (if (eq? (car (get-canvases)) target) + (begin + (set! soon-to-be-bigger-canvas (cadr (get-canvases))) + (cons (+ (car old-percentages) + (cadr old-percentages)) + (cddr old-percentages))) + (let loop ([canvases (cdr (get-canvases))] + [prev-canvas (car (get-canvases))] + [percentages (cdr old-percentages)] + [prev-percentage (car old-percentages)]) + (cond + [(null? canvases) + (error 'collapse "internal error.1")] + [(null? percentages) + (error 'collapse "internal error.2")] + [else + (if (eq? (car canvases) target) + (begin + (set! soon-to-be-bigger-canvas prev-canvas) + (cons (+ (car percentages) + prev-percentage) + (cdr percentages))) + (cons prev-percentage + (loop (cdr canvases) + (car canvases) + (cdr percentages) + (car percentages))))])))]) + (unless soon-to-be-bigger-canvas + (error 'collapse "internal error.3")) + (set-canvases! (remq target (get-canvases))) + (update-shown) + + (let ([target-admin + (send target call-as-primary-owner + (λ () + (send (send target get-editor) get-admin)))] + [to-be-bigger-admin + (send soon-to-be-bigger-canvas call-as-primary-owner + (λ () + (send (send soon-to-be-bigger-canvas get-editor) get-admin)))]) + (let-values ([(bx by bw bh) (get-visible-area target-admin)]) + + ;; this line makes the soon-to-be-bigger-canvas bigger + ;; if it fails, we're out of luck, but at least we don't crash. + (with-handlers ([exn:fail? (λ (x) (void))]) + (send resizable-panel set-percentages percentages)) + + (let-values ([(ax ay aw ah) (get-visible-area to-be-bigger-admin)]) + (send soon-to-be-bigger-canvas scroll-to + bx + (- by (/ (- ah bh) 2)) + aw + ah + #t)))) + + (send target set-editor #f) + (send soon-to-be-bigger-canvas focus)))) + ; + ; + ; + ; ; + ; ; + ; ; + ; ;;; ; ;; ;;; ; ; ; ; ;; ;; ;;; ; ;; ; ; + ; ; ;; ; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; + ; ;;; ; ; ;;; ; ; ; ; ; ;;;; ; ; ;; ; + ; + ; + ; + + + (define interactions-shown? #t) + (define definitions-shown? #t) + + (define/private (toggle-show/hide-definitions) + (set! definitions-shown? (not definitions-shown?)) + (unless definitions-shown? + (set! interactions-shown? #t))) + (define/private (toggle-show/hide-interactions) + (set! interactions-shown? (not interactions-shown?)) + (unless interactions-shown? + (set! definitions-shown? #t))) + + (define (immediate-children parent children) + (define (immediate child) + (let loop ([child child]) + (define immediate-parent (send child get-parent)) + (if (eq? immediate-parent parent) + child + (loop immediate-parent)))) + (for/list ([child children]) + (immediate child))) + + (define/override (update-shown) + (super update-shown) + (let ([new-children + (foldl + (λ (shown? children sofar) + (if shown? + (append children sofar) + sofar)) + null + (list interactions-shown? + definitions-shown?) + (list interactions-canvases + definitions-canvases))] + [old-children (send resizable-panel get-children)] + [p (preferences:get 'drracket:unit-window-size-percentage)]) + (update-defs/ints-resize-corner) + (send definitions-item set-label + (if definitions-shown? + (string-constant hide-definitions-menu-item-label) + (string-constant show-definitions-menu-item-label))) + (send interactions-item set-label + (if interactions-shown? + (string-constant hide-interactions-menu-item-label) + (string-constant show-interactions-menu-item-label))) + (send resizable-panel begin-container-sequence) + + ;; this might change the unit-window-size-percentage, so save/restore it + (send resizable-panel change-children + (λ (old) + (immediate-children resizable-panel new-children))) + + (preferences:set 'drracket:unit-window-size-percentage p) + ;; restore preferred interactions/definitions sizes + (when (and (= 1 (length definitions-canvases)) + (= 1 (length interactions-canvases)) + (= 2 (length new-children))) + (with-handlers ([exn:fail? (λ (x) (void))]) + (send resizable-panel set-percentages + (list p (- 1 p))))) + + (send resizable-panel end-container-sequence) + (when (ormap (λ (child) + (and (is-a? child editor-canvas%) + (not (send child has-focus?)))) + (send resizable-panel get-children)) + (let ([new-focus + (let loop ([children (send resizable-panel get-children)]) + (cond + [(null? children) (void)] + [else (let ([child (car children)]) + (if (is-a? child editor-canvas%) + child + (loop (cdr children))))]))] + [old-focus + (ormap (λ (x) (and (is-a? x editor-canvas%) (send x has-focus?) x)) + old-children)]) + + ;; conservatively, only scroll when the focus stays in the same place. + (when old-focus + (when (eq? old-focus new-focus) + (let ([ed (send old-focus get-editor)]) + (when ed + (send ed scroll-to-position + (send ed get-start-position) + #f + (send ed get-end-position)))))) + + (send new-focus focus))) + + (for-each + (λ (get-item) + (let ([item (get-item)]) + (when item + (send item enable definitions-shown?)))) + (list (λ () (file-menu:get-revert-item)) + (λ () (file-menu:get-save-item)) + (λ () (file-menu:get-save-as-item)) + ;(λ () (file-menu:save-as-text-item)) ; Save As Text... + (λ () (file-menu:get-print-item)))) + (send file-menu:print-interactions-item enable interactions-shown?))) + + (define/augment (can-close?) + (and (andmap (lambda (tab) + (or (eq? tab current-tab) + (and (send (send tab get-defs) can-close?) + (send (send tab get-ints) can-close?)))) + tabs) + (send interactions-text can-close?) + (inner #t can-close?))) + (define/augment (on-close) + (inner (void) on-close) + (for-each (lambda (tab) + (unless (eq? tab current-tab) + (send (send tab get-defs) on-close) + (send (send tab get-ints) on-close))) + tabs) + (when (eq? this newest-frame) + (set! newest-frame #f)) + (when transcript + (stop-transcript)) + (remove-show-status-line-callback) + (remove-bug-icon-callback) + (send interactions-text on-close)) + + ;; execute-callback : -> void + ;; uses the state of the button to determine if an execution is + ;; already running. This function is called from many places, not + ;; just the execute button. + (define/public (execute-callback) + (when (send execute-button is-enabled?) + + ;; if the language is not-a-language, and the buffer looks like a module, + ;; automatically make the switch to the module language + (let ([next-settings (send definitions-text get-next-settings)]) + (when (is-a? (drracket:language-configuration:language-settings-language next-settings) + drracket:language-configuration:not-a-language-language<%>) + (when (looks-like-module? definitions-text) + (let-values ([(module-language module-language-settings) (get-module-language/settings)]) + (when (and module-language module-language-settings) + (send definitions-text set-next-settings + (drracket:language-configuration:language-settings + module-language + module-language-settings))))))) + + (check-if-save-file-up-to-date) + (when (preferences:get 'drracket:show-interactions-on-execute) + (ensure-rep-shown interactions-text)) + (when transcript + (record-definitions) + (record-interactions)) + (send definitions-text just-executed) + (send language-message set-yellow #f) + (send interactions-canvas focus) + (send interactions-text reset-console) + (send interactions-text clear-undos) + + (let ([start 0]) + (send definitions-text split-snip start) + (let* ([name (send definitions-text get-port-name)] + [text-port (open-input-text-editor definitions-text start 'end values name #t)]) + (port-count-lines! text-port) + (let* ([line (send definitions-text position-paragraph start)] + [column (- start (send definitions-text paragraph-start-position line))] + [relocated-port (relocate-input-port text-port + (+ line 1) + column + (+ start 1))]) + (port-count-lines! relocated-port) + (send interactions-text evaluate-from-port + relocated-port + #t + (λ () + (send interactions-text clear-undos)))))))) + + (inherit revert save) + (define/private (check-if-save-file-up-to-date) + (when (send definitions-text save-file-out-of-date?) + (let ([user-choice + (message-box/custom + (string-constant drscheme) + (string-constant definitions-modified) + (string-constant ignore) + (string-constant revert) + #f + this + '(caution default=2 number-order) + 1)]) + (case user-choice + [(1) (void)] + [(2) (revert)])))) + + (inherit get-menu-bar get-focus-object get-edit-target-object) + + (define/override (get-editor) definitions-text) + (define/override (get-canvas) + (initialize-definitions-canvas) + definitions-canvas) + + (define (create-definitions-canvas) + (new (drracket:get/extend:get-definitions-canvas) + [parent resizable-panel] + [editor definitions-text])) + + (define/private (initialize-definitions-canvas) + (unless definitions-canvas + (set! definitions-canvas (create-definitions-canvas)))) + + (define/override (get-delegated-text) definitions-text) + (define/override (get-open-here-editor) definitions-text) + + ;; wire the definitions text to the interactions text and initialize it. + (define/private (init-definitions-text tab) + (let ([defs (send tab get-defs)] + [ints (send tab get-ints)]) + (send defs set-interactions-text ints) + (send defs set-tab tab) + (send ints set-definitions-text defs) + (send defs change-mode-to-match) + (send defs insert-auto-text))) + + + ; + ; + ; @@ + ; @ @ + ; @@@@@ $@$: @-@$ :@@+@ + ; @ -@ @+ *$ @$ -@ + ; @ -$@$@ @ @ :@@$- + ; @ $* @ @ @ *@ + ; @: :$ @- *@ @ +$ @ :@ + ; :@@$- -$$-@@@@+@$ $+@@: + ; + ; + ; + ; + + (define/public (get-current-tab) current-tab) + + ;; create-new-tab : -> void + ;; creates a new tab and updates the GUI for that new tab + (define/private create-new-tab + (lambda ([filename #f]) + (let* ([defs (new (drracket:get/extend:get-definitions-text))] + [tab-count (length tabs)] + [new-tab (new (drracket:get/extend:get-tab) + (defs defs) + (i tab-count) + (frame this) + (defs-shown? #t) + (ints-shown? (not filename)))] + [ints (make-object (drracket:get/extend:get-interactions-text) new-tab)]) + (send new-tab set-ints ints) + (set! tabs (append tabs (list new-tab))) + (send tabs-panel append + (gui-utils:trim-string + (if filename + (get-tab-label-from-filename filename) + (get-defs-tab-label defs #f)) + 200)) + (init-definitions-text new-tab) + (change-to-nth-tab (- (send tabs-panel get-number) 1)) + (when filename (send defs load-file filename)) + (send ints initialize-console) + (send tabs-panel set-selection (- (send tabs-panel get-number) 1)) + (set! newest-frame this) + (update-menu-bindings)))) + + ;; change-to-tab : tab -> void + ;; updates current-tab, definitions-text, and interactactions-text + ;; to be the nth tab. Also updates the GUI to show the new tab + (inherit begin-container-sequence end-container-sequence) + (define/private (change-to-tab tab) + (let ([old-delegate (send definitions-text get-delegate)] + [old-tab current-tab]) + (save-visible-tab-regions) + (set! current-tab tab) + (set! definitions-text (send current-tab get-defs)) + (set! interactions-text (send current-tab get-ints)) + + + (begin-container-sequence) + (for-each (λ (defs-canvas) (send defs-canvas set-editor definitions-text #f)) + definitions-canvases) + (for-each (λ (ints-canvas) (send ints-canvas set-editor interactions-text #f)) + interactions-canvases) + + (update-save-message) + (update-save-button) + (language-changed) + + (send definitions-text update-frame-filename) + (send definitions-text set-delegate old-delegate) + (update-running (send current-tab is-running?)) + (on-tab-change old-tab current-tab) + (send tab update-log) + (send tab update-planet-status) + (send tab update-execute-warning-gui) + (restore-visible-tab-regions) + (for-each (λ (defs-canvas) (send defs-canvas refresh)) + definitions-canvases) + (for-each (λ (ints-canvas) (send ints-canvas refresh)) + interactions-canvases) + (set-color-status! (send definitions-text is-lexer-valid?)) + (end-container-sequence))) + + (define/pubment (on-tab-change from-tab to-tab) + (let ([old-enabled (send from-tab get-enabled)] + [new-enabled (send to-tab get-enabled)]) + (unless (eq? old-enabled new-enabled) + (if new-enabled + (enable-evaluation) + (disable-evaluation)))) - (super-new (label "(define ...)") ;; this default is quickly changed - [string-constant-untitled (string-constant untitled)] - [string-constant-no-full-name-since-not-saved - (string-constant no-full-name-since-not-saved)]))) + (let ([from-defs (send from-tab get-defs)] + [to-defs (send to-tab get-defs)]) + (let ([delegate (send from-defs get-delegate)]) + (send from-defs set-delegate #f) + (send to-defs set-delegate delegate))) + + (inner (void) on-tab-change from-tab to-tab)) + + (define/public (next-tab) (change-to-delta-tab +1)) + (define/public (prev-tab) (change-to-delta-tab -1)) + + (define/private (change-to-delta-tab dt) + (change-to-nth-tab (modulo (+ (send current-tab get-i) dt) (length tabs)))) + + (define/public-final (close-current-tab) + (cond + [(null? tabs) (void)] + [(null? (cdr tabs)) (void)] + [else + (let loop ([l-tabs tabs]) + (cond + [(null? l-tabs) (error 'close-current-tab "uh oh.3")] + [else + (let ([tab (car l-tabs)]) + (if (eq? tab current-tab) + (when (close-tab tab) + (for-each (lambda (t) (send t set-i (- (send t get-i) 1))) + (cdr l-tabs)) + (set! tabs (remq tab tabs)) + (send tabs-panel delete (send tab get-i)) + (update-menu-bindings) + (change-to-tab (cond + [(< (send tab get-i) (length tabs)) + (list-ref tabs (send tab get-i))] + [else (last tabs)]))) + (loop (cdr l-tabs))))]))])) + + ;; a helper private method for close-current-tab -- doesn't close an arbitrary tab. + (define/private (close-tab tab) + (cond + [(send tab can-close?) + (send tab on-close) + #t] + [else #f])) + + (define/public (open-in-new-tab filename) + (create-new-tab filename)) + + (define/public (get-tab-count) (length tabs)) + (define/public (change-to-nth-tab n) + (unless (< n (length tabs)) + (error 'change-to-nth-tab "number too big ~s" n)) + (change-to-tab (list-ref tabs n))) + + (define/private (save-visible-tab-regions) + (send current-tab set-visible-ints + (get-tab-visible-regions interactions-text) + interactions-shown?) + (send current-tab set-visible-defs + (get-tab-visible-regions definitions-text) + definitions-shown?) + (send current-tab set-focus-d/i + (if (ormap (λ (x) (send x has-focus?)) interactions-canvases) + 'ints + 'defs))) + + (define/private (get-tab-visible-regions txt) + (map (λ (canvas) + (let-values ([(x y w h _) (get-visible-region canvas)]) + (list x y w h))) + (send txt get-canvases))) + + (inherit set-text-to-search reflow-container) + (define/private (restore-visible-tab-regions) + (define (fix-up-canvas-numbers txt regions ints?) + (when regions + (let* ([canvases (send txt get-canvases)] + [canvases-count (length canvases)] + [regions-count (length regions)]) + (cond + [(> canvases-count regions-count) + (let loop ([i (- canvases-count regions-count)] + [canvases canvases]) + (unless (zero? i) + (if ints? + (collapse-interactions (car canvases)) + (collapse-definitions (car canvases))) + (loop (- i 1) + (cdr canvases))))] + [(= canvases-count regions-count) + (void)] + [(< canvases-count regions-count) + (let loop ([i (- regions-count canvases-count)] + [canvases canvases]) + (unless (zero? i) + (if ints? + (split-interactions (car canvases)) + (split-definitions (car canvases))) + (loop (- i 1) + (cdr canvases))))])))) + + (define (set-visible-regions txt regions) + (when regions + (for-each (λ (canvas region) + (set-visible-region canvas + (first region) + (second region) + (third region) + (fourth region) + #f)) + (send txt get-canvases) + regions))) + + (let-values ([(vi is?) (send current-tab get-visible-ints)] + [(vd ds?) (send current-tab get-visible-defs)]) + (set! interactions-shown? is?) + (set! definitions-shown? ds?) + (update-shown) + (reflow-container) ;; without this one, the percentages in the resizable-panel are not up to date with the children + (fix-up-canvas-numbers definitions-text vd #f) + (fix-up-canvas-numbers interactions-text vi #t) + (reflow-container) + (set-visible-regions definitions-text vd) + (set-visible-regions interactions-text vi)) + (case (send current-tab get-focus-d/i) + [(defs) + (send (car definitions-canvases) focus) + (set-text-to-search (send (car definitions-canvases) get-editor))] + [(ints) + (send (car interactions-canvases) focus) + (set-text-to-search (send (car interactions-canvases) get-editor))])) + + (define/private (pathname-equal? p1 p2) + (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) + (string=? (path->string (normal-case-path (normalize-path p1))) + (path->string (normal-case-path (normalize-path p2)))))) + + (define/override (make-visible filename) + (let ([tab (find-matching-tab filename)]) + (when tab + (change-to-tab tab)))) + + (define/private (find-matching-tab filename) + (let loop ([tabs tabs]) + (cond + [(null? tabs) #f] + [else + (let* ([tab (car tabs)] + [tab-filename (send (send tab get-defs) get-filename)]) + (if (and tab-filename + (pathname-equal? filename tab-filename)) + tab + (loop (cdr tabs))))]))) + + (define/override (editing-this-file? filename) + (ormap (λ (tab) + (let ([fn (send (send tab get-defs) get-filename)]) + (and fn + (pathname-equal? fn filename)))) + tabs)) + + (define/override (get-menu-item%) + (class (super get-menu-item%) + (inherit get-label get-plain-label) + (define/override (restore-keybinding) + (cond + [(equal? (get-plain-label) (string-constant close)) + (update-close-menu-item-shortcut this)] + [(equal? (get-plain-label) (string-constant close-tab)) + (update-close-tab-menu-item-shortcut this)] + [else (super restore-keybinding)])) + (super-new))) + + (define/private (update-menu-bindings) + (when (preferences:get 'framework:menu-bindings) + (when close-tab-menu-item + (update-close-tab-menu-item-shortcut close-tab-menu-item)) + (update-close-menu-item-shortcut (file-menu:get-close-item)))) + + (define/private (update-close-tab-menu-item-shortcut item) + (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) + (send item set-label (if just-one? + (string-constant close-tab) + (string-constant close-tab-amp))) + (send item set-shortcut (if just-one? #f #\w)))) + + (define/private (update-close-menu-item-shortcut item) + (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) + (send item set-label (if just-one? + (string-constant close-menu-item) + (string-constant close))) + (send item set-shortcut (if just-one? #\w #f)))) + + ;; offer-to-save-file : path -> void + ;; bring the tab that edits the file named by `path' to the front + ;; and opens a dialog asking if it should be saved. + (define/public (offer-to-save-file path) + (let ([original-tab current-tab] + [tab-to-save (find-matching-tab path)]) + (when tab-to-save + (let ([defs-to-save (send tab-to-save get-defs)]) + (when (send defs-to-save is-modified?) + (unless (eq? tab-to-save original-tab) + (change-to-tab tab-to-save)) + (send defs-to-save user-saves-or-not-modified? #f) + (unless (eq? tab-to-save original-tab) + (change-to-tab original-tab))))))) + + + ;; + ;; end tabs + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define/public (get-definitions-text) definitions-text) + (define/public (get-interactions-text) interactions-text) + + (define/public (get-definitions/interactions-panel-parent) + toolbar/rest-panel) + + (inherit delegated-text-shown? hide-delegated-text show-delegated-text) + (define/override (add-show-menu-items show-menu) + (super add-show-menu-items show-menu) + (set! definitions-item + (make-object menu:can-restore-menu-item% + (string-constant hide-definitions-menu-item-label) + (get-show-menu) + (λ (_1 _2) + (toggle-show/hide-definitions) + (update-shown)) + #\d + (string-constant definitions-menu-item-help-string))) + (set! interactions-item + (make-object menu:can-restore-menu-item% + (string-constant show-interactions-menu-item-label) + (get-show-menu) + (λ (_1 _2) + (toggle-show/hide-interactions) + (update-shown)) + #\e + (string-constant interactions-menu-item-help-string))) + + (new menu:can-restore-menu-item% + (shortcut #\u) + (label + (if (delegated-text-shown?) + (string-constant hide-overview) + (string-constant show-overview))) + (parent (get-show-menu)) + (callback + (λ (menu evt) + (if (delegated-text-shown?) + (begin + (send menu set-label (string-constant show-overview)) + (preferences:set 'framework:show-delegate? #f) + (hide-delegated-text)) + (begin + (send menu set-label (string-constant hide-overview)) + (preferences:set 'framework:show-delegate? #t) + (show-delegated-text)))))) + + (set! module-browser-menu-item + (new menu:can-restore-menu-item% + (label (if module-browser-shown? + (string-constant hide-module-browser) + (string-constant show-module-browser))) + (parent (get-show-menu)) + (callback + (λ (menu evt) + (if module-browser-shown? + (hide-module-browser) + (show-module-browser)))))) + + (set! toolbar-menu (new menu% + [parent show-menu] + [label (string-constant toolbar)])) + (set! toolbar-left-menu-item + (new checkable-menu-item% + [label (string-constant toolbar-on-left)] + [parent toolbar-menu] + [callback (λ (x y) (set-toolbar-left))] + [checked #f])) + (set! toolbar-top-menu-item + (new checkable-menu-item% + [label (string-constant toolbar-on-top)] + [parent toolbar-menu] + [callback (λ (x y) (set-toolbar-top))] + [checked #f])) + (set! toolbar-right-menu-item + (new checkable-menu-item% + [label (string-constant toolbar-on-right)] + [parent toolbar-menu] + [callback (λ (x y) (set-toolbar-right))] + [checked #f])) + (set! toolbar-hidden-menu-item + (new checkable-menu-item% + [label (string-constant toolbar-hidden)] + [parent toolbar-menu] + [callback (λ (x y) (set-toolbar-hidden))] + [checked #f])) + + (set! logger-menu-item + (new menu-item% + [label (string-constant show-log)] + [parent show-menu] + [callback + (λ (x y) (send current-tab toggle-log))])) + ) + + + ; + ; + ; + ; ; ; ; + ; ; ; ; + ; ; ; ; + ; ; ;; ;; ;;; ;; ; ; ; ; ;;; ; ;; ; ; ;;; ; ; ; ;;; ;;; ; ; + ; ;; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ;; ;;;;;; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; + ; ; ; ; ;;; ;; ; ;; ; ; ;;;; ; ;; ; ;;; ; ; ;;; ;;;; ; + ; + ; + ; + + + (field [module-browser-shown? #f] + [module-browser-parent-panel #f] + [module-browser-panel #f] + [module-browser-ec #f] + [module-browser-button #f] + [module-browser-lib-path-check-box #f] + [module-browser-planet-path-check-box #f] + [module-browser-name-length-choice #f] + [module-browser-pb #f] + [module-browser-menu-item 'module-browser-menu-item-unset]) + + (inherit open-status-line close-status-line update-status-line) + + (define/private (show-module-browser) + (when module-browser-panel + (when (can-browse-language?) + (set! module-browser-shown? #t) + (send module-browser-menu-item set-label (string-constant hide-module-browser)) + (update-module-browser-pane)))) + + (define/private (hide-module-browser) + (when module-browser-panel + (set! module-browser-shown? #f) + (send module-browser-menu-item set-label (string-constant show-module-browser)) + (close-status-line 'plt:module-browser:mouse-over) + (send module-browser-parent-panel change-children + (λ (l) + (remq module-browser-panel l))))) + + (define/private (can-browse-language?) + (let* ([lang/config (send (get-definitions-text) get-next-settings)] + [lang (drracket:language-configuration:language-settings-language lang/config)] + [strs (send lang get-language-position)] + [can-browse? + (or (is-a? lang drracket:module-language:module-language<%>) + (ormap (λ (x) (regexp-match #rx"PLT" x)) + strs))]) + (unless can-browse? + (message-box (string-constant drscheme) + (string-constant module-browser-only-in-plt-and-module-langs))) + can-browse?)) + + (define/private (update-module-browser-pane) + (open-status-line 'plt:module-browser:mouse-over) + (send module-browser-panel begin-container-sequence) + (unless module-browser-ec + (set! module-browser-pb + (drracket:module-overview:make-module-overview-pasteboard + #t + (λ (x) (mouse-currently-over x)))) + (set! module-browser-ec (make-object editor-canvas% + module-browser-panel + module-browser-pb)) + + (let* ([show-callback + (λ (cb key) + (if (send cb get-value) + (send module-browser-pb show-visible-paths key) + (send module-browser-pb remove-visible-paths key)) + (preferences:set 'drracket:module-browser:hide-paths (send module-browser-pb get-hidden-paths)))] + [mk-checkbox + (λ (key label) + (new check-box% + (parent module-browser-panel) + (label label) + (value (not (memq key (preferences:get 'drracket:module-browser:hide-paths)))) + (callback + (λ (cb _) + (show-callback cb key)))))]) + (set! module-browser-lib-path-check-box (mk-checkbox 'lib show-lib-paths)) + (set! module-browser-planet-path-check-box (mk-checkbox 'planet show-planet-paths))) + + (set! module-browser-name-length-choice + (new choice% + (parent module-browser-panel) + (label (string-constant module-browser-name-length)) + (choices (list (string-constant module-browser-name-short) + (string-constant module-browser-name-medium) + (string-constant module-browser-name-long) + (string-constant module-browser-name-very-long))) + (selection (preferences:get 'drracket:module-browser:name-length)) + (callback + (λ (x y) + (let ([selection (send module-browser-name-length-choice get-selection)]) + (preferences:set 'drracket:module-browser:name-length selection) + (update-module-browser-name-length selection)))))) + (update-module-browser-name-length + (preferences:get 'drracket:module-browser:name-length)) + + (set! module-browser-button + (new button% + (parent module-browser-panel) + (label refresh) + (callback (λ (x y) (update-module-browser-pane))) + (stretchable-width #t)))) + + (let ([p (preferences:get 'drracket:module-browser-size-percentage)]) + (send module-browser-parent-panel change-children + (λ (l) + (cons module-browser-panel + (remq module-browser-panel l)))) + (with-handlers ([exn:fail? void]) + (send module-browser-parent-panel set-percentages (list p (- 1 p)))) + (send module-browser-parent-panel end-container-sequence) + (calculate-module-browser))) + + (define/private (update-module-browser-name-length i) + (send module-browser-pb set-name-length + (case i + [(0) 'short] + [(1) 'medium] + [(2) 'long] + [(3) 'very-long]))) + + (define/private (mouse-currently-over snips) + (if (null? snips) + (update-status-line 'plt:module-browser:mouse-over #f) + (let* ([snip (car snips)] + [lines (send snip get-lines)] + [name (or (send snip get-filename) + (send snip get-word))] + [str (if lines + (format (string-constant module-browser-filename-format) name lines) + name)]) + (update-status-line 'plt:module-browser:mouse-over str)))) + + (define/private (calculate-module-browser) + (let ([mod-tab current-tab]) + (let-values ([(old-break-thread old-custodian) (send mod-tab get-breakables)]) + (open-status-line 'plt:module-browser) + (update-status-line 'plt:module-browser status-compiling-definitions) + (send module-browser-button enable #f) + (send module-browser-lib-path-check-box enable #f) + (send module-browser-planet-path-check-box enable #f) + (send module-browser-name-length-choice enable #f) + (disable-evaluation-in-tab current-tab) + (drracket:module-overview:fill-pasteboard + module-browser-pb + (drracket:language:make-text/pos + definitions-text + 0 + (send definitions-text last-position)) + (λ (str) (update-status-line + 'plt:module-browser + (format module-browser-progress-constant str))) + (λ (user-thread user-custodian) + (send mod-tab set-breakables user-thread user-custodian))) + (send mod-tab set-breakables old-break-thread old-custodian) + (send mod-tab enable-evaluation) + (send module-browser-button enable #t) + (send module-browser-lib-path-check-box enable #t) + (send module-browser-planet-path-check-box enable #t) + (send module-browser-name-length-choice enable #t) + (close-status-line 'plt:module-browser)))) + + ;; set-directory : text -> void + ;; sets the current-directory and current-load-relative-directory + ;; based on the file saved in the definitions-text + (define/private (set-directory definitions-text) + (let* ([tmp-b (box #f)] + [fn (send definitions-text get-filename tmp-b)]) + (unless (unbox tmp-b) + (when fn + (let-values ([(base name dir?) (split-path fn)]) + (current-directory base) + (current-load-relative-directory base)))))) + + + ; + ; + ; + ; + ; + ; + ; ; ;; ;; ;;; ; ;; ; ; ;;; + ; ;; ;; ; ; ; ;; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ;; + ; ; ; ; ;;;;;; ; ; ; ; ;; + ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ;; ; + ; ; ; ; ;;;; ; ; ;; ; ;;; + ; + ; + ; + + (define execute-menu-item #f) + (define file-menu:print-interactions-item #f) + (define file-menu:create-new-tab-item #f) + + (define/override (file-menu:between-new-and-open file-menu) + (set! file-menu:create-new-tab-item + (new menu:can-restore-menu-item% + (label (string-constant new-tab)) + (shortcut #\=) + (parent file-menu) + (callback + (λ (x y) + (create-new-tab)))))) + [define/override file-menu:between-open-and-revert + (lambda (file-menu) + (super file-menu:between-open-and-revert file-menu) + (make-object separator-menu-item% file-menu))] + (define close-tab-menu-item #f) + (define/override (file-menu:between-close-and-quit file-menu) + (set! close-tab-menu-item + (new (get-menu-item%) + (label (string-constant close-tab)) + (demand-callback + (λ (item) + (send item enable (1 . < . (send tabs-panel get-number))))) + (parent file-menu) + (callback + (λ (x y) + (close-current-tab))))) + (super file-menu:between-close-and-quit file-menu)) + + (define/override (file-menu:save-string) (string-constant save-definitions)) + (define/override (file-menu:save-as-string) (string-constant save-definitions-as)) + (define/override (file-menu:between-save-as-and-print file-menu) + (let ([sub-menu (make-object menu% (string-constant save-other) file-menu)]) + (make-object menu:can-restore-menu-item% + (string-constant save-definitions-as-text) + sub-menu + (λ (_1 _2) + (let ([filename (send definitions-text put-file #f #f)]) + (when filename + (send definitions-text save-file/gui-error filename 'text))))) + (make-object menu:can-restore-menu-item% + (string-constant save-interactions) + sub-menu + (λ (_1 _2) + (send interactions-text save-file/gui-error))) + (make-object menu:can-restore-menu-item% + (string-constant save-interactions-as) + sub-menu + (λ (_1 _2) + (let ([filename (send interactions-text put-file #f #f)]) + (when filename + (send interactions-text save-file/gui-error filename 'standard))))) + (make-object menu:can-restore-menu-item% + (string-constant save-interactions-as-text) + sub-menu + (λ (_1 _2) + (let ([filename (send interactions-text put-file #f #f)]) + (when filename + (send interactions-text save-file/gui-error filename 'text))))) + (make-object separator-menu-item% file-menu) + (set! transcript-menu-item + (make-object menu:can-restore-menu-item% + (string-constant log-definitions-and-interactions) + file-menu + (λ (x y) + (if transcript + (stop-transcript) + (start-transcript))))) + (make-object separator-menu-item% file-menu) + (super file-menu:between-save-as-and-print file-menu))) + + [define/override file-menu:print-string (λ () (string-constant print-definitions))] + (define/override (file-menu:between-print-and-close file-menu) + (set! file-menu:print-interactions-item + (make-object menu:can-restore-menu-item% + (string-constant print-interactions) + file-menu + (λ (_1 _2) + (send interactions-text print + #t + #t + (preferences:get 'framework:print-output-mode))))) + (super file-menu:between-print-and-close file-menu)) + + (define/override (edit-menu:between-find-and-preferences edit-menu) + (super edit-menu:between-find-and-preferences edit-menu) + (new menu:can-restore-menu-item% + [label (string-constant complete-word)] + [shortcut #\/] + [parent edit-menu] + [demand-callback + (λ (mi) + (send mi enable + (let ([ed (get-edit-target-object)]) + (and ed + (is-a? ed text:autocomplete<%>)))))] + [callback (λ (x y) + (send (get-edit-target-object) auto-complete))]) + (add-modes-submenu edit-menu)) + + (define/override (edit-menu:between-select-all-and-find edit-menu) + (new menu:can-restore-checkable-menu-item% + [label (string-constant overwrite-mode)] + [parent edit-menu] + [demand-callback + (λ (mi) + (let ([target (get-edit-target-object)]) + (send mi enable (is-a? target text%)) + (when (is-a? target text%) + (send mi check (and target (send target get-overwrite-mode))))))] + [callback (λ (x y) + (let ([target (get-edit-target-object)]) + (send target set-overwrite-mode + (not (send target get-overwrite-mode)))))]) + (super edit-menu:between-select-all-and-find edit-menu)) + + ;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key))) + (define capability-menu-items (make-hasheq)) + (define/public (register-capability-menu-item key menu) + (let ([items (send menu get-items)]) + (when (null? items) + (error 'register-capability-menu-item "menu ~e has no items" menu)) + (let* ([menu-item (last items)] + [this-one (list menu-item (- (length items) 1) key)] + [old-ones (hash-ref capability-menu-items menu (λ () '()))]) + (hash-set! capability-menu-items menu (cons this-one old-ones))))) + + (define/private (update-items/capability menu) + (let* ([old-items (send menu get-items)] + [new-items (begin '(get-items/capability menu) + old-items)]) + (unless (equal? old-items new-items) + (for-each (λ (i) (send i delete)) old-items) + (for-each (λ (i) (send i restore)) new-items)))) + (define/private (get-items/capability menu) + (let loop ([capability-items (reverse (hash-ref capability-menu-items menu '()))] + [all-items (send menu get-items)] + [i 0]) + (cond + [(null? capability-items) all-items] + [(pair? capability-items) + (let* ([cap-item-list (car capability-items)] + [cap-item (list-ref cap-item-list 0)] + [cap-num (list-ref cap-item-list 1)] + [cap-key (list-ref cap-item-list 2)]) + (cond + [(= cap-num i) + (let ([is-on? (get-current-capability-value cap-key)]) + (cond + [is-on? + (cond + [(null? all-items) + (cons cap-item (loop (cdr capability-items) null (+ i 1)))] + [(pair? all-items) + (if (eq? (car all-items) cap-item) + (cons cap-item (loop (cdr capability-items) (cdr all-items) (+ i 1))) + (cons cap-item (loop (cdr capability-items) all-items (+ i 1))))])] + [else + (cond + [(null? all-items) + (loop (cdr capability-items) null (+ i 1))] + [(pair? all-items) + (if (eq? (car all-items) cap-item) + (loop (cdr capability-items) (cdr all-items) (+ i 1)) + (loop (cdr capability-items) all-items (+ i 1)))])]))] + [else (cons (car all-items) + (loop capability-items + (cdr all-items) + (+ i 1)))]))]))) + + (define/private (get-current-capability-value key) + (let* ([language-settings (send (get-definitions-text) get-next-settings)] + [new-language (drracket:language-configuration:language-settings-language language-settings)]) + (send new-language capability-value key))) + + (define language-menu 'uninited-language-menu) + (define language-specific-menu 'language-specific-menu-not-yet-init) + (define insert-menu 'insert-menu-not-yet-init) + (define/public (get-insert-menu) insert-menu) + (define/public (get-special-menu) insert-menu) + + (define/public (choose-language-callback) + (let ([new-settings (drracket:language-configuration:language-dialog + #f + (send definitions-text get-next-settings) + this)]) + (when new-settings + (send definitions-text set-next-settings new-settings)))) + + ;; must be called from on-demand (on each menu click), or the state won't be handled properly + (define/private (update-teachpack-menu) + (for-each (λ (item) (send item delete)) teachpack-items) + (let ([tp-callbacks (get-current-capability-value 'drscheme:teachpack-menu-items)]) + (cond + [tp-callbacks + (let* ([language (drracket:language-configuration:language-settings-language + (send (get-definitions-text) get-next-settings))] + [settings (drracket:language-configuration:language-settings-settings + (send (get-definitions-text) get-next-settings))] + [tp-names ((teachpack-callbacks-get-names tp-callbacks) settings)] + [update-settings + (λ (settings) + (send (get-definitions-text) set-next-settings + (drracket:language-configuration:language-settings language settings)) + (send (get-definitions-text) teachpack-changed))]) + (set! teachpack-items + (list* + (make-object separator-menu-item% language-menu) + (new menu:can-restore-menu-item% + [label (string-constant add-teachpack-menu-item-label)] + [parent language-menu] + [callback + (λ (_1 _2) + (update-settings ((teachpack-callbacks-add tp-callbacks) settings this)))]) + (let ([mi (new menu:can-restore-menu-item% + [label (string-constant clear-all-teachpacks-menu-item-label)] + [parent language-menu] + [callback + (λ (_1 _2) + (update-settings ((teachpack-callbacks-remove-all tp-callbacks) settings)))])]) + + (send mi enable (not (null? tp-names))) + mi) + (map (λ (name) + (new menu:can-restore-menu-item% + [label (gui-utils:format-literal-label (string-constant clear-teachpack) name)] + [parent language-menu] + [callback + (λ (item evt) + (update-settings ((teachpack-callbacks-remove tp-callbacks) settings name)))])) + tp-names))))] + [else + (set! teachpack-items + (list + (new menu:can-restore-menu-item% + [label (string-constant add-teachpack-menu-item-label)] + [parent language-menu] + [callback + (λ (_1 _2) + (message-box (string-constant drscheme) + (gui-utils:format-literal-label (string-constant teachpacks-only-in-languages) + (apply + string-append + (reverse + (filter + values + (map (λ (l) + (and + (send l capability-value 'drscheme:teachpack-menu-items) + (format "\n ~a" (send l get-language-name)))) + (drracket:language-configuration:get-languages)))))) + this))])))]))) + + (define/private (initialize-menus) + (let* ([mb (get-menu-bar)] + [language-menu-on-demand (λ (menu-item) (update-teachpack-menu))] + [_ (set! language-menu (make-object (get-menu%) + (string-constant language-menu-name) + mb + #f + language-menu-on-demand))] + [_ (set! language-specific-menu (new (get-menu%) + [label (drracket:language:get-capability-default + 'drscheme:language-menu-title)] + [parent mb]))] + [send-method + (λ (method) + (λ (_1 _2) + (let ([text (get-focus-object)]) + (when (is-a? text scheme:text<%>) + (method text)))))] + [show/hide-capability-menus + (λ () + (for-each (λ (menu) (update-items/capability menu)) + (send (get-menu-bar) get-items)))]) + + (make-object menu:can-restore-menu-item% + (string-constant choose-language-menu-item-label) + language-menu + (λ (_1 _2) (choose-language-callback)) + #\l) + + (set! execute-menu-item + (make-object menu:can-restore-menu-item% + (string-constant execute-menu-item-label) + language-specific-menu + (λ (_1 _2) (execute-callback)) + #\t + (string-constant execute-menu-item-help-string))) + (make-object menu:can-restore-menu-item% + (string-constant ask-quit-menu-item-label) + language-specific-menu + (λ (_1 _2) (send current-tab break-callback)) + #\b + (string-constant ask-quit-menu-item-help-string)) + (make-object menu:can-restore-menu-item% + (string-constant force-quit-menu-item-label) + language-specific-menu + (λ (_1 _2) (send interactions-text kill-evaluation)) + #\k + (string-constant force-quit-menu-item-help-string)) + (when (custodian-memory-accounting-available?) + (new menu-item% + [label (string-constant limit-memory-menu-item-label)] + [parent language-specific-menu] + [callback + (λ (item b) + (let ([num (get-mbytes this + (let ([limit (send interactions-text get-custodian-limit)]) + (and limit + (floor (/ limit 1024 1024)))))]) + (when num + (cond + [(eq? num #t) + (preferences:set 'drracket:child-only-memory-limit #f) + (send interactions-text set-custodian-limit #f)] + [else + (preferences:set 'drracket:child-only-memory-limit + (* 1024 1024 num)) + (send interactions-text set-custodian-limit + (* 1024 1024 num))]))))])) + (new menu:can-restore-menu-item% + (label (string-constant clear-error-highlight-menu-item-label)) + (parent language-specific-menu) + (callback + (λ (_1 _2) + (let* ([tab (get-current-tab)] + [ints (send tab get-ints)] + [defs (send tab get-defs)]) + (send ints reset-error-ranges) + (send defs clear-test-coverage)))) + (help-string (string-constant clear-error-highlight-item-help-string)) + (demand-callback + (λ (item) + (let* ([tab (get-current-tab)] + [ints (send tab get-ints)]) + (send item enable (or (send ints get-error-ranges) + (send tab get-test-coverage-info-visible?))))))) + (make-object separator-menu-item% language-specific-menu) + (make-object menu:can-restore-menu-item% + (string-constant create-executable-menu-item-label) + language-specific-menu + (λ (x y) (create-executable this))) + (make-object menu:can-restore-menu-item% + (string-constant module-browser...) + language-specific-menu + (λ (x y) (drracket:module-overview:module-overview this))) + (let () + (define base-title (format (string-constant module-browser-in-file) "")) + (define (update-menu-item i) + (define fn (send definitions-text get-filename)) + (send i set-label + (if fn + (let* ([str (path->string fn)] + [overage (- 200 + (+ (string-length str) + (string-length base-title)))]) + (format (string-constant module-browser-in-file) + (if (overage . >= . 0) + str + (string-append "..." + (substring str + (+ (- (string-length str) (abs overage)) 3) + (string-length str)))))) + (string-constant module-browser-no-file))) + (send i enable fn)) + (define i (new menu:can-restore-menu-item% + [label base-title] + [parent language-specific-menu] + [demand-callback update-menu-item] + [callback (λ (x y) + (define fn (send definitions-text get-filename)) + (when fn + (drracket:module-overview:module-overview/file fn this)))])) + (update-menu-item i)) + (make-object separator-menu-item% language-specific-menu) + + (let ([cap-val + (λ () + (let* ([tab (get-current-tab)] + [defs (send tab get-defs)] + [settings (send defs get-next-settings)] + [language (drracket:language-configuration:language-settings-language settings)]) + (send language capability-value 'drscheme:tabify-menu-callback)))]) + (new menu:can-restore-menu-item% + [label (string-constant reindent-menu-item-label)] + [parent language-specific-menu] + [demand-callback (λ (m) (send m enable (cap-val)))] + [callback (send-method + (λ (x) + (let ([f (cap-val)]) + (when f + (f x + (send x get-start-position) + (send x get-end-position))))))]) + + (new menu:can-restore-menu-item% + [label (string-constant reindent-all-menu-item-label)] + [parent language-specific-menu] + [callback + (send-method + (λ (x) + (let ([f (cap-val)]) + (when f + (f x 0 (send x last-position))))))] + [shortcut #\i] + [demand-callback (λ (m) (send m enable (cap-val)))])) + + (make-object menu:can-restore-menu-item% + (string-constant box-comment-out-menu-item-label) + language-specific-menu + (send-method (λ (x) (send x box-comment-out-selection)))) + (make-object menu:can-restore-menu-item% + (string-constant semicolon-comment-out-menu-item-label) + language-specific-menu + (send-method (λ (x) (send x comment-out-selection)))) + (make-object menu:can-restore-menu-item% + (string-constant uncomment-menu-item-label) + language-specific-menu + (λ (x y) + (let ([text (get-focus-object)]) + (when (is-a? text text%) + (let ([admin (send text get-admin)]) + (cond + [(is-a? admin editor-snip-editor-admin<%>) + (let ([es (send admin get-snip)]) + (cond + [(is-a? es comment-box:snip%) + (let ([es-admin (send es get-admin)]) + (when es-admin + (let ([ed (send es-admin get-editor)]) + (when (is-a? ed scheme:text<%>) + (send ed uncomment-box/selection)))))] + [else (send text uncomment-selection)]))] + [else (send text uncomment-selection)])))))) + + (set! insert-menu + (new (get-menu%) + [label (string-constant insert-menu)] + [parent mb] + [demand-callback + (λ (insert-menu) + ;; just here for convience -- it actually works on all menus, not just the special menu + (show/hide-capability-menus))])) + + (let ([has-editor-on-demand + (λ (menu-item) + (let ([edit (get-edit-target-object)]) + (send menu-item enable (and edit (is-a? edit editor<%>)))))] + [callback + (λ (menu evt) + (let ([edit (get-edit-target-object)]) + (when (and edit + (is-a? edit editor<%>)) + (let ([number (get-fraction-from-user this)]) + (when number + (send edit insert + (number-snip:make-fraction-snip number #f))))) + #t))] + [insert-lambda + (λ () + (let ([edit (get-edit-target-object)]) + (when (and edit + (is-a? edit editor<%>)) + (send edit insert "\u03BB"))) + #t)] + [insert-large-semicolon-letters + (λ () + (let ([edit (get-edit-target-object)]) + (when edit + (let ([language-settings (send definitions-text get-next-settings)]) + (let-values ([(comment-prefix comment-character) + (if language-settings + (send (drracket:language-configuration:language-settings-language + language-settings) + get-comment-character) + (values ";" #\;))]) + (insert-large-letters comment-prefix comment-character edit this))))))] + [c% (get-menu-item%)]) + + (frame:add-snip-menu-items + insert-menu + c% + (λ (item) + (let ([label (send item get-label)]) + (cond + [(equal? label (string-constant insert-comment-box-menu-item-label)) + (register-capability-menu-item 'drscheme:special:insert-comment-box insert-menu)] + [(equal? label (string-constant insert-image-item)) + (register-capability-menu-item 'drscheme:special:insert-image insert-menu)])))) + + (make-object c% (string-constant insert-fraction-menu-item-label) + insert-menu callback + #f #f + has-editor-on-demand) + (register-capability-menu-item 'drscheme:special:insert-fraction insert-menu) + + (make-object c% (string-constant insert-large-letters...) + insert-menu + (λ (x y) (insert-large-semicolon-letters)) + #f #f + has-editor-on-demand) + (register-capability-menu-item 'drscheme:special:insert-large-letters insert-menu) + + (make-object c% (string-constant insert-lambda) + insert-menu + (λ (x y) (insert-lambda)) + #\\ + #f + has-editor-on-demand) + (register-capability-menu-item 'drscheme:special:insert-lambda insert-menu)) + + (new menu:can-restore-menu-item% + [label (if (show-line-numbers?) + (string-constant hide-line-numbers/menu) + (string-constant show-line-numbers/menu))] + [parent (get-show-menu)] + [callback (lambda (self event) + (define value (preferences:get 'drracket:show-line-numbers?)) + (send self set-label + (if value + (string-constant show-line-numbers/menu) + (string-constant hide-line-numbers/menu))) + (preferences:set 'drracket:show-line-numbers? (not value)) + (show-line-numbers! (not value)))]) + + (make-object separator-menu-item% (get-show-menu)) + + (new menu:can-restore-menu-item% + (shortcut (if (eq? (system-type) 'macosx) #f #\m)) + (label (string-constant split-menu-item-label)) + (parent (get-show-menu)) + (callback (λ (x y) (split))) + (demand-callback (λ (item) (split-demand item)))) + (new menu:can-restore-menu-item% + (shortcut (if (eq? (system-type) 'macosx) #f #\m)) + (shortcut-prefix (if (eq? (system-type) 'macosx) + (get-default-shortcut-prefix) + (cons 'shift (get-default-shortcut-prefix)))) + (label (string-constant collapse-menu-item-label)) + (parent (get-show-menu)) + (callback (λ (x y) (collapse))) + (demand-callback (λ (item) (collapse-demand item)))) + + (frame:reorder-menus this))) + + ; + ; + ; + ; + ; ++-@@- -+@+- +++: :++ + ; +@@-+@ -@-:-@--@- -@ + ; :@: @: @+ ++ @::@::@ + ; :@ @: @@@@@@@ +--@--* + ; :@ @: @- -@+*+@: + ; -@: :@- +@:::+@ :@@:@@ + ; @@@ +@@: +@@@+: ++ ++ + ; + ; + ; + + (define definitions-text (new (drracket:get/extend:get-definitions-text))) + + ;; tabs : (listof tab) + (define tabs (list (new (drracket:get/extend:get-tab) + (defs definitions-text) + (frame this) + (i 0) + (defs-shown? #t) + (ints-shown? #t)))) + (define/public-final (get-tabs) tabs) + + ;; current-tab : tab + ;; corresponds to the tabs-panel's active button. + (define current-tab (car tabs)) + + (define interactions-text (new (drracket:get/extend:get-interactions-text) + (context (car tabs)))) + (send (car tabs) set-ints interactions-text) + + (init-definitions-text (car tabs)) + + (super-new + [filename filename] + [style '(toolbar-button)] + [size-preferences-key 'drracket:unit-window-size] + [position-preferences-key 'drracket:unit-window-position]) + + (initialize-menus) + + + ; + ; + ; + ; ; ; + ; ; ; + ; ; ; ; + ; ; ;; ;;; ; ;; ;;; ; ; ;;; ; ; ;;; ; ; ;;;; + ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;; ; ; ;;;;;; ; ; ;;;; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; + ; ; ;; ;;;;; ; ; ;;;; ; ; ;;;;; ; ;;; ;; ; ;; + ; ; ; + ; ; ; + ; ; ; + + + (define toolbar/rest-panel (new vertical-panel% [parent (get-area-container)])) + + ;; most contain only top-panel (or nothing) + (define top-outer-panel (new horizontal-panel% + [parent toolbar/rest-panel] + [alignment '(right top)] + [stretchable-height #f])) + + [define top-panel (make-object horizontal-panel% top-outer-panel)] + [define name-panel (new horizontal-panel% + (parent top-panel) + (alignment '(left center)) + (stretchable-width #f) + (stretchable-height #f))] + (define panel-with-tabs (new vertical-panel% + (parent (get-definitions/interactions-panel-parent)))) + (define tabs-panel (new tab-panel% + (font small-control-font) + (parent panel-with-tabs) + (stretchable-height #f) + (style '(deleted no-border)) + (choices '("first name")) + (callback (λ (x y) + (let ([sel (send tabs-panel get-selection)]) + (when sel + (change-to-nth-tab sel))))))) + [define resizable-panel (new (if (preferences:get 'drracket:defs/ints-horizontal) + horizontal-dragable/def-int% + vertical-dragable/def-int%) + (unit-frame this) + (parent panel-with-tabs))] + [define orientation-callback (λ (p v) (send resizable-panel set-orientation v))] + (preferences:add-callback 'drracket:defs/ints-horizontal orientation-callback #t) + + [define definitions-canvas #f] + (initialize-definitions-canvas) + [define definitions-canvases (list definitions-canvas)] + [define interactions-canvas (new (drracket:get/extend:get-interactions-canvas) + (parent resizable-panel) + (editor interactions-text))] + [define interactions-canvases (list interactions-canvas)] + + + (define/public (get-definitions-canvases) + ;; before definition, just return null + (if (pair? definitions-canvases) + definitions-canvases + null)) + (define/public (get-interactions-canvases) + ;; before definition, just return null + (if (pair? interactions-canvases) + interactions-canvases + null)) + + (public get-definitions-canvas get-interactions-canvas) + [define get-definitions-canvas (λ () definitions-canvas)] + [define get-interactions-canvas (λ () interactions-canvas)] + + (set! save-button + (new switchable-button% + [parent top-panel] + [callback (λ (x) (when definitions-text + (save) + (send definitions-canvas focus)))] + [bitmap save-bitmap] + [label (string-constant save-button-label)])) + (register-toolbar-button save-button) + + (set! name-message (new drs-name-message% [parent name-panel])) + (send name-message stretchable-width #t) + (send name-message set-allow-shrinking 200) + [define teachpack-items null] + [define break-button (void)] + [define execute-button (void)] + [define button-panel (new horizontal-panel% [parent top-panel] [spacing 2])] + (define/public (get-execute-button) execute-button) + (define/public (get-break-button) break-button) + (define/public (get-button-panel) button-panel) + + (inherit get-info-panel) + + (define color-status-canvas + (and checkout-or-nightly? + (let () + (define on-string "()") + (define color-status-canvas + (new canvas% + [parent (get-info-panel)] + [style '(transparent)] + [stretchable-width #f] + [paint-callback + (λ (c dc) + (when (number? th) + (unless color-valid? + (let-values ([(cw ch) (send c get-client-size)]) + (send dc set-font small-control-font) + (send dc draw-text on-string 0 (- (/ ch 2) (/ th 2)))))))])) + (define-values (tw th ta td) (send (send color-status-canvas get-dc) get-text-extent on-string small-control-font)) + (send color-status-canvas min-width (inexact->exact (ceiling tw))) + color-status-canvas))) + (define color-valid? #t) + (define/public (set-color-status! v?) + (when color-status-canvas + (set! color-valid? v?) + (send color-status-canvas refresh-now))) + + (define running-canvas + (new running-canvas% [parent (get-info-panel)])) + + (define bug-icon + (let* ([info-panel (get-info-panel)] + [btn + (new switchable-button% + [parent info-panel] + [callback (λ (x) (show-saved-bug-reports-window))] + [bitmap very-small-planet-bitmap] + [vertical-tight? #t] + [label (string-constant show-planet-contract-violations)])]) + (send btn set-label-visible #f) + (send info-panel change-children + (λ (l) + (cons btn (remq* (list btn) l)))) + btn)) + (define/private (set-bug-label v) + (if (null? v) + (send bug-icon show #f) + (send bug-icon show #t))) + (set-bug-label (preferences:get 'drracket:saved-bug-reports)) + (define remove-bug-icon-callback + (preferences:add-callback + 'drracket:saved-bug-reports + (λ (p v) + (set-bug-label v)))) + + [define func-defs-canvas (new func-defs-canvas% + (parent name-panel) + (frame this))] + + (set! execute-button + (new switchable-button% + [parent button-panel] + [callback (λ (x) (execute-callback))] + [bitmap execute-bitmap] + [label (string-constant execute-button-label)])) + (register-toolbar-button execute-button) + + (set! break-button + (new switchable-button% + [parent button-panel] + [callback (λ (x) (send current-tab break-callback))] + [bitmap break-bitmap] + [label (string-constant break-button-label)])) + (register-toolbar-button break-button) + + (send button-panel stretchable-height #f) + (send button-panel stretchable-width #f) + + (send top-panel change-children + (λ (l) + (list name-panel save-button + (make-object vertical-panel% top-panel) ;; spacer + button-panel))) + + (send top-panel stretchable-height #f) + (inherit get-label) + (let ([m (send definitions-canvas get-editor)]) + (set-save-init-shown? + (and m (send m is-modified?)))) + + (define language-message + (let* ([info-panel (get-info-panel)] + [p (new vertical-panel% + [parent info-panel] + [alignment '(left center)])] + [language-message (new language-label-message% [parent p] [frame this])]) + (send info-panel change-children + (λ (l) + (list* p + (remq* (list p) + l)))) + language-message)) + + (update-save-message) + (update-save-button) + (language-changed) + + (cond + [filename + (set! definitions-shown? #t) + (set! interactions-shown? #f)] + [else + (set! definitions-shown? #t) + (set! interactions-shown? #t)]) + + (update-shown) + + (when (= 2 (length (send resizable-panel get-children))) + (send resizable-panel set-percentages + (let ([p (preferences:get 'drracket:unit-window-size-percentage)]) + (list p (- 1 p))))) + + (set-label-prefix (string-constant drscheme)) + (set! newest-frame this) + ;; a callback might have happened that initializes set-color-status! before the + ;; definitions text is connected to the frame, so we do an extra initialization + ;; now, once we know we have the right connection + (set-color-status! (send definitions-text is-lexer-valid?)) + (send definitions-canvas focus))) + + ;; get-define-popup-name : (or/c #f (cons/c string? string?) (list/c string? string? string)) boolean -> (or/c #f string?) + (define (get-define-popup-name info vertical?) + (and info + (if vertical? + (if (pair? (cdr info)) + (list-ref info 2) + "δ") + (if (pair? (cdr info)) + (list-ref info 1) + (cdr info))))) + + + (define execute-warning-canvas% + (class canvas% + (inherit stretchable-height get-dc get-client-size min-height) + (init-field message) + (define/public (set-message _msg) (set! message _msg)) + + (define/override (on-paint) + (let ([dc (get-dc)]) + (let-values ([(w h) (get-client-size)]) + (send dc set-pen "yellow" 1 'solid) + (send dc set-brush "yellow" 'solid) + (send dc draw-rectangle 0 0 w h) + (when message + (let* ([base normal-control-font] + [face (send base get-face)]) + (if face + (send dc set-font (send the-font-list find-or-create-font + (send base get-point-size) + face + (send base get-family) + (send base get-style) + 'bold)) + (send dc set-font (send the-font-list find-or-create-font + (send base get-point-size) + (send base get-family) + (send base get-style) + 'bold)))) + (let-values ([(tw th _1 _2) (send dc get-text-extent message)]) + (send dc draw-text message + (floor (- (/ w 2) (/ tw 2))) + (floor (- (/ h 2) (/ th 2))))))))) + (super-new [style '(no-focus)]) + (let-values ([(w h d a) (send (get-dc) get-text-extent "Xy")]) + (min-height (+ 4 (floor (inexact->exact h))))))) + + + ; + ; + ; + ; + ; ;;; + ; + ; ;;; ;;;; ;;; ;;; ;; ;;; ;; ;;; ;;; ;; ;; ;;; + ; ;;;;;;;; ;;; ;;;;;;; ;;;;;;; ;;; ;;;;;;; ;;;;;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; + ; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; + ; ;;; + ; ;;;;;; + ; + ; + + + (define running-bitmap (include-bitmap (lib "icons/b-run.png"))) + (define waiting-bitmap (include-bitmap (lib "icons/b-wait.png"))) + (define waiting2-bitmap (include-bitmap (lib "icons/b-wait2.png"))) + (define running/waiting-bitmaps (list running-bitmap waiting-bitmap waiting2-bitmap)) + (define running-canvas% + (class canvas% + (inherit get-dc refresh get-client-size) + (define/public (set-running r?) + (unless (eq? r? is-running?) + (set! is-running? r?) + (refresh))) + (define is-running? #f) + (define toggle? #t) + (define timer #f) + (define inside? #f) + + (define/override (on-event evt) + (let-values ([(w h) (get-client-size)]) + (let ([new-inside? + (and (< 0 (send evt get-x) w) + (< 0 (send evt get-y) h))] + [old-inside? inside?]) + (set! inside? new-inside?) + (cond + [(and new-inside? (not old-inside?)) + (unless is-running? + (set! timer + (new timer% + [notify-callback + (λ () + (set! toggle? (not toggle?)) + (refresh))] + [interval 200])))] + [(and (not new-inside?) old-inside? timer) + (send timer stop) + (set! timer #f)])))) + + (define/override (on-paint) + (let ([dc (get-dc)] + [bm + (if is-running? + running-bitmap + (if toggle? + waiting-bitmap + waiting2-bitmap))]) + (let-values ([(cw ch) (get-client-size)]) + (send dc draw-bitmap bm + (- (/ cw 2) (/ (send bm get-width) 2)) + (- (/ ch 2) (/ (send bm get-height) 2)) + 'solid + (send the-color-database find-color "black") + (send bm get-loaded-mask))))) + + (super-new [stretchable-width #f] + [stretchable-height #f] + [style '(transparent no-focus)]) + (inherit min-width min-height) + (min-width (apply max (map (λ (x) (send x get-width)) running/waiting-bitmaps))) + (min-height (apply max (map (λ (x) (send x get-height)) running/waiting-bitmaps))))) + + ;; get-mbytes : top-level-window -> (union #f ;; cancel + ;; integer[>=100] ;; a limit + ;; #t) ;; no limit + (define (get-mbytes parent current-limit) + (define d (new dialog% + [label (string-constant drscheme)] + [parent parent])) + (define msg1 (new message% + [parent d] + [label (string-constant limit-memory-msg-1)])) + (define msg1.5 (new message% + [parent d] + [label (string-constant limit-memory-msg-2)])) - (define (set-box/f! b v) (when (box? b) (set-box! b v))) - -; -; -; -; -; ;;;; -; ;;; -; ;;;; ;;; ;;;;;;; ;;; ;; ;;; ;;;; -; ;;;; ;;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; -; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; -; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;; -; -; -; -; - - (define dragable/def-int-mixin - (mixin (panel:dragable<%>) () - (init-field unit-frame) - (inherit get-percentages) - (define/augment (after-percentage-change) - (let ([percentages (get-percentages)]) - (when (and (= 1 - (length (send unit-frame get-definitions-canvases)) - (length (send unit-frame get-interactions-canvases))) - (= 2 (length percentages))) - (preferences:set 'drracket:unit-window-size-percentage (car percentages)))) - (inner (void) after-percentage-change)) - (super-new))) + (define outer-hp (new horizontal-panel% [parent d] [alignment '(center bottom)])) + (define rb (new radio-box% + [label #f] + [choices (list (string-constant limit-memory-unlimited) (string-constant limit-memory-limited))] + [callback (λ (a b) (grayizie))] + [parent outer-hp])) - (define vertical-dragable/def-int% (dragable/def-int-mixin panel:vertical-dragable%)) - (define horizontal-dragable/def-int% (dragable/def-int-mixin panel:horizontal-dragable%)) + (define (grayizie) + (case (send rb get-selection) + [(0) + (send tb enable #f) + (send msg2 enable #f) + (background gray-foreground-sd)] + [(1) + (send tb enable #t) + (send msg2 enable #t) + (background black-foreground-sd) + (let ([e (send tb get-editor)]) + (send e set-position 0 (send e last-position))) + (send tb focus)]) + (update-ok-button-state)) - (define super-frame% + (define hp (new horizontal-panel% + [parent outer-hp] + [stretchable-height #f] + [stretchable-width #f])) + + (define tb + (new text-field% + [label #f] + [parent hp] + [init-value (if current-limit + (format "~a" current-limit) + "64")] + [stretchable-width #f] + [min-width 100] + [callback + (λ (tf e) + (let ([ed (send tf get-editor)]) + (cond + [(is-valid-number? ed) + (background clear-sd)] + [else + (background yellow-sd)])) + (update-ok-button-state))])) + + (define (update-ok-button-state) + (case (send rb get-selection) + [(0) (send ok-button enable #t)] + [(1) (send ok-button enable (is-valid-number? (send tb get-editor)))])) + + (define msg2 (new message% [parent hp] [label (string-constant limit-memory-megabytes)])) + (define bp (new horizontal-panel% [parent d])) + (define-values (ok-button cancel-button) + (gui-utils:ok/cancel-buttons + bp + (λ (a b) + (case (send rb get-selection) + [(0) (set! result #t)] + [(1) (set! result (string->number (send (send tb get-editor) get-text)))]) + (send d show #f)) + (λ (a b) (send d show #f)))) + + (define result #f) + + (define clear-sd (make-object style-delta%)) + (define yellow-sd (make-object style-delta%)) + + (define black-foreground-sd (make-object style-delta%)) + (define gray-foreground-sd (make-object style-delta%)) + + (define (is-valid-number? txt) + (let* ([n (string->number (send txt get-text))]) + (and n + (integer? n) + (1 . <= . n)))) + + (define (background sd) + (let ([txt (send tb get-editor)]) + (send txt change-style sd 0 (send txt last-position)))) + + (send clear-sd set-delta-background "white") + (send yellow-sd set-delta-background "yellow") + (send black-foreground-sd set-delta-foreground "black") + (send gray-foreground-sd set-delta-foreground "gray") + (send d set-alignment 'left 'center) + (send bp set-alignment 'right 'center) + (when current-limit + (send rb set-selection 1)) + (update-ok-button-state) + (grayizie) + (send tb focus) + (let ([e (send tb get-editor)]) + (send e set-position 0 (send e last-position))) + (send d show #t) + result) + + + + (define (limit-length l n) + (let loop ([l l] + [n n]) + (cond + [(or (null? l) (zero? n)) null] + [else (cons (car l) (loop (cdr l) (- n 1)))]))) + (define (remove-duplicate-languages l) + (reverse + (let loop ([l (reverse l)]) + (cond + [(null? l) l] + [else + (if (member (car (car l)) (map car (cdr l))) + (loop (cdr l)) + (cons (car l) (loop (cdr l))))])))) + + (define language-label-message% + (class name-message% + (init-field frame) + (inherit refresh) + + (inherit set-message) + (define yellow? #f) + (define/override (get-background-color) (and yellow? "yellow")) + (define/public (set-yellow y?) + (set! yellow? y?) + (refresh)) + (define/public (set-yellow/lang y? lang) + (set-message #f lang) + (set-yellow y?)) + + (define/override (fill-popup menu reset) + (let ([added-one? #f]) + (send (new menu-item% + [label (string-constant recent-languages)] + [callback void] + [parent menu]) + enable #f) + (for-each + (λ (name/settings) + (let* ([name (car name/settings)] + [marshalled-settings (cdr name/settings)] + [lang (ormap + (λ (l) (and (equal? (send l get-language-name) name) l)) + (drracket:language-configuration:get-languages))]) + (when lang + ;; this test can fail when a language has been added wrongly via the tools interface + ;; just ignore that menu item, in that case. + (let ([settings (or (send lang unmarshall-settings marshalled-settings) + (send lang default-settings))]) + (when lang + (set! added-one? #t) + (new menu-item% + [parent menu] + [label (send lang get-language-name)] + [callback + (λ (x y) + (send (send frame get-definitions-text) + set-next-settings + (drracket:language-configuration:language-settings + lang + settings)))])))))) + (preferences:get 'drracket:recent-language-names)) + (unless added-one? + (send (new menu-item% + [label (string-append + " << " + (string-constant no-recently-chosen-languages) + " >>")] + [parent menu] + [callback void]) + enable #f)) + (new separator-menu-item% [parent menu])) + (new menu-item% + [label (string-constant choose-language-menu-item-label)] + [parent menu] + [callback + (λ (x y) + (send frame choose-language-callback))])) + + (super-new [label ""] + [font small-control-font] + [string-constant-untitled (string-constant untitled)] + [string-constant-no-full-name-since-not-saved + (string-constant no-full-name-since-not-saved)]) + + (inherit set-allow-shrinking) + (set-allow-shrinking 100))) + + + + ; + ; + ; + ; + ; ;;; ; + ; ;;; ;;; + ; ;;; ;; ;;; ;;; ;; ;;; ;;; ;; ;;;; ;;; ;; ;;; ;;; ;;;;; ;;;; + ; ;;;;;;; ;;; ;;; ;;;;;;; ;;;;; ;; ;;; ;;;;;;; ;;;;; ;;;;;;;;; ;;; ;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;;;;;; ;;;;;;; ;;;;;;; ;;; ;;;;;; ;;;;;;; ;;;;; ;;; ;;;; ;; ;;; + ; ;;; ;; ;; ;;; ;; ;;; ;;; ;;;; ;;; ;; ;;; ;;; ;;; ;;;; + ; ;;; ;;; + ; ;;;;;; ;;; + ; + ; + + + ;; record-saved-bug-report : (listof (cons symbol string)) -> void + ;; =Kernel= =Handler= + (define (record-saved-bug-report table) + (let ([recorded (preferences:get 'drracket:saved-bug-reports)]) + (unless (member table recorded) + (preferences:set 'drracket:saved-bug-reports (shorten-to (cons table recorded) 15))))) + + ;; shorten-to : (listof X) number -> (listof X) + ;; drops items from the end of the list to bring it back down to `n' items + (define (shorten-to l n) + (let loop ([l l] + [n n]) + (cond + [(zero? n) '()] + [(null? l) '()] + [else (cons (car l) (loop (cdr l) (- n 1)))]))) + + (define very-small-planet-bitmap (include-bitmap (lib "icons/very-small-planet.png") 'png/mask)) + + (define saved-bug-reports-window #f) + (define saved-bug-reports-panel #f) + (define (init-saved-bug-reports-window) + (unless saved-bug-reports-window + (let () + (define stupid-internal-define-syntax1 + (set! saved-bug-reports-window (new frame:basic% [label (string-constant drscheme)] [width 600]))) + (define stupid-internal-define-syntax2 + (set! saved-bug-reports-panel + (new vertical-panel% [parent (send saved-bug-reports-window get-area-container)]))) + (define hp (new horizontal-panel% + [parent (send saved-bug-reports-window get-area-container)] + [stretchable-width #f] + [alignment '(right center)])) + (define forget-all (new button% + [label (string-constant bug-track-forget-all)] + [callback + (λ (_1 _2) + (send saved-bug-reports-window show #f) + (preferences:set 'drracket:saved-bug-reports '()))] + [parent hp])) + (void)))) + + (preferences:add-callback + 'drracket:saved-bug-reports + (λ (p v) + (when saved-bug-reports-window + (when (send saved-bug-reports-window is-shown?) + (cond + [(null? v) + (send saved-bug-reports-window show #f)] + [else + (refresh-saved-bug-reports-window v)]))))) + + (define (refresh-saved-bug-reports-window pref) + (send saved-bug-reports-window begin-container-sequence) + (send saved-bug-reports-panel change-children (λ (l) '())) + (for-each + (λ (item) + (let () + (define (lookup k [default ""]) + (let loop ([item item]) + (cond + [(null? item) default] + [else (let ([rib (car item)]) + (if (eq? (car rib) k) + (cdr rib) + (loop (cdr item))))]))) + (define vp + (new vertical-panel% + [style '(border)] + [parent saved-bug-reports-panel] + [stretchable-height #f])) + (define hp + (new horizontal-panel% + [parent vp] + [stretchable-height #f])) + (define first-line-msg + (let ([desc (lookup 'description #f)]) + (and desc + (new message% + [label (read-line (open-input-string desc))] + [parent vp] + [stretchable-width #t] + [font (send (send (editor:get-standard-style-list) find-named-style "Standard") get-font)])))) + (define msg (new message% + [stretchable-width #t] + [label (string-append (lookup 'component "<>") + (let ([v (lookup 'version #f)]) + (if v + (string-append " " v) + "")))] + [parent hp])) + (define forget (new button% + [parent hp] + [callback (λ (x y) (forget-saved-bug-report item))] + [label (string-constant bug-track-forget)])) + (define report (new button% + [parent hp] + [callback (λ (x y) + (forget-saved-bug-report item) + (send-url + (url->string + (drracket:debug:bug-info->ticket-url item))))] + [label (string-constant bug-track-report)])) + (void))) + pref) ;; reverse list so first elements end up on top of list + (send saved-bug-reports-window reflow-container) + (send saved-bug-reports-window end-container-sequence)) + + (define (forget-saved-bug-report item) + (preferences:set 'drracket:saved-bug-reports (remove item (preferences:get 'drracket:saved-bug-reports)))) + + (define (show-saved-bug-reports-window) + (init-saved-bug-reports-window) + (unless (send saved-bug-reports-window is-shown?) + (refresh-saved-bug-reports-window (preferences:get 'drracket:saved-bug-reports))) + (send saved-bug-reports-window show #t)) + + + + ; + ; + ; + ; + ; ;;;; ;; ; + ; ;;; ; ; ; + ; ;;;; ;;; ;;;;;;; ;;; ;; ;;; ;;;; ; ; ; + ; ;;;; ;;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; ; ; ; + ; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ;; + ; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;; ; ; ; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ; ; ; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ; ; ; + ; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;; ; ;; + ; + ; + ; + ; + + + (define -frame% + (drracket:module-language:module-language-online-expand-frame-mixin + (frame-mixin (drracket:frame:mixin (drracket:frame:basics-mixin (frame:size-pref-mixin @@ -1156,3635 +4644,85 @@ module browser threading seems wrong. (frame:standard-menus-mixin (frame:register-group-mixin (frame:basic-mixin - frame%)))))))))))))))) - - (define tab% - (class* object% (drracket:rep:context<%> tab<%>) - (init-field frame - defs - i - defs-shown? - ints-shown?) - (define enabled? #t) - (field [ints #f] - [visible-defs #f] - [visible-ints #f] - [focus-d/i 'defs]) - - ;; only called to initialize this tab. - ;; the interactions editor should be invariant. - (define/public (set-ints i) (set! ints i)) - - (define/public-final (get-frame) frame) - (define/public-final (get-defs) defs) - (define/public-final (get-ints) ints) - (define/public-final (get-visible-defs) (values visible-defs defs-shown?)) - (define/public-final (set-visible-defs vd ds?) - (set! visible-defs vd) - (set! defs-shown? ds?)) - (define/public-final (get-visible-ints) (values visible-ints ints-shown?)) - (define/public-final (set-visible-ints vi is?) - (set! visible-ints vi) - (set! ints-shown? is?)) - (define/public-final (set-focus-d/i di) - (set! focus-d/i di)) - (define/public-final (get-focus-d/i) focus-d/i) - (define/public-final (get-i) i) - (define/public-final (set-i _i) (set! i _i)) - (define/public (disable-evaluation) - (set! enabled? #f) - (send defs lock #t) - (send ints lock #t) - (send frame disable-evaluation-in-tab this)) - (define/public (enable-evaluation) - (set! enabled? #t) - (send defs lock #f) - (send ints lock #f) - (send frame enable-evaluation-in-tab this)) - (define/public (get-enabled) enabled?) - - ;; current-execute-warning is a snapshot of the needs-execution-message - ;; that is taken each time repl submission happens, and it gets reset - ;; when "Run" is clicked. - (define current-execute-warning #f) - (define/pubment (repl-submit-happened) - (set! current-execute-warning (send defs get-needs-execution-message)) - (update-execute-warning-gui)) - (define/public (get-current-execute-warning) current-execute-warning) - (define/public (clear-execution-state) - (set! current-execute-warning #f) - (update-execute-warning-gui) - (send defs already-warned)) - (define/public (update-execute-warning-gui) - (when (is-current-tab?) - (send frame show/hide-warning-message - (get-current-execute-warning) - (λ () - ;; this callback might be run with a different tab ... - (send (send frame get-current-tab) clear-execution-state))))) - - (define/public (get-directory) - (let ([filename (send defs get-filename)]) - (if (and (path? filename) - (file-exists? filename)) - (let-values ([(base _1 _2) (split-path (normalize-path filename))]) - base) - #f))) - - (define/pubment (can-close?) - (and (send defs can-close?) - (send ints can-close?) - (inner #t can-close?))) - (define/pubment (on-close) - (send defs on-close) - (send ints on-close) - (inner (void) on-close)) - - ;; this should really do something local to the tab, but - ;; for now it doesn't. - (define/public (ensure-rep-shown rep) - (send frame ensure-rep-shown rep)) - - (field [thread-to-break-box (make-weak-box #f)] - [custodian-to-kill-box (make-weak-box #f)] - [offer-kill? #f]) - - ;; break-callback : -> void - (define/public (break-callback) - (let ([thread-to-break (weak-box-value thread-to-break-box)] - [custodian-to-kill (weak-box-value custodian-to-kill-box)]) - (cond - [(or (not thread-to-break) - (not custodian-to-kill)) - (bell)] - [offer-kill? - (if (user-wants-kill?) - (when thread-to-break - (break-thread thread-to-break)) - (when custodian-to-kill - (custodian-shutdown-all custodian-to-kill)))] - [else - (when thread-to-break - (break-thread thread-to-break)) - ;; only offer a kill the next time if - ;; something got broken. - (set! offer-kill? #t)]))) - - ;; user-wants-kill? : -> boolean - ;; handles events, so be sure to check state - ;; after calling to avoid race conditions. - (define/private (user-wants-kill?) - (gui-utils:get-choice - (string-constant kill-evaluation?) - (string-constant just-break) - (string-constant kill) - (string-constant kill?) - 'diallow-close - frame)) - - ;; reset-offer-kill - (define/public (reset-offer-kill) - (set! offer-kill? #f)) - - ;; get-breakables : -> (union #f thread) (union #f cust) -> void - (define/public (get-breakables) - (values (weak-box-value thread-to-break-box) (weak-box-value custodian-to-kill-box))) - - ;; set-breakables : (union #f thread) (union #f cust) -> void - (define/public (set-breakables thd cust) - (set! thread-to-break-box (make-weak-box thd)) - (set! custodian-to-kill-box (make-weak-box cust))) - - (define/pubment (clear-annotations) - (inner (void) clear-annotations) - (send ints reset-highlighting)) - - (define running? #f) - (define/public-final (is-running?) running?) - (define/public (update-running b?) - (set! running? b?) - (send frame update-running b?)) - - (define/public-final (is-current-tab?) (eq? this (send frame get-current-tab))) - - (define log-visible? #f) - (define/public-final (toggle-log) - (set! log-visible? (not log-visible?)) - (send frame show/hide-log log-visible?)) - (define/public-final (update-log) - (send frame show/hide-log log-visible?)) - (define/public-final (update-logger-window command) - (when (is-current-tab?) - (send frame update-logger-window command))) - - (define current-planet-status #f) - (define/public-final (new-planet-status a b) - (set! current-planet-status (cons a b)) - (update-planet-status)) - (define/public-final (clear-planet-status) - (set! current-planet-status #f) - (update-planet-status)) - (define/public-final (update-planet-status) - (send frame show-planet-status - (and current-planet-status - (car current-planet-status)) - (and current-planet-status - (cdr current-planet-status)))) - - (super-new))) - - ;; should only be called by the tab% object (and the class itself) - (define-local-member-name - disable-evaluation-in-tab - enable-evaluation-in-tab - update-toolbar-visibility - show/hide-log - show-planet-status) - - (define -frame<%> - (interface (drracket:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>) - get-insert-menu - get-special-menu - get-interactions-text - get-definitions-text - get-interactions-canvas - get-definitions-canvas - get-button-panel - execute-callback - get-current-tab - open-in-new-tab - close-current-tab - on-tab-change - enable-evaluation - disable-evaluation - get-definitions/interactions-panel-parent - register-capability-menu-item - - ensure-rep-shown - ensure-rep-hidden - ensure-defs-shown - - - get-language-menu - register-toolbar-button - register-toolbar-buttons - unregister-toolbar-button - get-tabs)) - - - (define frame-mixin - (mixin (drracket:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>) - (-frame<%>) - (init filename) - (inherit set-label-prefix get-show-menu - get-menu% - get-area-container - update-info - get-file-menu - search-hidden? - unhide-search - hide-search - file-menu:get-close-item - file-menu:get-save-item - file-menu:get-save-as-item - file-menu:get-revert-item - file-menu:get-print-item) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; execute warning - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define execute-warning-panel #f) - (define execute-warning-parent-panel #f) - (define execute-warning-canvas #f) - (define/public-final (show/hide-warning-message msg hide-canvas) - (when (and execute-warning-parent-panel - execute-warning-panel) - (cond - [msg - (cond - [execute-warning-canvas - (send execute-warning-canvas set-message msg)] - [else - (set! execute-warning-canvas - (new execute-warning-canvas% - [stretchable-height #t] - [parent execute-warning-panel] - [message msg])) - (new close-icon% - [parent execute-warning-panel] - [bg-color "yellow"] - [callback (λ () (hide-canvas))])]) - (send execute-warning-parent-panel - change-children - (λ (l) (append (remq execute-warning-panel l) - (list execute-warning-panel))))] - [else - (when execute-warning-canvas - (send execute-warning-parent-panel - change-children - (λ (l) (remq execute-warning-panel l))) - (send execute-warning-canvas set-message #f))]))) - - - ;; bind the proc to a field - ;; so it stays alive as long - ;; as the frame stays alive - (define show-line-numbers-pref-fn - (let ([fn (lambda (pref value) (show-line-numbers! value))]) - (preferences:add-callback - 'drracket:show-line-numbers? - fn - #t) - fn)) - - (define/override (add-line-number-menu-items menu) - (define on? (preferences:get 'drracket:show-line-numbers?)) - (new separator-menu-item% [parent menu]) - (new checkable-menu-item% - [label (string-constant show-line-numbers-in-definitions)] - [parent menu] - [checked on?] - [callback - (λ (c dc) - (preferences:set 'drracket:show-line-numbers? (not on?)))]) - (super add-line-number-menu-items menu)) - - (define/private (show-line-numbers! show) - (for ([tab tabs]) - (define text (send tab get-defs)) - (send text show-line-numbers! show)) - (send definitions-canvas refresh)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; logging - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define logger-panel #f) - (define logger-parent-panel #f) - - ;; logger-gui-tab-panel: (or/c #f (is-a?/c tab-panel%)) - ;; this is #f when the GUI has not been built yet. After - ;; it becomes a tab-panel, it is always a tab-panel (altho the tab panel might not always be shown) - (define logger-gui-tab-panel #f) - (define logger-gui-canvas #f) - - ;; logger-gui-text: (or/c #f (is-a?/c tab-panel%)) - ;; this is #f when the GUI has not been built or when the logging panel is hidden - ;; in that case, the logging messages aren't begin saved in an editor anywhere - (define logger-gui-text #f) - - (define logger-menu-item #f) - - (define/public-final (show/hide-log show?) - (let ([p (preferences:get 'drracket:logging-size-percentage)]) - (begin-container-sequence) - (cond - [logger-gui-tab-panel - (send logger-parent-panel change-children - (λ (l) - (cond - [(or (and show? (member logger-panel l)) - (and (not show?) - (not (member logger-panel l)))) - ;; if things are already up to date, only update the logger text - (when show? - (update-logger-window #f)) - l] - [show? - (new-logger-text) - (send logger-gui-canvas set-editor logger-gui-text) - (update-logger-window #f) - (send logger-menu-item set-label (string-constant hide-log)) - (append (remq logger-panel l) (list logger-panel))] - [else - (send logger-menu-item set-label (string-constant show-log)) - (set! logger-gui-text #f) - (send logger-gui-canvas set-editor #f) - (remq logger-panel l)])))] - [else - (when show? ;; if we want to hide and it isn't built yet, do nothing - (set! logger-gui-tab-panel - (new tab-panel% - [choices (list (string-constant logging-all) - "fatal" "error" "warning" "info" "debug")] - [parent logger-panel] - [callback - (λ (tp evt) - (preferences:set 'drracket:logger-gui-tab-panel-level (send logger-gui-tab-panel get-selection)) - (update-logger-window #f))])) - (send logger-gui-tab-panel set-selection (preferences:get 'drracket:logger-gui-tab-panel-level)) - (new-logger-text) - (set! logger-gui-canvas - (new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text])) - (send logger-menu-item set-label (string-constant hide-log)) - (update-logger-window #f) - (send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))]) - (with-handlers ([exn:fail? void]) - (send logger-parent-panel set-percentages (list p (- 1 p)))) - (update-logger-button-label) - (end-container-sequence))) - - (define/private (log-shown?) - (and logger-gui-tab-panel - (member logger-panel (send logger-parent-panel get-children)))) - - (define/private (new-logger-text) - (set! logger-gui-text (new (text:hide-caret/selection-mixin text:basic%))) - (send logger-gui-text lock #t)) - - (define/public (update-logger-window command) - (when logger-gui-text - (let ([admin (send logger-gui-text get-admin)] - [canvas (send logger-gui-text get-canvas)]) - (when (and canvas admin) - (let ([logger-messages (send interactions-text get-logger-messages)] - [level (case (send logger-gui-tab-panel get-selection) - [(0) #f] - [(1) 'fatal] - [(2) 'error] - [(3) 'warning] - [(4) 'info] - [(5) 'debug])]) - (cond - [(and (pair? command) - (pair? logger-messages) - ;; just flush and redraw everything if there is one (or zero) logger messages - (pair? (cdr logger-messages))) - (let ([msg (cdr command)]) - (when (or (not level) - (eq? (vector-ref msg 0) level)) - (send logger-gui-text begin-edit-sequence) - (send logger-gui-text lock #f) - (case (car command) - [(add-line) (void)] - [(clear-last-and-add-line) - (send logger-gui-text delete - 0 - (send logger-gui-text paragraph-start-position 1))]) - (send logger-gui-text insert - "\n" - (send logger-gui-text last-position) - (send logger-gui-text last-position)) - (send logger-gui-text insert - (vector-ref msg 1) - (send logger-gui-text last-position) - (send logger-gui-text last-position)) - (send logger-gui-text end-edit-sequence) - (send logger-gui-text lock #t)))] - [else - (send logger-gui-text begin-edit-sequence) - (send logger-gui-text lock #f) - (send logger-gui-text erase) - - (let ([insert-one - (λ (x newline?) - (when (or (not level) - (eq? level (vector-ref x 0))) - (when newline? (send logger-gui-text insert "\n" 0 0)) - (send logger-gui-text insert (vector-ref x 1) 0 0)))]) - - (unless (null? logger-messages) - ;; skip the last newline in the buffer - (insert-one (car logger-messages) #f) - (for-each - (λ (x) (insert-one x #t)) - (cdr (send interactions-text get-logger-messages))))) - - (send logger-gui-text lock #t) - (send logger-gui-text end-edit-sequence)])))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; planet status - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define planet-status-parent-panel #f) - (define planet-status-panel #f) - (define planet-message #f) - (define planet-logger-button #f) - ;; local-member-name - (define/public (show-planet-status tag package) - (cond - [(and (not tag) - (not package) - (or (not planet-status-parent-panel) - (not (member planet-status-panel (send planet-status-parent-panel get-children))))) - ;; if there is no information and there is no GUI there, don't do anything - (void)] - [else - (when planet-status-panel - (unless planet-message - (new message% - [parent planet-status-panel] - [label drracket:debug:small-planet-bitmap]) - (set! planet-message (new message% [parent planet-status-panel] [label ""] [stretchable-width #t])) - (set! planet-logger-button - (new button% - [font small-control-font] - [parent planet-status-panel] - [label (string-constant show-log)] - [callback (λ (a b) (send current-tab toggle-log))])) - (update-logger-button-label) - (new close-icon% - [parent planet-status-panel] - [callback (λ () - (send planet-status-parent-panel change-children - (λ (l) - (remq planet-status-panel l))) - (send current-tab clear-planet-status))])) - (send planet-message set-label - (case tag - [(download) - (format (string-constant planet-downloading) package)] - [(install) - (format (string-constant planet-installing) package)] - [(docs-build) - (format (string-constant planet-docs-building) package)] - [(finish) - (format (string-constant planet-finished) package)] - [else - (string-constant planet-no-status)])) - (send planet-status-parent-panel change-children - (λ (l) - (if (memq planet-status-panel l) - l - (append (remq planet-status-panel l) (list planet-status-panel))))))])) - - (define/private (update-logger-button-label) - (when planet-logger-button - (send planet-logger-button set-label - (if (and logger-gui-text - (member logger-panel (send logger-parent-panel get-children))) - (string-constant hide-log) - (string-constant show-log))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; transcript - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - ;; transcript : (union #f string[directory-name]) - (field [transcript #f] - [definitions-transcript-counter 0] ;; number - [interactions-transcript-counter 0] ;; number - [transcript-parent-panel #f] ;; panel (unitialized short time only) - [transcript-panel #f] ;; panel (unitialized short time only) - [transcript-menu-item #f]) ;; menu-item (unitialized short time only) - ;; record-definitions : -> void - (define/private (record-definitions) - (when transcript - (set! definitions-transcript-counter (+ definitions-transcript-counter 1)) - (send definitions-text save-file - (build-path transcript (format "~a-definitions" (pad-two definitions-transcript-counter))) - 'copy))) - - ;; record-ineractions : -> void - (define/private (record-interactions) - (when transcript - (set! interactions-transcript-counter (+ interactions-transcript-counter 1)) - (send interactions-text save-file - (build-path transcript (format "~a-interactions" (pad-two interactions-transcript-counter))) - 'copy))) - - ;; pad-two : number -> string - ;; pads a number to two digits? - (define/private (pad-two n) - (cond - [(<= 0 n 9) (format "0~a" n)] - [else (format "~a" n)])) - - ;; start-transcript : -> void - ;; turns on the transcript and shows the transcript gui - (define/private (start-transcript) - (let ([transcript-directory (mred:get-directory - (string-constant please-choose-a-log-directory) - this)]) - (when (and transcript-directory - (ensure-empty transcript-directory)) - (send transcript-menu-item set-label (string-constant stop-logging)) - (set! transcript transcript-directory) - (set! definitions-transcript-counter 0) - (set! interactions-transcript-counter 0) - (build-transcript-panel) - (record-definitions)))) - - ;; stop-transcript : -> void - ;; turns off the transcript procedure - (define/private (stop-transcript) - (record-interactions) - (send transcript-menu-item set-label (string-constant log-definitions-and-interactions)) - (set! transcript #f) - (send transcript-panel change-children (λ (l) null))) - - ;; build-transcript-panel : -> void - ;; builds the contents of the transcript panel - (define/private (build-transcript-panel) - (define hp (make-object horizontal-panel% transcript-panel '(border))) - (make-object message% (string-constant logging-to) hp) - (send (make-object message% (path->string transcript) hp) stretchable-width #t) - (make-object button% (string-constant stop-logging) hp (λ (x y) (stop-transcript)))) - - ;; ensure-empty : string[directory] -> boolean - ;; if the transcript-directory is empty, just return #t - ;; if not, ask the user about emptying it. - ;; if they say yes, try to empty it. - ;; if that fails, report the error and return #f. - ;; if it succeeds, return #t. - ;; if they say no, return #f. - (define/private (ensure-empty transcript-directory) - (let ([dir-list (directory-list transcript-directory)]) - (or (null? dir-list) - (let ([query (message-box - (string-constant drscheme) - (gui-utils:format-literal-label (string-constant erase-log-directory-contents) - transcript-directory) - this - '(yes-no))]) - (cond - [(eq? query 'no) - #f] - [(eq? query 'yes) - (with-handlers ([exn:fail:filesystem? - (λ (exn) - (message-box - (string-constant drscheme) - (gui-utils:format-literal-label (string-constant error-erasing-log-directory) - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "~s" exn))) - this) - #f)]) - (for-each (λ (file) (delete-file (build-path transcript-directory file))) - dir-list) - #t)]))))) - - (define/override (make-root-area-container cls parent) - (let* ([saved-p (preferences:get 'drracket:module-browser-size-percentage)] - [saved-p2 (preferences:get 'drracket:logging-size-percentage)] - [_module-browser-parent-panel - (super make-root-area-container - (make-two-way-prefs-dragable-panel% panel:horizontal-dragable% - 'drracket:module-browser-size-percentage) - parent)] - [_module-browser-panel (new vertical-panel% - (parent _module-browser-parent-panel) - (alignment '(left center)) - (stretchable-width #f))] - [planet-status-outer-panel (new vertical-panel% [parent _module-browser-parent-panel])] - [execute-warning-outer-panel (new vertical-panel% [parent planet-status-outer-panel])] - [logger-outer-panel (new (make-two-way-prefs-dragable-panel% panel:vertical-dragable% - 'drracket:logging-size-percentage) - [parent execute-warning-outer-panel])] - [trans-outer-panel (new vertical-panel% [parent logger-outer-panel])] - [root (make-object cls trans-outer-panel)]) - (set! module-browser-parent-panel _module-browser-parent-panel) - (set! module-browser-panel _module-browser-panel) - (send module-browser-parent-panel change-children (λ (l) (remq module-browser-panel l))) - (set! logger-parent-panel logger-outer-panel) - (set! logger-panel (new vertical-panel% [parent logger-parent-panel])) - (send logger-parent-panel change-children (lambda (x) (remq logger-panel x))) - - (set! execute-warning-parent-panel execute-warning-outer-panel) - (set! execute-warning-panel (new horizontal-panel% - [parent execute-warning-parent-panel] - [stretchable-height #f])) - (send execute-warning-parent-panel change-children (λ (l) (remq execute-warning-panel l))) - - (set! transcript-parent-panel (new horizontal-panel% - (parent trans-outer-panel) - (stretchable-height #f))) - (set! transcript-panel (make-object horizontal-panel% transcript-parent-panel)) - (set! planet-status-parent-panel (new vertical-panel% - [parent planet-status-outer-panel] - [stretchable-height #f])) - (set! planet-status-panel (new horizontal-panel% - [parent planet-status-parent-panel])) - (send planet-status-parent-panel change-children (λ (l) (remq planet-status-panel l))) - (unless (toolbar-shown?) - (send transcript-parent-panel change-children (λ (l) '()))) - (preferences:set 'drracket:module-browser-size-percentage saved-p) - (preferences:set 'drracket:logging-size-percentage saved-p2) - - root)) - - (inherit show-info hide-info is-info-hidden?) - (field [toolbar-state (preferences:get 'drracket:toolbar-state)] - [toolbar-top-menu-item #f] - [toolbar-left-menu-item #f] - [toolbar-right-menu-item #f] - [toolbar-hidden-menu-item #f] - [toolbar-menu #f]) - - ;; returns #t if the toolbar is visible, #f otherwise - (define/private (toolbar-shown?) (car toolbar-state)) - - (define/private (change-toolbar-state new-state) - (set! toolbar-state new-state) - (preferences:set 'drracket:toolbar-state new-state) - (update-toolbar-visibility)) - - (define/override (on-toolbar-button-click) (change-toolbar-state (cons (not (car toolbar-state)) (cdr toolbar-state)))) - (define/private (set-toolbar-left) (change-toolbar-state (cons #f 'left))) - (define/private (set-toolbar-right) (change-toolbar-state (cons #f 'right))) - (define/private (set-toolbar-top) (change-toolbar-state (cons #f 'top))) - (define/private (set-toolbar-hidden) (change-toolbar-state (cons #t (cdr toolbar-state)))) - - (define/public (update-toolbar-visibility) - (let* ([hidden? (toolbar-is-hidden?)] - [left? (toolbar-is-left?)] - [right? (toolbar-is-right?)] - [top? (toolbar-is-top?)]) - - (send toolbar-left-menu-item check left?) - (send toolbar-right-menu-item check right?) - (send toolbar-top-menu-item check top?) - (send toolbar-hidden-menu-item check hidden?) - - (cond - [hidden? - (hide-info) - (send top-outer-panel change-children (λ (l) '())) - (send transcript-parent-panel change-children (λ (l) '()))] - [top? (orient/show #t)] - [left? (orient/show #t)] - [right? (orient/show #f)])) - (update-defs/ints-resize-corner)) - - (define/private (toolbar-is-hidden?) - (car (preferences:get 'drracket:toolbar-state))) - (define/private (toolbar-is-top?) - (and (not (toolbar-is-hidden?)) - (eq? (cdr (preferences:get 'drracket:toolbar-state)) - 'top))) - (define/private (toolbar-is-right?) - (and (not (toolbar-is-hidden?)) - (eq? (cdr (preferences:get 'drracket:toolbar-state)) - 'right))) - (define/private (toolbar-is-left?) - (and (not (toolbar-is-hidden?)) - (eq? (cdr (preferences:get 'drracket:toolbar-state)) - 'left))) - - (define/private (orient/show bar-at-beginning?) - (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) - (begin-container-sequence) - (show-info) - - ;; orient the button panel and all panels inside it. - (let loop ([obj button-panel]) - (when (is-a? obj area-container<%>) - (when (or (is-a? obj vertical-panel%) - (is-a? obj horizontal-panel%)) - (unless (equal? (send obj get-orientation) (not vertical?)) - (send obj set-orientation (not vertical?)) - ;; have to be careful to avoid reversing the list when the orientation is already proper - (send obj change-children reverse))) - (for-each loop (send obj get-children)))) - - (orient) - - (send top-outer-panel stretchable-height vertical?) - (send top-outer-panel stretchable-width (not vertical?)) - (send top-panel set-orientation (not vertical?)) - (send toolbar/rest-panel set-orientation vertical?) - (send toolbar/rest-panel change-children - (λ (l) - (if bar-at-beginning? - (cons top-outer-panel (remq top-outer-panel l)) - (append (remq top-outer-panel l) (list top-outer-panel))))) - (send top-outer-panel change-children (λ (l) (list top-panel))) - (send transcript-parent-panel change-children (λ (l) (list transcript-panel))) - - (let* ([settings (send definitions-text get-next-settings)] - [language (drracket:language-configuration:language-settings-language settings)] - [name (get-define-popup-name (send language capability-value 'drscheme:define-popup) - vertical?)]) - (when name - (send func-defs-canvas set-message #f name))) - (send name-message set-short-title vertical?) - (send name-panel set-orientation (not vertical?)) - (if vertical? - (send name-panel set-alignment 'right 'top) - (send name-panel set-alignment 'left 'center)) - (end-container-sequence))) - - (define toolbar-buttons '()) - (define/public (register-toolbar-button b) - (set! toolbar-buttons (cons b toolbar-buttons)) - (orient)) - - (define/public (register-toolbar-buttons bs) - (set! toolbar-buttons (append bs toolbar-buttons)) - (orient)) - - (define/public (unregister-toolbar-button b) - (set! toolbar-buttons (remq b toolbar-buttons)) - (void)) - - (define/private (orient) - (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) - (for-each - (λ (obj) (send obj set-label-visible (not vertical?))) - toolbar-buttons)) - - (let loop ([obj button-panel]) - (cond - [(is-a? obj area-container<%>) - (for-each loop (send obj get-children))] - [(is-a? obj switchable-button%) - (unless (memq obj toolbar-buttons) - (error 'register-toolbar-button "found a switchable-button% that is not registered, label ~s" - (send obj get-label)))] - [else (void)]))) - - (field [remove-show-status-line-callback - (preferences:add-callback - 'framework:show-status-line - (λ (p v) - (update-defs/ints-resize-corner/pref v)))]) - - (define/private (update-defs/ints-resize-corner) - (update-defs/ints-resize-corner/pref - (preferences:get 'framework:show-status-line))) - - (define/private (update-defs/ints-resize-corner/pref si-pref) - (let ([bottom-material? (and (not (car toolbar-state)) - si-pref)]) - (let loop ([cs definitions-canvases]) - (cond - [(null? cs) (void)] - [(null? (cdr cs)) - (send (car cs) set-resize-corner (and (not bottom-material?) - (not interactions-shown?)))] - [else - (send (car cs) set-resize-corner #f) - (loop (cdr cs))])) - (let loop ([cs interactions-canvases]) - (cond - [(null? cs) (void)] - [(null? (cdr cs)) - (send (car cs) set-resize-corner (and (not bottom-material?) - interactions-shown?))] - [else - (send (car cs) set-resize-corner #f) - (loop (cdr cs))])))) - - [define definitions-item #f] - [define interactions-item #f] - [define name-message #f] - [define save-button #f] - [define save-init-shown? #f] - - [define/private set-save-init-shown? (λ (x) (set! save-init-shown? x))] - - [define canvas-show-mode #f] - [define allow-split? #f] - [define forced-quit? #f] - [define search-canvas #f] - - (define/public (make-searchable canvas) - (update-info) - (set! search-canvas canvas)) - - (define was-locked? #f) - - (define/public-final (disable-evaluation-in-tab tab) - (when (eq? tab current-tab) - (disable-evaluation))) - - (define/pubment (disable-evaluation) - (when execute-menu-item - (send execute-menu-item enable #f)) - (send execute-button enable #f) - (inner (void) disable-evaluation)) - - (define/public-final (enable-evaluation-in-tab tab) - (when (eq? tab current-tab) - (enable-evaluation))) - - (define/pubment (enable-evaluation) - (when execute-menu-item - (send execute-menu-item enable #t)) - (send execute-button enable #t) - (inner (void) enable-evaluation)) - - (inherit set-label) - (inherit modified) - (define/public (update-save-button) - (let ([mod? (send definitions-text is-modified?)]) - (modified mod?) - (if save-button - (unless (eq? mod? (send save-button is-shown?)) - (send save-button show mod?)) - (set! save-init-shown? mod?)) - (update-tab-label current-tab))) - - (define/public (language-changed) - (let* ([settings (send definitions-text get-next-settings)] - [language (drracket:language-configuration:language-settings-language settings)]) - (send func-defs-canvas language-changed language (or (toolbar-is-left?) (toolbar-is-right?))) - (send language-message set-yellow/lang - (not (send definitions-text this-and-next-language-the-same?)) - (string-append (send language get-language-name) - (if (send language default-settings? - (drracket:language-configuration:language-settings-settings settings)) + frame%)))))))))))))))))) + + (define (make-two-way-prefs-dragable-panel% % pref-key) + (class % + (inherit get-percentages) + (define/augment (after-percentage-change) + (let ([percentages (get-percentages)]) + (when (and (pair? percentages) + (pair? (cdr percentages)) + (null? (cddr percentages))) + (preferences:set pref-key (car percentages)))) + (inner (void) after-percentage-change)) + (super-new))) + + (define drs-name-message% + (class name-message% + (define/override (on-choose-directory dir) + (let ([file (finder:get-file dir + (string-constant select-file) + #f "" - (string-append " " (string-constant custom))))) - (when (is-a? language-specific-menu menu%) - (let ([label (send language-specific-menu get-label)] - [new-label (send language capability-value 'drscheme:language-menu-title)]) - (unless (equal? label new-label) - (send language-specific-menu set-label new-label)))))) - - (define/public (get-language-menu) language-specific-menu) - - ;; update-save-message : -> void - ;; sets the save message. If input is #f, uses the frame's - ;; title. - (define/public (update-save-message) - (when name-message - (let ([filename (send definitions-text get-filename)]) - (send name-message set-message - (if filename #t #f) - (send definitions-text get-filename/untitled-name)))) - (update-tabs-labels)) - - (define/private (update-tabs-labels) - (for-each (λ (tab) (update-tab-label tab)) tabs) - (send tabs-panel set-selection (send current-tab get-i)) - (send (send tabs-panel get-parent) - change-children - (λ (l) - (cond - [(= (send tabs-panel get-number) 1) - (remq tabs-panel l)] - [else - (if (memq tabs-panel l) - l - (cons tabs-panel l))])))) - - (define/private (update-tab-label tab) - (let ([label (gui-utils:trim-string (get-defs-tab-label (send tab get-defs) tab) 200)]) - (unless (equal? label (send tabs-panel get-item-label (send tab get-i))) - (send tabs-panel set-item-label (send tab get-i) label)))) - - (define/public (get-tab-filename i) - (get-defs-tab-filename (send (list-ref tabs i) get-defs))) - - (define/private (get-defs-tab-label defs tab) - (let ([fn (send defs get-filename)] - [i-prefix (or (for/or ([i (in-list tabs)] - [n (in-naturals 1)] - #:when (<= n 9)) - (and (eq? i tab) - (format "~a: " n))) - "")]) - (add-modified-flag - defs - (string-append - i-prefix - (get-defs-tab-filename defs))))) - - (define/private (get-defs-tab-filename defs) - (let ([fn (send defs get-filename)]) - (if fn - (get-tab-label-from-filename fn) - (send defs get-filename/untitled-name)))) - - ;; tab-label-cache-valid : (listof path) - ;; If the current set of filenames in the tabs is the - ;; same set of filenames as in this list, then the - ;; tab-label-cache is valid; otherwise not - (define tab-label-cache-valid '()) - - ;; tab-label-cache : path -o> string - (define tab-label-cache (make-hasheq)) - - (define/private (get-tab-label-from-filename fn) - (define current-paths (map (lambda (tab) (send (send tab get-defs) get-filename)) - tabs)) - (unless (and (= (length tab-label-cache-valid) (length current-paths)) - (andmap eq? tab-label-cache-valid current-paths)) - (set! tab-label-cache-valid current-paths) - (set! tab-label-cache (make-hasheq))) - (hash-ref! tab-label-cache - fn - (lambda () (compute-tab-label-from-filename fn)))) - - (define/private (compute-tab-label-from-filename fn) - (let* ([take-n - (λ (n lst) - (let loop ([n n] - [lst lst]) + (send this get-top-level-window))]) + (when file + (handler:edit-file file)))) + (super-new + [string-constant-untitled (string-constant untitled)] + [string-constant-no-full-name-since-not-saved + (string-constant no-full-name-since-not-saved)]))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; lambda-snipclass is for backwards compatibility + ;; + (define lambda-snipclass + (make-object (class snip-class% + (define/override (read p) (make-object string-snip% "λ")) + (super-new)))) + (send lambda-snipclass set-version 1) + (send lambda-snipclass set-classname "drscheme:lambda-snip%") + (send (get-the-snip-class-list) add lambda-snipclass) + + (define newest-frame 'nothing-yet) + + (define open-drscheme-window + (case-lambda + [() (open-drscheme-window #f)] + [(name) + (cond + [(and newest-frame + name + (not (eq? newest-frame 'nothing-yet)) + (send newest-frame still-untouched?)) + (send newest-frame change-to-file name) + (send newest-frame show #t) + (begin0 newest-frame + (set! newest-frame #f))] + [(and name ;; only open a tab if we have a filename + (preferences:get 'drracket:open-in-tabs)) + (let ([fr (let loop ([frs (cons (send (group:get-the-frame-group) get-active-frame) + (send (group:get-the-frame-group) get-frames))]) (cond - [(zero? n) null] - [(null? lst) null] - [else (cons (car lst) (loop (- n 1) (cdr lst)))])))] - [find-exp-diff - (λ (p1 p2) - (let loop ([p1 p1] - [p2 p2] - [i 1]) - (cond - [(or (null? p1) (null? p2)) i] - [else (let ([f1 (car p1)] - [f2 (car p2)]) - (if (equal? f1 f2) - (loop (cdr p1) (cdr p2) (+ i 1)) - i))])))] - [exp (reverse (explode-path (normalize-path/exists fn)))] - [other-exps - (filter - (λ (x) (and x - (not (equal? exp x)))) - (map (λ (other-tab) - (let ([fn (send (send other-tab get-defs) get-filename)]) - (and fn - (reverse (explode-path (normalize-path/exists fn)))))) - tabs))] - [size - (let loop ([other-exps other-exps] - [size 1]) - (cond - [(null? other-exps) size] - [else (let ([new-size (find-exp-diff (car other-exps) exp)]) - (loop (cdr other-exps) - (max new-size size)))]))]) - (path->string (apply build-path (reverse (take-n size exp)))))) - - (define/private (normalize-path/exists fn) - (if (file-exists? fn) - (normalize-path fn) - fn)) - - (define/private (add-modified-flag text string) - (if (send text is-modified?) - (let ([prefix (get-save-diamond-prefix)]) - (if prefix - (string-append prefix string) - string)) - string)) - - (define/private (get-save-diamond-prefix) - (let ([candidate-prefixes - ;; be sure asterisk is at the end of each list, - ;; since that's a relatively safe character - (case (system-type) - [(unix windows) '("★ " "◆ " "• " "* ")] - [else '("◆ " "★ " "• " "* ")])]) - (ormap - (lambda (candidate) - (and (andmap (λ (x) (send normal-control-font screen-glyph-exists? x #t)) - (string->list candidate)) - candidate)) - candidate-prefixes))) - - [define/override get-canvas% (λ () (drracket:get/extend:get-definitions-canvas))] - - (define/public (update-running running?) - (send running-canvas set-running running?)) - (define/public (ensure-defs-shown) - (unless definitions-shown? - (toggle-show/hide-definitions) - (update-shown))) - (define/public (ensure-rep-shown rep) - (unless (eq? rep interactions-text) - (let loop ([tabs tabs]) - (unless (null? tabs) - (let ([tab (car tabs)]) - (if (eq? (send tab get-ints) rep) - (change-to-tab tab) - (loop (cdr tabs))))))) - (unless interactions-shown? - (toggle-show/hide-interactions) - (update-shown))) - (define/public (ensure-rep-hidden) - (when interactions-shown? - (toggle-show/hide-interactions) - (update-shown))) - - (define/override (get-editor%) (drracket:get/extend:get-definitions-text)) - (define/public (still-untouched?) - (and (send definitions-text still-untouched?) - (let* ([prompt (send interactions-text get-prompt)] - [first-prompt-para - (let loop ([n 0]) - (cond - [(n . <= . (send interactions-text last-paragraph)) - (if (string=? - (send interactions-text get-text - (send interactions-text paragraph-start-position n) - (+ (send interactions-text paragraph-start-position n) - (string-length prompt))) - prompt) - n - (loop (+ n 1)))] - [else #f]))]) - (and first-prompt-para - (= first-prompt-para (send interactions-text last-paragraph)) - (equal? - (send interactions-text get-text - (send interactions-text paragraph-start-position first-prompt-para) - (send interactions-text paragraph-end-position first-prompt-para)) - (send interactions-text get-prompt)))))) - (define/public (change-to-file name) - (cond - [(and name (file-exists? name)) - (ensure-rep-hidden) - (send definitions-text begin-edit-sequence) - (send definitions-text load-file/gui-error name) - (send definitions-text end-edit-sequence) - (send language-message set-yellow #f)] - [name - (send definitions-text set-filename name)] - [else (send definitions-text clear)]) - (send definitions-canvas focus)) - - - - - - - ; - ; - ; - ; ; - ; ; - ; ; - ; ; ;; ;; ;;; ;; ; ;;; ;;; - ; ;; ;; ; ; ; ; ;; ; ; ; - ; ; ; ; ; ; ; ; ; ; ;; - ; ; ; ; ; ; ; ; ;;;;;; ;; - ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;; ; ; - ; ; ; ; ;;; ;; ; ;;;; ;;; - ; - ; - ; - - - (define/private (add-modes-submenu edit-menu) - (new menu% - (parent edit-menu) - (label (string-constant mode-submenu-label)) - (demand-callback - (λ (menu) - (for-each (λ (item) (send item delete)) - (send menu get-items)) - (for-each (λ (mode) - (let* ([item - (new checkable-menu-item% - (label (drracket:modes:mode-name mode)) - (parent menu) - (callback - (λ (_1 _2) (send definitions-text set-current-mode mode))))]) - (when (send definitions-text is-current-mode? mode) - (send item check #t)))) - (drracket:modes:get-modes)))))) - - - - - ; - ; - ; - ; ; ; ; ; ; - ; ; ; ; ; - ; ; ; ; ; ; - ; ;;; ; ;; ; ; ;;;; ; ;;; ;;; ; ; ;;; ; ;; ;;; ;;; - ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ;; ;;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; - ; ;;; ; ;; ; ; ;; ; ;;; ;;; ; ; ;;;;; ; ;; ;;; ;;;; - ; ; ; ; - ; ; ; ; - ; ; ; - - - (inherit get-edit-target-window) - - (define/public (split) - (let ([canvas-to-be-split (get-edit-target-window)]) - (cond - [(memq canvas-to-be-split definitions-canvases) - (split-definitions canvas-to-be-split)] - [(memq canvas-to-be-split interactions-canvases) - (split-interactions canvas-to-be-split)] - [else (bell)]))) - - (define/private (split-definitions canvas-to-be-split) - (handle-split canvas-to-be-split - (λ (x) (set! definitions-canvases x)) - definitions-canvases - (drracket:get/extend:get-definitions-canvas) - definitions-text)) - - (define/private (split-interactions canvas-to-be-split) - (handle-split canvas-to-be-split - (λ (x) (set! interactions-canvases x)) - interactions-canvases - (drracket:get/extend:get-interactions-canvas) - interactions-text)) - - (define/private (handle-split canvas-to-be-split set-canvases! canvases canvas% text) - (let-values ([(ox oy ow oh cursor-y) - (get-visible-region canvas-to-be-split)]) - (let ([orig-percentages (send resizable-panel get-percentages)] - [orig-canvases (send resizable-panel get-children)] - [new-canvas (new canvas% - (parent resizable-panel) - (editor text) - (style '()))]) - - (set-canvases! - (let loop ([canvases canvases]) - (cond - [(null? canvases) (error 'split "couldn't split; didn't find canvas")] - [else - (let ([canvas (car canvases)]) - (if (eq? canvas canvas-to-be-split) - (list* new-canvas - canvas - (cdr canvases)) - (cons canvas (loop (cdr canvases)))))]))) - - (update-shown) - - ;; with-handlers prevents bad calls to set-percentages - ;; might still leave GUI in bad state, however. - (with-handlers ([exn:fail? (λ (x) (void))]) - (send resizable-panel set-percentages - (let loop ([canvases orig-canvases] - [percentages orig-percentages]) - (cond - [(null? canvases) - (error 'split "couldn't split; didn't find canvas")] - [(null? percentages) - (error 'split "wrong number of percentages: ~s ~s" - orig-percentages - (send resizable-panel get-children))] - [else (let ([canvas (car canvases)]) - (if (eq? canvas-to-be-split canvas) - (list* (/ (car percentages) 2) - (/ (car percentages) 2) - (cdr percentages)) - (cons - (car percentages) - (loop (cdr canvases) - (cdr percentages)))))])))) - - (set-visible-region new-canvas ox oy ow oh cursor-y) - (set-visible-region canvas-to-be-split ox oy ow oh cursor-y) - - (send new-canvas focus)))) - - ;; split-demand : menu-item -> void - ;; enables the menu-item if splitting is allowed, disables otherwise - (define/private (split-demand item) - (let ([canvas-to-be-split (get-edit-target-window)]) - (send item enable - (or (memq canvas-to-be-split definitions-canvases) - (memq canvas-to-be-split interactions-canvases))))) - - ;; collapse-demand : menu-item -> void - ;; enables the menu-item if collapsing is allowed, disables otherwise - (define/private (collapse-demand item) - (let ([canvas-to-be-split (get-edit-target-window)]) - (cond - [(memq canvas-to-be-split definitions-canvases) - (send item enable (2 . <= . (length definitions-canvases)))] - [(memq canvas-to-be-split interactions-canvases) - (send item enable (2 . <= . (length interactions-canvases)))] - [else - (send item enable #f)]))) - - ;; get-visible-region : editor-canvas -> number number number number (union #f number) - ;; calculates the visible region of the editor in this editor-canvas, returning - ;; four numbers for the x, y, width and height of the visible region - ;; also, the last two booleans indiciate if the beginning and the end - ;; of the selection was visible before the split, respectively. - (define/private (get-visible-region canvas) - (send canvas call-as-primary-owner - (λ () - (let* ([text (send canvas get-editor)] - [admin (send text get-admin)] - [start (send text get-start-position)] - [end (send text get-end-position)]) - (let-values ([(x y w h) (get-visible-area admin)]) - (let ([ysb (box 0)]) - (send text position-location (send text get-start-position) #f ysb) - (values x y w h - (and (= start end) - (<= y (unbox ysb) (+ y h)) - (unbox ysb))))))))) - - ;; set-visible-region : editor-canvas number number number number (union #f number) -> void - ;; sets the visible region of the text displayed by the editor canvas - ;; to be the middle of the region (vertically) specified by x, y, w, and h. - ;; if start-visible? and/or end-visible? are true, some special handling - ;; is done to try to keep the start and end visible, with precendence - ;; given to start if both are #t. - (define/private (set-visible-region canvas x y w h cursor-y) - (send canvas call-as-primary-owner - (λ () - (let* ([text (send canvas get-editor)] - [admin (send text get-admin)] - [nwb (box 0)] - [nhb (box 0)]) - (send admin get-view #f #f nwb nhb) - (let* ([nw (unbox nwb)] - [nh (unbox nhb)] - - [nx x] - [raw-y (- (+ y (/ h 2)) (/ nh 2))] - [ny (if (and cursor-y - (not (<= raw-y cursor-y (+ raw-y nh)))) - (- cursor-y (/ nh 2)) - raw-y)]) - (send canvas scroll-to nx ny nw nh #t) - (void)))))) - - ;; get-visible-area : admin -> number number number number - ;; returns the visible area for this admin - (define/private (get-visible-area admin) - (let ([bx (box 0)] - [by (box 0)] - [bw (box 0)] - [bh (box 0)]) - (send admin get-view bx by bw bh) - (values (unbox bx) - (unbox by) - (unbox bw) - (unbox bh)))) - - (define/public (collapse) - (let* ([target (get-edit-target-window)]) - (cond - [(memq target definitions-canvases) - (collapse-definitions target)] - [(memq target interactions-canvases) - (collapse-interactions target)] - [else (bell)]))) - - (define/private (collapse-definitions target) - (handle-collapse - target - (λ () definitions-canvases) - (λ (c) (set! definitions-canvases c)))) - - (define/private (collapse-interactions target) - (handle-collapse - target - (λ () interactions-canvases) - (λ (c) (set! interactions-canvases c)))) - - (define/private (handle-collapse target get-canvases set-canvases!) - (if (= 1 (length (get-canvases))) - (bell) - (let* ([old-percentages (send resizable-panel get-percentages)] - [soon-to-be-bigger-canvas #f] - [percentages - (if (eq? (car (get-canvases)) target) - (begin - (set! soon-to-be-bigger-canvas (cadr (get-canvases))) - (cons (+ (car old-percentages) - (cadr old-percentages)) - (cddr old-percentages))) - (let loop ([canvases (cdr (get-canvases))] - [prev-canvas (car (get-canvases))] - [percentages (cdr old-percentages)] - [prev-percentage (car old-percentages)]) - (cond - [(null? canvases) - (error 'collapse "internal error.1")] - [(null? percentages) - (error 'collapse "internal error.2")] - [else - (if (eq? (car canvases) target) - (begin - (set! soon-to-be-bigger-canvas prev-canvas) - (cons (+ (car percentages) - prev-percentage) - (cdr percentages))) - (cons prev-percentage - (loop (cdr canvases) - (car canvases) - (cdr percentages) - (car percentages))))])))]) - (unless soon-to-be-bigger-canvas - (error 'collapse "internal error.3")) - (set-canvases! (remq target (get-canvases))) - (update-shown) - - (let ([target-admin - (send target call-as-primary-owner - (λ () - (send (send target get-editor) get-admin)))] - [to-be-bigger-admin - (send soon-to-be-bigger-canvas call-as-primary-owner - (λ () - (send (send soon-to-be-bigger-canvas get-editor) get-admin)))]) - (let-values ([(bx by bw bh) (get-visible-area target-admin)]) - - ;; this line makes the soon-to-be-bigger-canvas bigger - ;; if it fails, we're out of luck, but at least we don't crash. - (with-handlers ([exn:fail? (λ (x) (void))]) - (send resizable-panel set-percentages percentages)) - - (let-values ([(ax ay aw ah) (get-visible-area to-be-bigger-admin)]) - (send soon-to-be-bigger-canvas scroll-to - bx - (- by (/ (- ah bh) 2)) - aw - ah - #t)))) - - (send target set-editor #f) - (send soon-to-be-bigger-canvas focus)))) - ; - ; - ; - ; ; - ; ; - ; ; - ; ;;; ; ;; ;;; ; ; ; ; ;; ;; ;;; ; ;; ; ; - ; ; ;; ; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; - ; ;;; ; ; ;;; ; ; ; ; ; ;;;; ; ; ;; ; - ; - ; - ; - - - (define interactions-shown? #t) - (define definitions-shown? #t) - - (define/private (toggle-show/hide-definitions) - (set! definitions-shown? (not definitions-shown?)) - (unless definitions-shown? - (set! interactions-shown? #t))) - (define/private (toggle-show/hide-interactions) - (set! interactions-shown? (not interactions-shown?)) - (unless interactions-shown? - (set! definitions-shown? #t))) - - (define (immediate-children parent children) - (define (immediate child) - (let loop ([child child]) - (define immediate-parent (send child get-parent)) - (if (eq? immediate-parent parent) - child - (loop immediate-parent)))) - (for/list ([child children]) - (immediate child))) - - (define/override (update-shown) - (super update-shown) - (let ([new-children - (foldl - (λ (shown? children sofar) - (if shown? - (append children sofar) - sofar)) - null - (list interactions-shown? - definitions-shown?) - (list interactions-canvases - definitions-canvases))] - [old-children (send resizable-panel get-children)] - [p (preferences:get 'drracket:unit-window-size-percentage)]) - (update-defs/ints-resize-corner) - (send definitions-item set-label - (if definitions-shown? - (string-constant hide-definitions-menu-item-label) - (string-constant show-definitions-menu-item-label))) - (send interactions-item set-label - (if interactions-shown? - (string-constant hide-interactions-menu-item-label) - (string-constant show-interactions-menu-item-label))) - (send resizable-panel begin-container-sequence) - - ;; this might change the unit-window-size-percentage, so save/restore it - (send resizable-panel change-children - (λ (old) - (immediate-children resizable-panel new-children))) - - (preferences:set 'drracket:unit-window-size-percentage p) - ;; restore preferred interactions/definitions sizes - (when (and (= 1 (length definitions-canvases)) - (= 1 (length interactions-canvases)) - (= 2 (length new-children))) - (with-handlers ([exn:fail? (λ (x) (void))]) - (send resizable-panel set-percentages - (list p (- 1 p))))) - - (send resizable-panel end-container-sequence) - (when (ormap (λ (child) - (and (is-a? child editor-canvas%) - (not (send child has-focus?)))) - (send resizable-panel get-children)) - (let ([new-focus - (let loop ([children (send resizable-panel get-children)]) - (cond - [(null? children) (void)] - [else (let ([child (car children)]) - (if (is-a? child editor-canvas%) - child - (loop (cdr children))))]))] - [old-focus - (ormap (λ (x) (and (is-a? x editor-canvas%) (send x has-focus?) x)) - old-children)]) - - ;; conservatively, only scroll when the focus stays in the same place. - (when old-focus - (when (eq? old-focus new-focus) - (let ([ed (send old-focus get-editor)]) - (when ed - (send ed scroll-to-position - (send ed get-start-position) - #f - (send ed get-end-position)))))) - - (send new-focus focus))) - - (for-each - (λ (get-item) - (let ([item (get-item)]) - (when item - (send item enable definitions-shown?)))) - (list (λ () (file-menu:get-revert-item)) - (λ () (file-menu:get-save-item)) - (λ () (file-menu:get-save-as-item)) - ;(λ () (file-menu:save-as-text-item)) ; Save As Text... - (λ () (file-menu:get-print-item)))) - (send file-menu:print-interactions-item enable interactions-shown?))) - - (define/augment (can-close?) - (and (andmap (lambda (tab) - (or (eq? tab current-tab) - (and (send (send tab get-defs) can-close?) - (send (send tab get-ints) can-close?)))) - tabs) - (send interactions-text can-close?) - (inner #t can-close?))) - (define/augment (on-close) - (inner (void) on-close) - (for-each (lambda (tab) - (unless (eq? tab current-tab) - (send (send tab get-defs) on-close) - (send (send tab get-ints) on-close))) - tabs) - (when (eq? this newest-frame) - (set! newest-frame #f)) - (when transcript - (stop-transcript)) - (remove-show-status-line-callback) - (remove-bug-icon-callback) - (send interactions-text on-close)) - - ;; execute-callback : -> void - ;; uses the state of the button to determine if an execution is - ;; already running. This function is called from many places, not - ;; just the execute button. - (define/public (execute-callback) - (when (send execute-button is-enabled?) - - ;; if the language is not-a-language, and the buffer looks like a module, - ;; automatically make the switch to the module language - (let ([next-settings (send definitions-text get-next-settings)]) - (when (is-a? (drracket:language-configuration:language-settings-language next-settings) - drracket:language-configuration:not-a-language-language<%>) - (when (looks-like-module? definitions-text) - (let-values ([(module-language module-language-settings) (get-module-language/settings)]) - (when (and module-language module-language-settings) - (send definitions-text set-next-settings - (drracket:language-configuration:language-settings - module-language - module-language-settings))))))) - - (check-if-save-file-up-to-date) - (when (preferences:get 'drracket:show-interactions-on-execute) - (ensure-rep-shown interactions-text)) - (when transcript - (record-definitions) - (record-interactions)) - (send definitions-text just-executed) - (send language-message set-yellow #f) - (send interactions-canvas focus) - (send interactions-text reset-console) - (send interactions-text clear-undos) - - (let ([start 0]) - (send definitions-text split-snip start) - (let* ([name (send definitions-text get-port-name)] - [text-port (open-input-text-editor definitions-text start 'end values name #t)]) - (port-count-lines! text-port) - (let* ([line (send definitions-text position-paragraph start)] - [column (- start (send definitions-text paragraph-start-position line))] - [relocated-port (relocate-input-port text-port - (+ line 1) - column - (+ start 1))]) - (port-count-lines! relocated-port) - (send interactions-text evaluate-from-port - relocated-port - #t - (λ () - (send interactions-text clear-undos)))))))) - - (inherit revert save) - (define/private (check-if-save-file-up-to-date) - (when (send definitions-text save-file-out-of-date?) - (let ([user-choice - (message-box/custom - (string-constant drscheme) - (string-constant definitions-modified) - (string-constant ignore) - (string-constant revert) - #f - this - '(caution default=2 number-order) - 1)]) - (case user-choice - [(1) (void)] - [(2) (revert)])))) - - (inherit get-menu-bar get-focus-object get-edit-target-object) - - (define/override (get-editor) definitions-text) - (define/override (get-canvas) - (initialize-definitions-canvas) - definitions-canvas) - - (define (create-definitions-canvas) - (new (drracket:get/extend:get-definitions-canvas) - [parent resizable-panel] - [editor definitions-text])) - - (define/private (initialize-definitions-canvas) - (unless definitions-canvas - (set! definitions-canvas (create-definitions-canvas)))) - - (define/override (get-delegated-text) definitions-text) - (define/override (get-open-here-editor) definitions-text) - - ;; wire the definitions text to the interactions text and initialize it. - (define/private (init-definitions-text tab) - (let ([defs (send tab get-defs)] - [ints (send tab get-ints)]) - (send defs set-interactions-text ints) - (send defs set-tab tab) - (send ints set-definitions-text defs) - (send defs change-mode-to-match) - (send defs insert-auto-text))) - - - ; - ; - ; @@ - ; @ @ - ; @@@@@ $@$: @-@$ :@@+@ - ; @ -@ @+ *$ @$ -@ - ; @ -$@$@ @ @ :@@$- - ; @ $* @ @ @ *@ - ; @: :$ @- *@ @ +$ @ :@ - ; :@@$- -$$-@@@@+@$ $+@@: - ; - ; - ; - ; - - (define/public (get-current-tab) current-tab) - - ;; create-new-tab : -> void - ;; creates a new tab and updates the GUI for that new tab - (define/private create-new-tab - (lambda ([filename #f]) - (let* ([defs (new (drracket:get/extend:get-definitions-text))] - [tab-count (length tabs)] - [new-tab (new (drracket:get/extend:get-tab) - (defs defs) - (i tab-count) - (frame this) - (defs-shown? #t) - (ints-shown? (not filename)))] - [ints (make-object (drracket:get/extend:get-interactions-text) new-tab)]) - (send new-tab set-ints ints) - (set! tabs (append tabs (list new-tab))) - (send tabs-panel append - (gui-utils:trim-string - (if filename - (get-tab-label-from-filename filename) - (get-defs-tab-label defs #f)) - 200)) - (init-definitions-text new-tab) - (when filename (send defs load-file filename)) - (change-to-nth-tab (- (send tabs-panel get-number) 1)) - (send ints initialize-console) - (send tabs-panel set-selection (- (send tabs-panel get-number) 1)) - (set! newest-frame this) - (update-menu-bindings)))) - - ;; change-to-tab : tab -> void - ;; updates current-tab, definitions-text, and interactactions-text - ;; to be the nth tab. Also updates the GUI to show the new tab - (inherit begin-container-sequence end-container-sequence) - (define/private (change-to-tab tab) - (let ([old-delegate (send definitions-text get-delegate)] - [old-tab current-tab]) - (save-visible-tab-regions) - (set! current-tab tab) - (set! definitions-text (send current-tab get-defs)) - (set! interactions-text (send current-tab get-ints)) - - - (begin-container-sequence) - (for-each (λ (defs-canvas) (send defs-canvas set-editor definitions-text #f)) - definitions-canvases) - (for-each (λ (ints-canvas) (send ints-canvas set-editor interactions-text #f)) - interactions-canvases) - - (update-save-message) - (update-save-button) - (language-changed) - - (send definitions-text update-frame-filename) - (send definitions-text set-delegate old-delegate) - (update-running (send current-tab is-running?)) - (on-tab-change old-tab current-tab) - (send tab update-log) - (send tab update-planet-status) - (send tab update-execute-warning-gui) - (restore-visible-tab-regions) - (for-each (λ (defs-canvas) (send defs-canvas refresh)) - definitions-canvases) - (for-each (λ (ints-canvas) (send ints-canvas refresh)) - interactions-canvases) - (set-color-status! (send definitions-text is-lexer-valid?)) - (end-container-sequence))) - - (define/pubment (on-tab-change from-tab to-tab) - (let ([old-enabled (send from-tab get-enabled)] - [new-enabled (send to-tab get-enabled)]) - (unless (eq? old-enabled new-enabled) - (if new-enabled - (enable-evaluation) - (disable-evaluation)))) - - (let ([from-defs (send from-tab get-defs)] - [to-defs (send to-tab get-defs)]) - (let ([delegate (send from-defs get-delegate)]) - (send from-defs set-delegate #f) - (send to-defs set-delegate delegate))) - - (inner (void) on-tab-change from-tab to-tab)) - - (define/public (next-tab) (change-to-delta-tab +1)) - (define/public (prev-tab) (change-to-delta-tab -1)) - - (define/private (change-to-delta-tab dt) - (change-to-nth-tab (modulo (+ (send current-tab get-i) dt) (length tabs)))) - - (define/public-final (close-current-tab) - (cond - [(null? tabs) (void)] - [(null? (cdr tabs)) (void)] - [else - (let loop ([l-tabs tabs]) - (cond - [(null? l-tabs) (error 'close-current-tab "uh oh.3")] - [else - (let ([tab (car l-tabs)]) - (if (eq? tab current-tab) - (when (close-tab tab) - (for-each (lambda (t) (send t set-i (- (send t get-i) 1))) - (cdr l-tabs)) - (set! tabs (remq tab tabs)) - (send tabs-panel delete (send tab get-i)) - (update-menu-bindings) - (change-to-tab (cond - [(< (send tab get-i) (length tabs)) - (list-ref tabs (send tab get-i))] - [else (last tabs)]))) - (loop (cdr l-tabs))))]))])) - - ;; a helper private method for close-current-tab -- doesn't close an arbitrary tab. - (define/private (close-tab tab) - (cond - [(send tab can-close?) - (send tab on-close) - #t] - [else #f])) - - (define/public (open-in-new-tab filename) - (create-new-tab filename)) - - (define/public (get-tab-count) (length tabs)) - (define/public (change-to-nth-tab n) - (unless (< n (length tabs)) - (error 'change-to-nth-tab "number too big ~s" n)) - (change-to-tab (list-ref tabs n))) - - (define/private (save-visible-tab-regions) - (send current-tab set-visible-ints - (get-tab-visible-regions interactions-text) - interactions-shown?) - (send current-tab set-visible-defs - (get-tab-visible-regions definitions-text) - definitions-shown?) - (send current-tab set-focus-d/i - (if (ormap (λ (x) (send x has-focus?)) interactions-canvases) - 'ints - 'defs))) - - (define/private (get-tab-visible-regions txt) - (map (λ (canvas) - (let-values ([(x y w h _) (get-visible-region canvas)]) - (list x y w h))) - (send txt get-canvases))) - - (inherit set-text-to-search reflow-container) - (define/private (restore-visible-tab-regions) - (define (fix-up-canvas-numbers txt regions ints?) - (when regions - (let* ([canvases (send txt get-canvases)] - [canvases-count (length canvases)] - [regions-count (length regions)]) - (cond - [(> canvases-count regions-count) - (let loop ([i (- canvases-count regions-count)] - [canvases canvases]) - (unless (zero? i) - (if ints? - (collapse-interactions (car canvases)) - (collapse-definitions (car canvases))) - (loop (- i 1) - (cdr canvases))))] - [(= canvases-count regions-count) - (void)] - [(< canvases-count regions-count) - (let loop ([i (- regions-count canvases-count)] - [canvases canvases]) - (unless (zero? i) - (if ints? - (split-interactions (car canvases)) - (split-definitions (car canvases))) - (loop (- i 1) - (cdr canvases))))])))) - - (define (set-visible-regions txt regions) - (when regions - (for-each (λ (canvas region) - (set-visible-region canvas - (first region) - (second region) - (third region) - (fourth region) - #f)) - (send txt get-canvases) - regions))) - - (let-values ([(vi is?) (send current-tab get-visible-ints)] - [(vd ds?) (send current-tab get-visible-defs)]) - (set! interactions-shown? is?) - (set! definitions-shown? ds?) - (update-shown) - (reflow-container) ;; without this one, the percentages in the resizable-panel are not up to date with the children - (fix-up-canvas-numbers definitions-text vd #f) - (fix-up-canvas-numbers interactions-text vi #t) - (reflow-container) - (set-visible-regions definitions-text vd) - (set-visible-regions interactions-text vi)) - (case (send current-tab get-focus-d/i) - [(defs) - (send (car definitions-canvases) focus) - (set-text-to-search (send (car definitions-canvases) get-editor))] - [(ints) - (send (car interactions-canvases) focus) - (set-text-to-search (send (car interactions-canvases) get-editor))])) - - (define/private (pathname-equal? p1 p2) - (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) - (string=? (path->string (normal-case-path (normalize-path p1))) - (path->string (normal-case-path (normalize-path p2)))))) - - (define/override (make-visible filename) - (let ([tab (find-matching-tab filename)]) - (when tab - (change-to-tab tab)))) - - (define/private (find-matching-tab filename) - (let loop ([tabs tabs]) - (cond - [(null? tabs) #f] - [else - (let* ([tab (car tabs)] - [tab-filename (send (send tab get-defs) get-filename)]) - (if (and tab-filename - (pathname-equal? filename tab-filename)) - tab - (loop (cdr tabs))))]))) - - (define/override (editing-this-file? filename) - (ormap (λ (tab) - (let ([fn (send (send tab get-defs) get-filename)]) - (and fn - (pathname-equal? fn filename)))) - tabs)) - - (define/override (get-menu-item%) - (class (super get-menu-item%) - (inherit get-label get-plain-label) - (define/override (restore-keybinding) - (cond - [(equal? (get-plain-label) (string-constant close)) - (update-close-menu-item-shortcut this)] - [(equal? (get-plain-label) (string-constant close-tab)) - (update-close-tab-menu-item-shortcut this)] - [else (super restore-keybinding)])) - (super-new))) - - (define/private (update-menu-bindings) - (when (preferences:get 'framework:menu-bindings) - (when close-tab-menu-item - (update-close-tab-menu-item-shortcut close-tab-menu-item)) - (update-close-menu-item-shortcut (file-menu:get-close-item)))) - - (define/private (update-close-tab-menu-item-shortcut item) - (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) - (send item set-label (if just-one? - (string-constant close-tab) - (string-constant close-tab-amp))) - (send item set-shortcut (if just-one? #f #\w)))) - - (define/private (update-close-menu-item-shortcut item) - (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) - (send item set-label (if just-one? - (string-constant close-menu-item) - (string-constant close))) - (send item set-shortcut (if just-one? #\w #f)))) - - ;; offer-to-save-file : path -> void - ;; bring the tab that edits the file named by `path' to the front - ;; and opens a dialog asking if it should be saved. - (define/public (offer-to-save-file path) - (let ([original-tab current-tab] - [tab-to-save (find-matching-tab path)]) - (when tab-to-save - (let ([defs-to-save (send tab-to-save get-defs)]) - (when (send defs-to-save is-modified?) - (unless (eq? tab-to-save original-tab) - (change-to-tab tab-to-save)) - (send defs-to-save user-saves-or-not-modified? #f) - (unless (eq? tab-to-save original-tab) - (change-to-tab original-tab))))))) - - - ;; - ;; end tabs - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define/public (get-definitions-text) definitions-text) - (define/public (get-interactions-text) interactions-text) - - (define/public (get-definitions/interactions-panel-parent) - toolbar/rest-panel) - - (inherit delegated-text-shown? hide-delegated-text show-delegated-text) - (define/override (add-show-menu-items show-menu) - (super add-show-menu-items show-menu) - (set! definitions-item - (make-object menu:can-restore-menu-item% - (string-constant hide-definitions-menu-item-label) - (get-show-menu) - (λ (_1 _2) - (toggle-show/hide-definitions) - (update-shown)) - #\d - (string-constant definitions-menu-item-help-string))) - (set! interactions-item - (make-object menu:can-restore-menu-item% - (string-constant show-interactions-menu-item-label) - (get-show-menu) - (λ (_1 _2) - (toggle-show/hide-interactions) - (update-shown)) - #\e - (string-constant interactions-menu-item-help-string))) - - (new menu:can-restore-menu-item% - (shortcut #\u) - (label - (if (delegated-text-shown?) - (string-constant hide-overview) - (string-constant show-overview))) - (parent (get-show-menu)) - (callback - (λ (menu evt) - (if (delegated-text-shown?) - (begin - (send menu set-label (string-constant show-overview)) - (preferences:set 'framework:show-delegate? #f) - (hide-delegated-text)) - (begin - (send menu set-label (string-constant hide-overview)) - (preferences:set 'framework:show-delegate? #t) - (show-delegated-text)))))) - - (set! module-browser-menu-item - (new menu:can-restore-menu-item% - (label (if module-browser-shown? - (string-constant hide-module-browser) - (string-constant show-module-browser))) - (parent (get-show-menu)) - (callback - (λ (menu evt) - (if module-browser-shown? - (hide-module-browser) - (show-module-browser)))))) - - (set! toolbar-menu (new menu% - [parent show-menu] - [label (string-constant toolbar)])) - (set! toolbar-left-menu-item - (new checkable-menu-item% - [label (string-constant toolbar-on-left)] - [parent toolbar-menu] - [callback (λ (x y) (set-toolbar-left))] - [checked #f])) - (set! toolbar-top-menu-item - (new checkable-menu-item% - [label (string-constant toolbar-on-top)] - [parent toolbar-menu] - [callback (λ (x y) (set-toolbar-top))] - [checked #f])) - (set! toolbar-right-menu-item - (new checkable-menu-item% - [label (string-constant toolbar-on-right)] - [parent toolbar-menu] - [callback (λ (x y) (set-toolbar-right))] - [checked #f])) - (set! toolbar-hidden-menu-item - (new checkable-menu-item% - [label (string-constant toolbar-hidden)] - [parent toolbar-menu] - [callback (λ (x y) (set-toolbar-hidden))] - [checked #f])) - - (set! logger-menu-item - (new menu-item% - [label (string-constant show-log)] - [parent show-menu] - [callback - (λ (x y) (send current-tab toggle-log))])) - ) - - - ; - ; - ; - ; ; ; ; - ; ; ; ; - ; ; ; ; - ; ; ;; ;; ;;; ;; ; ; ; ; ;;; ; ;; ; ; ;;; ; ; ; ;;; ;;; ; ; - ; ;; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ;; ;;;;;; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; - ; ; ; ; ;;; ;; ; ;; ; ; ;;;; ; ;; ; ;;; ; ; ;;; ;;;; ; - ; - ; - ; - - - (field [module-browser-shown? #f] - [module-browser-parent-panel #f] - [module-browser-panel #f] - [module-browser-ec #f] - [module-browser-button #f] - [module-browser-lib-path-check-box #f] - [module-browser-planet-path-check-box #f] - [module-browser-name-length-choice #f] - [module-browser-pb #f] - [module-browser-menu-item 'module-browser-menu-item-unset]) - - (inherit open-status-line close-status-line update-status-line) - - (define/private (show-module-browser) - (when module-browser-panel - (when (can-browse-language?) - (set! module-browser-shown? #t) - (send module-browser-menu-item set-label (string-constant hide-module-browser)) - (update-module-browser-pane)))) - - (define/private (hide-module-browser) - (when module-browser-panel - (set! module-browser-shown? #f) - (send module-browser-menu-item set-label (string-constant show-module-browser)) - (close-status-line 'plt:module-browser:mouse-over) - (send module-browser-parent-panel change-children - (λ (l) - (remq module-browser-panel l))))) - - (define/private (can-browse-language?) - (let* ([lang/config (send (get-definitions-text) get-next-settings)] - [lang (drracket:language-configuration:language-settings-language lang/config)] - [strs (send lang get-language-position)] - [can-browse? - (or (is-a? lang drracket:module-language:module-language<%>) - (ormap (λ (x) (regexp-match #rx"PLT" x)) - strs))]) - (unless can-browse? - (message-box (string-constant drscheme) - (string-constant module-browser-only-in-plt-and-module-langs))) - can-browse?)) - - (define/private (update-module-browser-pane) - (open-status-line 'plt:module-browser:mouse-over) - (send module-browser-panel begin-container-sequence) - (unless module-browser-ec - (set! module-browser-pb - (drracket:module-overview:make-module-overview-pasteboard - #t - (λ (x) (mouse-currently-over x)))) - (set! module-browser-ec (make-object editor-canvas% - module-browser-panel - module-browser-pb)) - - (let* ([show-callback - (λ (cb key) - (if (send cb get-value) - (send module-browser-pb show-visible-paths key) - (send module-browser-pb remove-visible-paths key)) - (preferences:set 'drracket:module-browser:hide-paths (send module-browser-pb get-hidden-paths)))] - [mk-checkbox - (λ (key label) - (new check-box% - (parent module-browser-panel) - (label label) - (value (not (memq key (preferences:get 'drracket:module-browser:hide-paths)))) - (callback - (λ (cb _) - (show-callback cb key)))))]) - (set! module-browser-lib-path-check-box (mk-checkbox 'lib show-lib-paths)) - (set! module-browser-planet-path-check-box (mk-checkbox 'planet show-planet-paths))) - - (set! module-browser-name-length-choice - (new choice% - (parent module-browser-panel) - (label (string-constant module-browser-name-length)) - (choices (list (string-constant module-browser-name-short) - (string-constant module-browser-name-medium) - (string-constant module-browser-name-long) - (string-constant module-browser-name-very-long))) - (selection (preferences:get 'drracket:module-browser:name-length)) - (callback - (λ (x y) - (let ([selection (send module-browser-name-length-choice get-selection)]) - (preferences:set 'drracket:module-browser:name-length selection) - (update-module-browser-name-length selection)))))) - (update-module-browser-name-length - (preferences:get 'drracket:module-browser:name-length)) - - (set! module-browser-button - (new button% - (parent module-browser-panel) - (label refresh) - (callback (λ (x y) (update-module-browser-pane))) - (stretchable-width #t)))) - - (let ([p (preferences:get 'drracket:module-browser-size-percentage)]) - (send module-browser-parent-panel change-children - (λ (l) - (cons module-browser-panel - (remq module-browser-panel l)))) - (with-handlers ([exn:fail? void]) - (send module-browser-parent-panel set-percentages (list p (- 1 p)))) - (send module-browser-parent-panel end-container-sequence) - (calculate-module-browser))) - - (define/private (update-module-browser-name-length i) - (send module-browser-pb set-name-length - (case i - [(0) 'short] - [(1) 'medium] - [(2) 'long] - [(3) 'very-long]))) - - (define/private (mouse-currently-over snips) - (if (null? snips) - (update-status-line 'plt:module-browser:mouse-over #f) - (let* ([snip (car snips)] - [lines (send snip get-lines)] - [name (or (send snip get-filename) - (send snip get-word))] - [str (if lines - (format (string-constant module-browser-filename-format) name lines) - name)]) - (update-status-line 'plt:module-browser:mouse-over str)))) - - (define/private (calculate-module-browser) - (let ([mod-tab current-tab]) - (let-values ([(old-break-thread old-custodian) (send mod-tab get-breakables)]) - (open-status-line 'plt:module-browser) - (update-status-line 'plt:module-browser status-compiling-definitions) - (send module-browser-button enable #f) - (send module-browser-lib-path-check-box enable #f) - (send module-browser-planet-path-check-box enable #f) - (send module-browser-name-length-choice enable #f) - (disable-evaluation-in-tab current-tab) - (drracket:module-overview:fill-pasteboard - module-browser-pb - (drracket:language:make-text/pos - definitions-text - 0 - (send definitions-text last-position)) - (λ (str) (update-status-line - 'plt:module-browser - (format module-browser-progress-constant str))) - (λ (user-thread user-custodian) - (send mod-tab set-breakables user-thread user-custodian))) - (send mod-tab set-breakables old-break-thread old-custodian) - (send mod-tab enable-evaluation) - (send module-browser-button enable #t) - (send module-browser-lib-path-check-box enable #t) - (send module-browser-planet-path-check-box enable #t) - (send module-browser-name-length-choice enable #t) - (close-status-line 'plt:module-browser)))) - - ;; set-directory : text -> void - ;; sets the current-directory and current-load-relative-directory - ;; based on the file saved in the definitions-text - (define/private (set-directory definitions-text) - (let* ([tmp-b (box #f)] - [fn (send definitions-text get-filename tmp-b)]) - (unless (unbox tmp-b) - (when fn - (let-values ([(base name dir?) (split-path fn)]) - (current-directory base) - (current-load-relative-directory base)))))) - - - ; - ; - ; - ; - ; - ; - ; ; ;; ;; ;;; ; ;; ; ; ;;; - ; ;; ;; ; ; ; ;; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ;; - ; ; ; ; ;;;;;; ; ; ; ; ;; - ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ;; ; - ; ; ; ; ;;;; ; ; ;; ; ;;; - ; - ; - ; - - (define execute-menu-item #f) - (define file-menu:print-interactions-item #f) - (define file-menu:create-new-tab-item #f) - - (define/override (file-menu:between-new-and-open file-menu) - (set! file-menu:create-new-tab-item - (new menu:can-restore-menu-item% - (label (string-constant new-tab)) - (shortcut #\=) - (parent file-menu) - (callback - (λ (x y) - (create-new-tab)))))) - [define/override file-menu:between-open-and-revert - (lambda (file-menu) - (super file-menu:between-open-and-revert file-menu) - (make-object separator-menu-item% file-menu))] - (define close-tab-menu-item #f) - (define/override (file-menu:between-close-and-quit file-menu) - (set! close-tab-menu-item - (new (get-menu-item%) - (label (string-constant close-tab)) - (demand-callback - (λ (item) - (send item enable (1 . < . (send tabs-panel get-number))))) - (parent file-menu) - (callback - (λ (x y) - (close-current-tab))))) - (super file-menu:between-close-and-quit file-menu)) - - (define/override (file-menu:save-string) (string-constant save-definitions)) - (define/override (file-menu:save-as-string) (string-constant save-definitions-as)) - (define/override (file-menu:between-save-as-and-print file-menu) - (let ([sub-menu (make-object menu% (string-constant save-other) file-menu)]) - (make-object menu:can-restore-menu-item% - (string-constant save-definitions-as-text) - sub-menu - (λ (_1 _2) - (let ([filename (send definitions-text put-file #f #f)]) - (when filename - (send definitions-text save-file/gui-error filename 'text))))) - (make-object menu:can-restore-menu-item% - (string-constant save-interactions) - sub-menu - (λ (_1 _2) - (send interactions-text save-file/gui-error))) - (make-object menu:can-restore-menu-item% - (string-constant save-interactions-as) - sub-menu - (λ (_1 _2) - (let ([filename (send interactions-text put-file #f #f)]) - (when filename - (send interactions-text save-file/gui-error filename 'standard))))) - (make-object menu:can-restore-menu-item% - (string-constant save-interactions-as-text) - sub-menu - (λ (_1 _2) - (let ([filename (send interactions-text put-file #f #f)]) - (when filename - (send interactions-text save-file/gui-error filename 'text))))) - (make-object separator-menu-item% file-menu) - (set! transcript-menu-item - (make-object menu:can-restore-menu-item% - (string-constant log-definitions-and-interactions) - file-menu - (λ (x y) - (if transcript - (stop-transcript) - (start-transcript))))) - (make-object separator-menu-item% file-menu) - (super file-menu:between-save-as-and-print file-menu))) - - [define/override file-menu:print-string (λ () (string-constant print-definitions))] - (define/override (file-menu:between-print-and-close file-menu) - (set! file-menu:print-interactions-item - (make-object menu:can-restore-menu-item% - (string-constant print-interactions) - file-menu - (λ (_1 _2) - (send interactions-text print - #t - #t - (preferences:get 'framework:print-output-mode))))) - (super file-menu:between-print-and-close file-menu)) - - (define/override (edit-menu:between-find-and-preferences edit-menu) - (super edit-menu:between-find-and-preferences edit-menu) - (new menu:can-restore-menu-item% - [label (string-constant complete-word)] - [shortcut #\/] - [parent edit-menu] - [demand-callback - (λ (mi) - (send mi enable - (let ([ed (get-edit-target-object)]) - (and ed - (is-a? ed text:autocomplete<%>)))))] - [callback (λ (x y) - (send (get-edit-target-object) auto-complete))]) - (add-modes-submenu edit-menu)) - - (define/override (edit-menu:between-select-all-and-find edit-menu) - (new menu:can-restore-checkable-menu-item% - [label (string-constant overwrite-mode)] - [parent edit-menu] - [demand-callback - (λ (mi) - (let ([target (get-edit-target-object)]) - (send mi enable (is-a? target text%)) - (when (is-a? target text%) - (send mi check (and target (send target get-overwrite-mode))))))] - [callback (λ (x y) - (let ([target (get-edit-target-object)]) - (send target set-overwrite-mode - (not (send target get-overwrite-mode)))))]) - (super edit-menu:between-select-all-and-find edit-menu)) - - ;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key))) - (define capability-menu-items (make-hasheq)) - (define/public (register-capability-menu-item key menu) - (let ([items (send menu get-items)]) - (when (null? items) - (error 'register-capability-menu-item "menu ~e has no items" menu)) - (let* ([menu-item (last items)] - [this-one (list menu-item (- (length items) 1) key)] - [old-ones (hash-ref capability-menu-items menu (λ () '()))]) - (hash-set! capability-menu-items menu (cons this-one old-ones))))) - - (define/private (update-items/capability menu) - (let* ([old-items (send menu get-items)] - [new-items (begin '(get-items/capability menu) - old-items)]) - (unless (equal? old-items new-items) - (for-each (λ (i) (send i delete)) old-items) - (for-each (λ (i) (send i restore)) new-items)))) - (define/private (get-items/capability menu) - (let loop ([capability-items (reverse (hash-ref capability-menu-items menu '()))] - [all-items (send menu get-items)] - [i 0]) - (cond - [(null? capability-items) all-items] - [else - (let* ([cap-item-list (car capability-items)] - [cap-item (list-ref cap-item-list 0)] - [cap-num (list-ref cap-item-list 1)] - [cap-key (list-ref cap-item-list 2)]) - (cond - [(= cap-num i) - (let ([is-on? (get-current-capability-value cap-key)]) - (cond - [is-on? - (cond - [(null? all-items) - (cons cap-item (loop (cdr capability-items) null (+ i 1)))] - [(eq? (car all-items) cap-item) - (cons cap-item (loop (cdr capability-items) (cdr all-items) (+ i 1)))] - [else - (cons cap-item (loop (cdr capability-items) all-items (+ i 1)))])] - [else - (cond - [(null? all-items) - (loop (cdr capability-items) null (+ i 1))] - [(eq? (car all-items) cap-item) - (loop (cdr capability-items) (cdr all-items) (+ i 1))] - [else - (loop (cdr capability-items) all-items (+ i 1))])]))] - [else (cons (car all-items) - (loop capability-items - (cdr all-items) - (+ i 1)))]))]))) - - (define/private (get-current-capability-value key) - (let* ([language-settings (send (get-definitions-text) get-next-settings)] - [new-language (drracket:language-configuration:language-settings-language language-settings)]) - (send new-language capability-value key))) - - (define language-menu 'uninited-language-menu) - (define language-specific-menu 'language-specific-menu-not-yet-init) - (define insert-menu 'insert-menu-not-yet-init) - (define/public (get-insert-menu) insert-menu) - (define/public (get-special-menu) insert-menu) - - (define/public (choose-language-callback) - (let ([new-settings (drracket:language-configuration:language-dialog - #f - (send definitions-text get-next-settings) - this)]) - (when new-settings - (send definitions-text set-next-settings new-settings)))) - - ;; must be called from on-demand (on each menu click), or the state won't be handled properly - (define/private (update-teachpack-menu) - (for-each (λ (item) (send item delete)) teachpack-items) - (let ([tp-callbacks (get-current-capability-value 'drscheme:teachpack-menu-items)]) - (cond - [tp-callbacks - (let* ([language (drracket:language-configuration:language-settings-language - (send (get-definitions-text) get-next-settings))] - [settings (drracket:language-configuration:language-settings-settings - (send (get-definitions-text) get-next-settings))] - [tp-names ((teachpack-callbacks-get-names tp-callbacks) settings)] - [update-settings - (λ (settings) - (send (get-definitions-text) set-next-settings - (drracket:language-configuration:language-settings language settings)) - (send (get-definitions-text) teachpack-changed))]) - (set! teachpack-items - (list* - (make-object separator-menu-item% language-menu) - (new menu:can-restore-menu-item% - [label (string-constant add-teachpack-menu-item-label)] - [parent language-menu] - [callback - (λ (_1 _2) - (update-settings ((teachpack-callbacks-add tp-callbacks) settings this)))]) - (let ([mi (new menu:can-restore-menu-item% - [label (string-constant clear-all-teachpacks-menu-item-label)] - [parent language-menu] - [callback - (λ (_1 _2) - (update-settings ((teachpack-callbacks-remove-all tp-callbacks) settings)))])]) - - (send mi enable (not (null? tp-names))) - mi) - (map (λ (name) - (new menu:can-restore-menu-item% - [label (gui-utils:format-literal-label (string-constant clear-teachpack) name)] - [parent language-menu] - [callback - (λ (item evt) - (update-settings ((teachpack-callbacks-remove tp-callbacks) settings name)))])) - tp-names))))] - [else - (set! teachpack-items - (list - (new menu:can-restore-menu-item% - [label (string-constant add-teachpack-menu-item-label)] - [parent language-menu] - [callback - (λ (_1 _2) - (message-box (string-constant drscheme) - (gui-utils:format-literal-label (string-constant teachpacks-only-in-languages) - (apply - string-append - (reverse - (filter - values - (map (λ (l) - (and - (send l capability-value 'drscheme:teachpack-menu-items) - (format "\n ~a" (send l get-language-name)))) - (drracket:language-configuration:get-languages)))))) - this))])))]))) - - (define/private (initialize-menus) - (let* ([mb (get-menu-bar)] - [language-menu-on-demand (λ (menu-item) (update-teachpack-menu))] - [_ (set! language-menu (make-object (get-menu%) - (string-constant language-menu-name) - mb - #f - language-menu-on-demand))] - [_ (set! language-specific-menu (new (get-menu%) - [label (drracket:language:get-capability-default - 'drscheme:language-menu-title)] - [parent mb]))] - [send-method - (λ (method) - (λ (_1 _2) - (let ([text (get-focus-object)]) - (when (is-a? text scheme:text<%>) - (method text)))))] - [show/hide-capability-menus - (λ () - (for-each (λ (menu) (update-items/capability menu)) - (send (get-menu-bar) get-items)))]) - - (make-object menu:can-restore-menu-item% - (string-constant choose-language-menu-item-label) - language-menu - (λ (_1 _2) (choose-language-callback)) - #\l) - - (set! execute-menu-item - (make-object menu:can-restore-menu-item% - (string-constant execute-menu-item-label) - language-specific-menu - (λ (_1 _2) (execute-callback)) - #\t - (string-constant execute-menu-item-help-string))) - (make-object menu:can-restore-menu-item% - (string-constant ask-quit-menu-item-label) - language-specific-menu - (λ (_1 _2) (send current-tab break-callback)) - #\b - (string-constant ask-quit-menu-item-help-string)) - (make-object menu:can-restore-menu-item% - (string-constant force-quit-menu-item-label) - language-specific-menu - (λ (_1 _2) (send interactions-text kill-evaluation)) - #\k - (string-constant force-quit-menu-item-help-string)) - (when (custodian-memory-accounting-available?) - (new menu-item% - [label (string-constant limit-memory-menu-item-label)] - [parent language-specific-menu] - [callback - (λ (item b) - (let ([num (get-mbytes this - (let ([limit (send interactions-text get-custodian-limit)]) - (and limit - (floor (/ limit 1024 1024)))))]) - (when num - (cond - [(eq? num #t) - (preferences:set 'drracket:child-only-memory-limit #f) - (send interactions-text set-custodian-limit #f)] - [else - (preferences:set 'drracket:child-only-memory-limit - (* 1024 1024 num)) - (send interactions-text set-custodian-limit - (* 1024 1024 num))]))))])) - (new menu:can-restore-menu-item% - (label (string-constant clear-error-highlight-menu-item-label)) - (parent language-specific-menu) - (callback - (λ (_1 _2) - (let* ([tab (get-current-tab)] - [ints (send tab get-ints)] - [defs (send tab get-defs)]) - (send ints reset-error-ranges) - (send defs clear-test-coverage)))) - (help-string (string-constant clear-error-highlight-item-help-string)) - (demand-callback - (λ (item) - (let* ([tab (get-current-tab)] - [ints (send tab get-ints)]) - (send item enable (or (send ints get-error-ranges) - (send tab get-test-coverage-info-visible?))))))) - (make-object separator-menu-item% language-specific-menu) - (make-object menu:can-restore-menu-item% - (string-constant create-executable-menu-item-label) - language-specific-menu - (λ (x y) (create-executable this))) - (make-object menu:can-restore-menu-item% - (string-constant module-browser...) - language-specific-menu - (λ (x y) (drracket:module-overview:module-overview this))) - (let () - (define base-title (format (string-constant module-browser-in-file) "")) - (define (update-menu-item i) - (define fn (send definitions-text get-filename)) - (send i set-label - (if fn - (let* ([str (path->string fn)] - [overage (- 200 - (+ (string-length str) - (string-length base-title)))]) - (format (string-constant module-browser-in-file) - (if (overage . >= . 0) - str - (string-append "..." - (substring str - (+ (- (string-length str) (abs overage)) 3) - (string-length str)))))) - (string-constant module-browser-no-file))) - (send i enable fn)) - (define i (new menu:can-restore-menu-item% - [label base-title] - [parent language-specific-menu] - [demand-callback update-menu-item] - [callback (λ (x y) - (define fn (send definitions-text get-filename)) - (when fn - (drracket:module-overview:module-overview/file fn this)))])) - (update-menu-item i)) - (make-object separator-menu-item% language-specific-menu) - - (let ([cap-val - (λ () - (let* ([tab (get-current-tab)] - [defs (send tab get-defs)] - [settings (send defs get-next-settings)] - [language (drracket:language-configuration:language-settings-language settings)]) - (send language capability-value 'drscheme:tabify-menu-callback)))]) - (new menu:can-restore-menu-item% - [label (string-constant reindent-menu-item-label)] - [parent language-specific-menu] - [demand-callback (λ (m) (send m enable (cap-val)))] - [callback (send-method - (λ (x) - (let ([f (cap-val)]) - (when f - (f x - (send x get-start-position) - (send x get-end-position))))))]) - - (new menu:can-restore-menu-item% - [label (string-constant reindent-all-menu-item-label)] - [parent language-specific-menu] - [callback - (send-method - (λ (x) - (let ([f (cap-val)]) - (when f - (f x 0 (send x last-position))))))] - [shortcut #\i] - [demand-callback (λ (m) (send m enable (cap-val)))])) - - (make-object menu:can-restore-menu-item% - (string-constant box-comment-out-menu-item-label) - language-specific-menu - (send-method (λ (x) (send x box-comment-out-selection)))) - (make-object menu:can-restore-menu-item% - (string-constant semicolon-comment-out-menu-item-label) - language-specific-menu - (send-method (λ (x) (send x comment-out-selection)))) - (make-object menu:can-restore-menu-item% - (string-constant uncomment-menu-item-label) - language-specific-menu - (λ (x y) - (let ([text (get-focus-object)]) - (when (is-a? text text%) - (let ([admin (send text get-admin)]) - (cond - [(is-a? admin editor-snip-editor-admin<%>) - (let ([es (send admin get-snip)]) - (cond - [(is-a? es comment-box:snip%) - (let ([es-admin (send es get-admin)]) - (when es-admin - (let ([ed (send es-admin get-editor)]) - (when (is-a? ed scheme:text<%>) - (send ed uncomment-box/selection)))))] - [else (send text uncomment-selection)]))] - [else (send text uncomment-selection)])))))) - - (set! insert-menu - (new (get-menu%) - [label (string-constant insert-menu)] - [parent mb] - [demand-callback - (λ (insert-menu) - ;; just here for convience -- it actually works on all menus, not just the special menu - (show/hide-capability-menus))])) - - (let ([has-editor-on-demand - (λ (menu-item) - (let ([edit (get-edit-target-object)]) - (send menu-item enable (and edit (is-a? edit editor<%>)))))] - [callback - (λ (menu evt) - (let ([edit (get-edit-target-object)]) - (when (and edit - (is-a? edit editor<%>)) - (let ([number (get-fraction-from-user this)]) - (when number - (send edit insert - (number-snip:make-fraction-snip number #f))))) - #t))] - [insert-lambda - (λ () - (let ([edit (get-edit-target-object)]) - (when (and edit - (is-a? edit editor<%>)) - (send edit insert "\u03BB"))) - #t)] - [insert-large-semicolon-letters - (λ () - (let ([edit (get-edit-target-object)]) - (when edit - (let ([language-settings (send definitions-text get-next-settings)]) - (let-values ([(comment-prefix comment-character) - (if language-settings - (send (drracket:language-configuration:language-settings-language - language-settings) - get-comment-character) - (values ";" #\;))]) - (insert-large-letters comment-prefix comment-character edit this))))))] - [c% (get-menu-item%)]) - - (frame:add-snip-menu-items - insert-menu - c% - (λ (item) - (let ([label (send item get-label)]) - (cond - [(equal? label (string-constant insert-comment-box-menu-item-label)) - (register-capability-menu-item 'drscheme:special:insert-comment-box insert-menu)] - [(equal? label (string-constant insert-image-item)) - (register-capability-menu-item 'drscheme:special:insert-image insert-menu)])))) - - (make-object c% (string-constant insert-fraction-menu-item-label) - insert-menu callback - #f #f - has-editor-on-demand) - (register-capability-menu-item 'drscheme:special:insert-fraction insert-menu) - - (make-object c% (string-constant insert-large-letters...) - insert-menu - (λ (x y) (insert-large-semicolon-letters)) - #f #f - has-editor-on-demand) - (register-capability-menu-item 'drscheme:special:insert-large-letters insert-menu) - - (make-object c% (string-constant insert-lambda) - insert-menu - (λ (x y) (insert-lambda)) - #\\ - #f - has-editor-on-demand) - (register-capability-menu-item 'drscheme:special:insert-lambda insert-menu)) - - (new menu:can-restore-menu-item% - [label (if (show-line-numbers?) - (string-constant hide-line-numbers/menu) - (string-constant show-line-numbers/menu))] - [parent (get-show-menu)] - [callback (lambda (self event) - (define value (preferences:get 'drracket:show-line-numbers?)) - (send self set-label - (if value - (string-constant show-line-numbers/menu) - (string-constant hide-line-numbers/menu))) - (preferences:set 'drracket:show-line-numbers? (not value)) - (show-line-numbers! (not value)))]) - - (make-object separator-menu-item% (get-show-menu)) - - (new menu:can-restore-menu-item% - (shortcut (if (eq? (system-type) 'macosx) #f #\m)) - (label (string-constant split-menu-item-label)) - (parent (get-show-menu)) - (callback (λ (x y) (split))) - (demand-callback (λ (item) (split-demand item)))) - (new menu:can-restore-menu-item% - (shortcut (if (eq? (system-type) 'macosx) #f #\m)) - (shortcut-prefix (if (eq? (system-type) 'macosx) - (get-default-shortcut-prefix) - (cons 'shift (get-default-shortcut-prefix)))) - (label (string-constant collapse-menu-item-label)) - (parent (get-show-menu)) - (callback (λ (x y) (collapse))) - (demand-callback (λ (item) (collapse-demand item)))) - - (frame:reorder-menus this))) - - ; - ; - ; - ; - ; ++-@@- -+@+- +++: :++ - ; +@@-+@ -@-:-@--@- -@ - ; :@: @: @+ ++ @::@::@ - ; :@ @: @@@@@@@ +--@--* - ; :@ @: @- -@+*+@: - ; -@: :@- +@:::+@ :@@:@@ - ; @@@ +@@: +@@@+: ++ ++ - ; - ; - ; - - (define definitions-text (new (drracket:get/extend:get-definitions-text))) - - ;; tabs : (listof tab) - (define tabs (list (new (drracket:get/extend:get-tab) - (defs definitions-text) - (frame this) - (i 0) - (defs-shown? #t) - (ints-shown? #t)))) - (define/public-final (get-tabs) tabs) - - ;; current-tab : tab - ;; corresponds to the tabs-panel's active button. - (define current-tab (car tabs)) - - (define interactions-text (new (drracket:get/extend:get-interactions-text) - (context (car tabs)))) - (send (car tabs) set-ints interactions-text) - - (init-definitions-text (car tabs)) - - (super-new - [filename filename] - [style '(toolbar-button)] - [size-preferences-key 'drracket:unit-window-size] - [position-preferences-key 'drracket:unit-window-position]) - - (initialize-menus) - - - ; - ; - ; - ; ; ; - ; ; ; - ; ; ; ; - ; ; ;; ;;; ; ;; ;;; ; ; ;;; ; ; ;;; ; ; ;;;; - ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;; ; ; ;;;;;; ; ; ;;;; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; - ; ; ;; ;;;;; ; ; ;;;; ; ; ;;;;; ; ;;; ;; ; ;; - ; ; ; - ; ; ; - ; ; ; - - - (define toolbar/rest-panel (new vertical-panel% [parent (get-area-container)])) - - ;; most contain only top-panel (or nothing) - (define top-outer-panel (new horizontal-panel% - [parent toolbar/rest-panel] - [alignment '(right top)] - [stretchable-height #f])) - - [define top-panel (make-object horizontal-panel% top-outer-panel)] - [define name-panel (new horizontal-panel% - (parent top-panel) - (alignment '(left center)) - (stretchable-width #f) - (stretchable-height #f))] - (define panel-with-tabs (new vertical-panel% - (parent (get-definitions/interactions-panel-parent)))) - (define tabs-panel (new tab-panel% - (font small-control-font) - (parent panel-with-tabs) - (stretchable-height #f) - (style '(deleted no-border)) - (choices '("first name")) - (callback (λ (x y) - (let ([sel (send tabs-panel get-selection)]) - (when sel - (change-to-nth-tab sel))))))) - [define resizable-panel (new (if (preferences:get 'drracket:defs/ints-horizontal) - horizontal-dragable/def-int% - vertical-dragable/def-int%) - (unit-frame this) - (parent panel-with-tabs))] - [define orientation-callback (λ (p v) (send resizable-panel set-orientation v))] - (preferences:add-callback 'drracket:defs/ints-horizontal orientation-callback #t) - - [define definitions-canvas #f] - (initialize-definitions-canvas) - [define definitions-canvases (list definitions-canvas)] - [define interactions-canvas (new (drracket:get/extend:get-interactions-canvas) - (parent resizable-panel) - (editor interactions-text))] - [define interactions-canvases (list interactions-canvas)] - - - (define/public (get-definitions-canvases) - ;; before definition, just return null - (if (pair? definitions-canvases) - definitions-canvases - null)) - (define/public (get-interactions-canvases) - ;; before definition, just return null - (if (pair? interactions-canvases) - interactions-canvases - null)) - - (public get-definitions-canvas get-interactions-canvas) - [define get-definitions-canvas (λ () definitions-canvas)] - [define get-interactions-canvas (λ () interactions-canvas)] - - (set! save-button - (new switchable-button% - [parent top-panel] - [callback (λ (x) (when definitions-text - (save) - (send definitions-canvas focus)))] - [bitmap save-bitmap] - [label (string-constant save-button-label)])) - (register-toolbar-button save-button) - - (set! name-message (new drs-name-message% [parent name-panel])) - (send name-message stretchable-width #t) - (send name-message set-allow-shrinking 200) - [define teachpack-items null] - [define break-button (void)] - [define execute-button (void)] - [define button-panel (new horizontal-panel% [parent top-panel] [spacing 2])] - (define/public (get-execute-button) execute-button) - (define/public (get-break-button) break-button) - (define/public (get-button-panel) button-panel) - - (inherit get-info-panel) - - (define color-status-canvas - (and checkout-or-nightly? - (let () - (define on-string "()") - (define color-status-canvas - (new canvas% - [parent (get-info-panel)] - [style '(transparent)] - [stretchable-width #f] - [paint-callback - (λ (c dc) - (when (number? th) - (unless color-valid? - (let-values ([(cw ch) (send c get-client-size)]) - (send dc set-font small-control-font) - (send dc draw-text on-string 0 (- (/ ch 2) (/ th 2)))))))])) - (define-values (tw th ta td) (send (send color-status-canvas get-dc) get-text-extent on-string small-control-font)) - (send color-status-canvas min-width (inexact->exact (ceiling tw))) - color-status-canvas))) - (define color-valid? #t) - (define/public (set-color-status! v?) - (when color-status-canvas - (set! color-valid? v?) - (send color-status-canvas refresh-now))) - - (define running-canvas - (new running-canvas% [parent (get-info-panel)])) - - (define bug-icon - (let* ([info-panel (get-info-panel)] - [btn - (new switchable-button% - [parent info-panel] - [callback (λ (x) (show-saved-bug-reports-window))] - [bitmap very-small-planet-bitmap] - [vertical-tight? #t] - [label (string-constant show-planet-contract-violations)])]) - (send btn set-label-visible #f) - (send info-panel change-children - (λ (l) - (cons btn (remq* (list btn) l)))) - btn)) - (define/private (set-bug-label v) - (if (null? v) - (send bug-icon show #f) - (send bug-icon show #t))) - (set-bug-label (preferences:get 'drracket:saved-bug-reports)) - (define remove-bug-icon-callback - (preferences:add-callback - 'drracket:saved-bug-reports - (λ (p v) - (set-bug-label v)))) - - [define func-defs-canvas (new func-defs-canvas% - (parent name-panel) - (frame this))] - - (set! execute-button - (new switchable-button% - [parent button-panel] - [callback (λ (x) (execute-callback))] - [bitmap execute-bitmap] - [label (string-constant execute-button-label)])) - (register-toolbar-button execute-button) - - (set! break-button - (new switchable-button% - [parent button-panel] - [callback (λ (x) (send current-tab break-callback))] - [bitmap break-bitmap] - [label (string-constant break-button-label)])) - (register-toolbar-button break-button) - - (send button-panel stretchable-height #f) - (send button-panel stretchable-width #f) - - (send top-panel change-children - (λ (l) - (list name-panel save-button - (make-object vertical-panel% top-panel) ;; spacer - button-panel))) - - (send top-panel stretchable-height #f) - (inherit get-label) - (let ([m (send definitions-canvas get-editor)]) - (set-save-init-shown? - (and m (send m is-modified?)))) - - (define language-message - (let* ([info-panel (get-info-panel)] - [p (new vertical-panel% - [parent info-panel] - [alignment '(left center)])] - [language-message (new language-label-message% [parent p] [frame this])]) - (send info-panel change-children - (λ (l) - (list* p - (remq* (list p) - l)))) - language-message)) - - (update-save-message) - (update-save-button) - (language-changed) - - (cond - [filename - (set! definitions-shown? #t) - (set! interactions-shown? #f)] - [else - (set! definitions-shown? #t) - (set! interactions-shown? #t)]) - - (update-shown) - - (when (= 2 (length (send resizable-panel get-children))) - (send resizable-panel set-percentages - (let ([p (preferences:get 'drracket:unit-window-size-percentage)]) - (list p (- 1 p))))) - - (set-label-prefix (string-constant drscheme)) - (set! newest-frame this) - ;; a callback might have happened that initializes set-color-status! before the - ;; definitions text is connected to the frame, so we do an extra initialization - ;; now, once we know we have the right connection - (set-color-status! (send definitions-text is-lexer-valid?)) - (send definitions-canvas focus))) - - ;; get-define-popup-name : (or/c #f (cons/c string? string?) (list/c string? string? string)) boolean -> (or/c #f string?) - (define (get-define-popup-name info vertical?) - (and info - (if vertical? - (if (pair? (cdr info)) - (list-ref info 2) - "δ") - (if (pair? (cdr info)) - (list-ref info 1) - (cdr info))))) - - - (define execute-warning-canvas% - (class canvas% - (inherit stretchable-height get-dc get-client-size min-height) - (init-field message) - (define/public (set-message _msg) (set! message _msg)) - - (define/override (on-paint) - (let ([dc (get-dc)]) - (let-values ([(w h) (get-client-size)]) - (send dc set-pen "yellow" 1 'solid) - (send dc set-brush "yellow" 'solid) - (send dc draw-rectangle 0 0 w h) - (when message - (let* ([base normal-control-font] - [face (send base get-face)]) - (if face - (send dc set-font (send the-font-list find-or-create-font - (send base get-point-size) - face - (send base get-family) - (send base get-style) - 'bold)) - (send dc set-font (send the-font-list find-or-create-font - (send base get-point-size) - (send base get-family) - (send base get-style) - 'bold)))) - (let-values ([(tw th _1 _2) (send dc get-text-extent message)]) - (send dc draw-text message - (floor (- (/ w 2) (/ tw 2))) - (floor (- (/ h 2) (/ th 2))))))))) - (super-new [style '(no-focus)]) - (let-values ([(w h d a) (send (get-dc) get-text-extent "Xy")]) - (min-height (+ 4 (floor (inexact->exact h))))))) - - -; -; -; -; -; ;;; -; -; ;;; ;;;; ;;; ;;; ;; ;;; ;; ;;; ;;; ;; ;; ;;; -; ;;;;;;;; ;;; ;;;;;;; ;;;;;;; ;;; ;;;;;;; ;;;;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; -; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; -; ;;; -; ;;;;;; -; -; - - - (define running-bitmap (include-bitmap (lib "icons/b-run.png"))) - (define waiting-bitmap (include-bitmap (lib "icons/b-wait.png"))) - (define waiting2-bitmap (include-bitmap (lib "icons/b-wait2.png"))) - (define running/waiting-bitmaps (list running-bitmap waiting-bitmap waiting2-bitmap)) - (define running-canvas% - (class canvas% - (inherit get-dc refresh get-client-size) - (define/public (set-running r?) - (unless (eq? r? is-running?) - (set! is-running? r?) - (refresh))) - (define is-running? #f) - (define toggle? #t) - (define timer #f) - (define inside? #f) - - (define/override (on-event evt) - (let-values ([(w h) (get-client-size)]) - (let ([new-inside? - (and (< 0 (send evt get-x) w) - (< 0 (send evt get-y) h))] - [old-inside? inside?]) - (set! inside? new-inside?) - (cond - [(and new-inside? (not old-inside?)) - (unless is-running? - (set! timer - (new timer% - [notify-callback - (λ () - (set! toggle? (not toggle?)) - (refresh))] - [interval 200])))] - [(and (not new-inside?) old-inside? timer) - (send timer stop) - (set! timer #f)])))) - - (define/override (on-paint) - (let ([dc (get-dc)] - [bm - (if is-running? - running-bitmap - (if toggle? - waiting-bitmap - waiting2-bitmap))]) - (let-values ([(cw ch) (get-client-size)]) - (send dc draw-bitmap bm - (- (/ cw 2) (/ (send bm get-width) 2)) - (- (/ ch 2) (/ (send bm get-height) 2)) - 'solid - (send the-color-database find-color "black") - (send bm get-loaded-mask))))) - - (super-new [stretchable-width #f] - [stretchable-height #f] - [style '(transparent no-focus)]) - (inherit min-width min-height) - (min-width (apply max (map (λ (x) (send x get-width)) running/waiting-bitmaps))) - (min-height (apply max (map (λ (x) (send x get-height)) running/waiting-bitmaps))))) - - ;; get-mbytes : top-level-window -> (union #f ;; cancel - ;; integer[>=100] ;; a limit - ;; #t) ;; no limit - (define (get-mbytes parent current-limit) - (define d (new dialog% - [label (string-constant drscheme)] - [parent parent])) - (define msg1 (new message% - [parent d] - [label (string-constant limit-memory-msg-1)])) - (define msg1.5 (new message% - [parent d] - [label (string-constant limit-memory-msg-2)])) - - (define outer-hp (new horizontal-panel% [parent d] [alignment '(center bottom)])) - (define rb (new radio-box% - [label #f] - [choices (list (string-constant limit-memory-unlimited) (string-constant limit-memory-limited))] - [callback (λ (a b) (grayizie))] - [parent outer-hp])) - - (define (grayizie) - (case (send rb get-selection) - [(0) - (send tb enable #f) - (send msg2 enable #f) - (background gray-foreground-sd)] - [(1) - (send tb enable #t) - (send msg2 enable #t) - (background black-foreground-sd) - (let ([e (send tb get-editor)]) - (send e set-position 0 (send e last-position))) - (send tb focus)]) - (update-ok-button-state)) - - (define hp (new horizontal-panel% - [parent outer-hp] - [stretchable-height #f] - [stretchable-width #f])) - - (define tb - (new text-field% - [label #f] - [parent hp] - [init-value (if current-limit - (format "~a" current-limit) - "64")] - [stretchable-width #f] - [min-width 100] - [callback - (λ (tf e) - (let ([ed (send tf get-editor)]) - (cond - [(is-valid-number? ed) - (background clear-sd)] - [else - (background yellow-sd)])) - (update-ok-button-state))])) - - (define (update-ok-button-state) - (case (send rb get-selection) - [(0) (send ok-button enable #t)] - [(1) (send ok-button enable (is-valid-number? (send tb get-editor)))])) - - (define msg2 (new message% [parent hp] [label (string-constant limit-memory-megabytes)])) - (define bp (new horizontal-panel% [parent d])) - (define-values (ok-button cancel-button) - (gui-utils:ok/cancel-buttons - bp - (λ (a b) - (case (send rb get-selection) - [(0) (set! result #t)] - [(1) (set! result (string->number (send (send tb get-editor) get-text)))]) - (send d show #f)) - (λ (a b) (send d show #f)))) - - (define result #f) - - (define clear-sd (make-object style-delta%)) - (define yellow-sd (make-object style-delta%)) - - (define black-foreground-sd (make-object style-delta%)) - (define gray-foreground-sd (make-object style-delta%)) - - (define (is-valid-number? txt) - (let* ([n (string->number (send txt get-text))]) - (and n - (integer? n) - (1 . <= . n)))) - - (define (background sd) - (let ([txt (send tb get-editor)]) - (send txt change-style sd 0 (send txt last-position)))) - - (send clear-sd set-delta-background "white") - (send yellow-sd set-delta-background "yellow") - (send black-foreground-sd set-delta-foreground "black") - (send gray-foreground-sd set-delta-foreground "gray") - (send d set-alignment 'left 'center) - (send bp set-alignment 'right 'center) - (when current-limit - (send rb set-selection 1)) - (update-ok-button-state) - (grayizie) - (send tb focus) - (let ([e (send tb get-editor)]) - (send e set-position 0 (send e last-position))) - (send d show #t) - result) - - - - (define (limit-length l n) - (let loop ([l l] - [n n]) - (cond - [(or (null? l) (zero? n)) null] - [else (cons (car l) (loop (cdr l) (- n 1)))]))) - (define (remove-duplicate-languages l) - (reverse - (let loop ([l (reverse l)]) - (cond - [(null? l) l] - [else - (if (member (car (car l)) (map car (cdr l))) - (loop (cdr l)) - (cons (car l) (loop (cdr l))))])))) - - (define language-label-message% - (class name-message% - (init-field frame) - (inherit refresh) - - (inherit set-message) - (define yellow? #f) - (define/override (get-background-color) (and yellow? "yellow")) - (define/public (set-yellow y?) - (set! yellow? y?) - (refresh)) - (define/public (set-yellow/lang y? lang) - (set-message #f lang) - (set-yellow y?)) - - (define/override (fill-popup menu reset) - (let ([added-one? #f]) - (send (new menu-item% - [label (string-constant recent-languages)] - [callback void] - [parent menu]) - enable #f) - (for-each - (λ (name/settings) - (let* ([name (car name/settings)] - [marshalled-settings (cdr name/settings)] - [lang (ormap - (λ (l) (and (equal? (send l get-language-name) name) l)) - (drracket:language-configuration:get-languages))]) - (when lang - ;; this test can fail when a language has been added wrongly via the tools interface - ;; just ignore that menu item, in that case. - (let ([settings (or (send lang unmarshall-settings marshalled-settings) - (send lang default-settings))]) - (when lang - (set! added-one? #t) - (new menu-item% - [parent menu] - [label (send lang get-language-name)] - [callback - (λ (x y) - (send (send frame get-definitions-text) - set-next-settings - (drracket:language-configuration:language-settings - lang - settings)))])))))) - (preferences:get 'drracket:recent-language-names)) - (unless added-one? - (send (new menu-item% - [label (string-append - " << " - (string-constant no-recently-chosen-languages) - " >>")] - [parent menu] - [callback void]) - enable #f)) - (new separator-menu-item% [parent menu])) - (new menu-item% - [label (string-constant choose-language-menu-item-label)] - [parent menu] - [callback - (λ (x y) - (send frame choose-language-callback))])) - - (super-new [label ""] - [font small-control-font] - [string-constant-untitled (string-constant untitled)] - [string-constant-no-full-name-since-not-saved - (string-constant no-full-name-since-not-saved)]) - - (inherit set-allow-shrinking) - (set-allow-shrinking 100))) - - - -; -; -; -; -; ;;; ; -; ;;; ;;; -; ;;; ;; ;;; ;;; ;; ;;; ;;; ;; ;;;; ;;; ;; ;;; ;;; ;;;;; ;;;; -; ;;;;;;; ;;; ;;; ;;;;;;; ;;;;; ;; ;;; ;;;;;;; ;;;;; ;;;;;;;;; ;;; ;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;;;;;; ;;;;;;; ;;;;;;; ;;; ;;;;;; ;;;;;;; ;;;;; ;;; ;;;; ;; ;;; -; ;;; ;; ;; ;;; ;; ;;; ;;; ;;;; ;;; ;; ;;; ;;; ;;; ;;;; -; ;;; ;;; -; ;;;;;; ;;; -; -; - - - ;; record-saved-bug-report : (listof (cons symbol string)) -> void - ;; =Kernel= =Handler= - (define (record-saved-bug-report table) - (let ([recorded (preferences:get 'drracket:saved-bug-reports)]) - (unless (member table recorded) - (preferences:set 'drracket:saved-bug-reports (shorten-to (cons table recorded) 15))))) - - ;; shorten-to : (listof X) number -> (listof X) - ;; drops items from the end of the list to bring it back down to `n' items - (define (shorten-to l n) - (let loop ([l l] - [n n]) - (cond - [(zero? n) '()] - [(null? l) '()] - [else (cons (car l) (loop (cdr l) (- n 1)))]))) - - (define very-small-planet-bitmap (include-bitmap (lib "icons/very-small-planet.png") 'png/mask)) - - (define saved-bug-reports-window #f) - (define saved-bug-reports-panel #f) - (define (init-saved-bug-reports-window) - (unless saved-bug-reports-window - (let () - (define stupid-internal-define-syntax1 - (set! saved-bug-reports-window (new frame:basic% [label (string-constant drscheme)] [width 600]))) - (define stupid-internal-define-syntax2 - (set! saved-bug-reports-panel - (new vertical-panel% [parent (send saved-bug-reports-window get-area-container)]))) - (define hp (new horizontal-panel% - [parent (send saved-bug-reports-window get-area-container)] - [stretchable-width #f] - [alignment '(right center)])) - (define forget-all (new button% - [label (string-constant bug-track-forget-all)] - [callback - (λ (_1 _2) - (send saved-bug-reports-window show #f) - (preferences:set 'drracket:saved-bug-reports '()))] - [parent hp])) - (void)))) - - (preferences:add-callback - 'drracket:saved-bug-reports - (λ (p v) - (when saved-bug-reports-window - (when (send saved-bug-reports-window is-shown?) - (cond - [(null? v) - (send saved-bug-reports-window show #f)] - [else - (refresh-saved-bug-reports-window v)]))))) - - (define (refresh-saved-bug-reports-window pref) - (send saved-bug-reports-window begin-container-sequence) - (send saved-bug-reports-panel change-children (λ (l) '())) - (for-each - (λ (item) - (let () - (define (lookup k [default ""]) - (let loop ([item item]) - (cond - [(null? item) default] - [else (let ([rib (car item)]) - (if (eq? (car rib) k) - (cdr rib) - (loop (cdr item))))]))) - (define vp - (new vertical-panel% - [style '(border)] - [parent saved-bug-reports-panel] - [stretchable-height #f])) - (define hp - (new horizontal-panel% - [parent vp] - [stretchable-height #f])) - (define first-line-msg - (let ([desc (lookup 'description #f)]) - (and desc - (new message% - [label (read-line (open-input-string desc))] - [parent vp] - [stretchable-width #t] - [font (send (send (editor:get-standard-style-list) find-named-style "Standard") get-font)])))) - (define msg (new message% - [stretchable-width #t] - [label (string-append (lookup 'component "<>") - (let ([v (lookup 'version #f)]) - (if v - (string-append " " v) - "")))] - [parent hp])) - (define forget (new button% - [parent hp] - [callback (λ (x y) (forget-saved-bug-report item))] - [label (string-constant bug-track-forget)])) - (define report (new button% - [parent hp] - [callback (λ (x y) - (forget-saved-bug-report item) - (send-url - (url->string - (drracket:debug:bug-info->ticket-url item))))] - [label (string-constant bug-track-report)])) - (void))) - pref) ;; reverse list so first elements end up on top of list - (send saved-bug-reports-window reflow-container) - (send saved-bug-reports-window end-container-sequence)) - - (define (forget-saved-bug-report item) - (preferences:set 'drracket:saved-bug-reports (remove item (preferences:get 'drracket:saved-bug-reports)))) - - (define (show-saved-bug-reports-window) - (init-saved-bug-reports-window) - (unless (send saved-bug-reports-window is-shown?) - (refresh-saved-bug-reports-window (preferences:get 'drracket:saved-bug-reports))) - (send saved-bug-reports-window show #t)) - - - -; -; -; -; -; ;;;; ;; ; -; ;;; ; ; ; -; ;;;; ;;; ;;;;;;; ;;; ;; ;;; ;;;; ; ; ; -; ;;;; ;;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; ; ; ; -; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ;; -; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;; ; ; ; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ; ; ; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ; ; ; -; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;; ; ;; -; -; -; -; - - - (define -frame% (frame-mixin super-frame%)) - - (define (make-two-way-prefs-dragable-panel% % pref-key) - (class % - (inherit get-percentages) - (define/augment (after-percentage-change) - (let ([percentages (get-percentages)]) - (when (and (pair? percentages) - (pair? (cdr percentages)) - (null? (cddr percentages))) - (preferences:set pref-key (car percentages)))) - (inner (void) after-percentage-change)) - (super-new))) - - (define drs-name-message% - (class name-message% - (define/override (on-choose-directory dir) - (let ([file (finder:get-file dir - (string-constant select-file) - #f - "" - (send this get-top-level-window))]) - (when file - (handler:edit-file file)))) - (super-new - [string-constant-untitled (string-constant untitled)] - [string-constant-no-full-name-since-not-saved - (string-constant no-full-name-since-not-saved)]))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; lambda-snipclass is for backwards compatibility - ;; - (define lambda-snipclass - (make-object (class snip-class% - (define/override (read p) (make-object string-snip% "λ")) - (super-new)))) - (send lambda-snipclass set-version 1) - (send lambda-snipclass set-classname "drscheme:lambda-snip%") - (send (get-the-snip-class-list) add lambda-snipclass) - - (define newest-frame 'nothing-yet) - - (define open-drscheme-window - (case-lambda - [() (open-drscheme-window #f)] - [(name) - (cond - [(and newest-frame - name - (not (eq? newest-frame 'nothing-yet)) - (send newest-frame still-untouched?)) - (send newest-frame change-to-file name) - (send newest-frame show #t) - (begin0 newest-frame - (set! newest-frame #f))] - [(and name ;; only open a tab if we have a filename - (preferences:get 'drracket:open-in-tabs)) - (let ([fr (let loop ([frs (cons (send (group:get-the-frame-group) get-active-frame) - (send (group:get-the-frame-group) get-frames))]) - (cond - [(null? frs) #f] - [else (let ([fr (car frs)]) - (or (and (is-a? fr -frame<%>) - fr) - (loop (cdr frs))))]))]) - (if fr - (begin (send fr open-in-new-tab name) - (send fr show #t) - fr) - (create-new-drscheme-frame name)))] - [else - (create-new-drscheme-frame name)])])) - - (define (create-new-drscheme-frame filename) - (let* ([drs-frame% (drracket:get/extend:get-unit-frame)] - [frame (new drs-frame% (filename filename))]) - (send frame update-toolbar-visibility) - (send frame initialize-module-language) - (send frame show #t) - (send (send frame get-interactions-text) initialize-console) - frame))) + [(null? frs) #f] + [else (let ([fr (car frs)]) + (or (and (is-a? fr drracket:unit:frame<%>) + fr) + (loop (cdr frs))))]))]) + (if fr + (begin (send fr open-in-new-tab name) + (send fr show #t) + fr) + (create-new-drscheme-frame name)))] + [else + (create-new-drscheme-frame name)])])) + + (define (create-new-drscheme-frame filename) + (let* ([drs-frame% (drracket:get/extend:get-unit-frame)] + [frame (new drs-frame% (filename filename))]) + (send frame update-toolbar-visibility) + (send frame initialize-module-language) + (send frame show #t) + (send (send frame get-interactions-text) initialize-console) + frame))) diff --git a/collects/drracket/tool-lib.rkt b/collects/drracket/tool-lib.rkt index ef1ea12f95..5cb76d568d 100644 --- a/collects/drracket/tool-lib.rkt +++ b/collects/drracket/tool-lib.rkt @@ -101,6 +101,31 @@ all of the names in the tools library, for use defining keybindings out. The default is the empty list, meaning that all opt-out buttons appear. }) + (proc-doc/names + drracket:module-language-tools:add-online-expansion-handler + (-> path-string? symbol? (-> (is-a?/c drracket:unit:definitions-text<%>) any/c any) void?) + (mod-path id local-handler) + @{Registers a pair of procedures with DrRacket's online expansion machinery. + + The first two arguments name a procedure in a module that is loaded by + @racket[dynamic-require] is a separate place. When DrRacket detects that + the editor has been modified, it sends the contents of the editor over to + that separate place, @racket[expand]s the program there, and then supplies + the fully expanded object to that first procedure. (The procedure is called + in the same context as the expansion process.) + + Note that the thread that calls this procedure may be + killed at anytime: DrRacket may kill it when the user types in the buffer + (in order to start a new expansion), but bizarro code may also create a separate + thread during expansion that lurks around and then mutates arbitrary things. + + The result of the procedure is expected to be something that can be sent + across a @racket[place-channel], which is then sent back to the original + place where DrRacket itself is running and passed to the @racket[local-handler] + argument. At this point, the only code running is trusted code (DrRacket itself + and other tools), but any long running computations may freeze DrRacket's GUI, + since this procedure is invoked on DrRacket's eventspace's handler thread.}) + (proc-doc/names drracket:module-language:add-module-language (-> any) diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index 326921b9a7..ab54990d95 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -9,7 +9,9 @@ (for-label racket/unit racket/contract) (for-label racket/base racket/gui) (for-label framework/framework) - (for-label drracket/syncheck-drracket-button)) + (for-label drracket/syncheck-drracket-button + drracket/check-syntax) + scribble/extract) (define (File x) @tt[x]) (define (FileFirst x) @tt[x]) ;; indexing missing @@ -66,8 +68,8 @@ help being early clients for DrRacket plugins. Plugins are designed for major extensions in DrRacket's functionality. To extend the appearance or the functionality the DrRacket window (say, to annotate -programs in certain ways, to add buttons to the DrRacket -frame or to add additional languages to DrRacket) use a +programs in certain ways or to add buttons to the DrRacket +frame) use a tool. The Macro Stepper, the Syntax Checker, the Stepper, and the teaching languages are all implemented as tools. @@ -575,6 +577,182 @@ for a list of the capabilities registered by default. Check Syntax is a part of the DrRacket collection, but is implemented via the tools API. +@subsection{Accessing Check Syntax Programmatically} + +@defmodule[drracket/check-syntax] + +@defproc[(make-traversal [namespace namespace?] + [path (or/c #f path-string?)]) + (values (->* (syntax?) ((-> (and/c syntax? + (λ (x) + (define lst (syntax->list x)) + (and lst (andmap identifier? lst)))) + void?)) + void?) + (-> void?))]{ + This function creates some local state about a traversal of syntax objects + and returns two functions. The first one should be called with each of the + syntax objects that make up a program (there will be only one if the program + is a module) and then the second one should be called to indicate there are no + more. + + The optional argument to the first function is called for each sequence + of binding identifiers encountered in @racket[define-values], @racket[define-syntaxes], + and @racket[define-values-for-syntax]. + + During the dynamic extent of the call to the two result functions, the value + of the @racket[current-annotations] parameter is consulted and various + methods are invoked in the corresponding object (if any), to indicate + what has been found in the syntax object. +} + +@defparam[current-annotations ca (or/c #f (is-a?/c syncheck-annotations<%>))]{ + The methods of the value of this parameter are invoked by the functions returned + from @racket[make-traversal]. +} + +@definterface[syncheck-annotations<%> ()]{ + + Classes implementing this interface are + accceptors of information about a traversal + of syntax objects. See @racket[make-traversal]. + + Do not implement this interface directly, as it + is liable to change without warning. Instead, use + the @racket[annotations-mixin] and override + the methods you're interested in. The + @racket[annotations-mixin] will keep in sync + with this interface, providing methods that + ignore their arguments. + + @defmethod[(syncheck:find-source-object [stx syntax?]) (or/c #f (not/c #f))]{ + This should return @racket[#f] if the source of this syntax object is + uninteresting for annotations (if, for example, the only interesting + annotations are those in the original file and this is a syntax object + introduced by a macro and thus has a source location from some other file). + + Otherwise, it should return some (non-@racket[#f]) + value that will then be passed to one of the other methods below as + a @racket[_source-obj] argument. + } + + @defmethod[(syncheck:add-background-color [source-obj (not/c #f)] + [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [color string?]) + void?]{ + Called to indicate that the color @racket[color] should be drawn on the background of + the given range in the editor, when the mouse moves over it. This method is typically + called in conjuction with some other method that provides some other annotation + on the source. + } + @defmethod[(syncheck:add-require-open-menu [source-obj (not/c #f)] + [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [file path-string?]) + void?]{ + Called to indicate that there is a @racket[require] at the location from @racket[start] to @racket[end], + and that it corresponds to @racket[file]. Check Syntax adds a popup menu. + } + + @defmethod[(syncheck:add-docs-menu [source-obj (not/c #f)] + [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [id symbol?] + [label any/c] + [path any/c] + [tag any/c]) + void?]{ + Called to indicate that there is something that has documentation between the range @racket[start] and @racket[end]. The + documented identifier's name is given by @racket[id] and the docs are found in the html file @racket[path] at the + html tag @racket[tag]. The @racket[label] argument describes the binding for use in the menu item (although it may + be longer than 200 characters). + } + + @defmethod[(syncheck:add-rename-menu [id symbol?] + [all-ids (listof (list/c (not/c #f) exact-nonnegative-integer? exact-nonnegative-integer?))] + [new-name-interferes? (-> symbol boolean?)]) + void?]{ + Called to indicate that there is a variable that can be renamed. The + identifier's name is @racket[id] and all of the occurrences of the identifier are given in the + list @racket[all-ids]. The @racket[new-name-interferes?] procedure determines if a potential name would + interfere with the existing bindings. + } + + @defmethod[(syncheck:add-arrow [start-source-obj (not/c #f)] + [start-left exact-nonnegative-integer?] + [start-right exact-nonnegative-integer?] + [end-source-obj (not/c #f)] + [end-left exact-nonnegative-integer?] + [end-right exact-nonnegative-integer?] + [actual? boolean?] + [phase-level (or/c exact-nonnegative-integer? #f)]) + void?]{ + Called to indicate that there should be an arrow between the locations described by the first six arguments. + The @racket[phase-level] argument indicates the phase of the binding and the @racket[actual?] argument + indicates if the binding is a real one, or a predicted one from a syntax template (predicted bindings + are drawn with question marks in Check Syntax). + } + @defmethod[(syncheck:add-tail-arrow [from-source-obj (not/c #f)] + [from-pos exact-nonnegative-integer?] + [to-source-obj (not/c #f)] + [to-pos exact-nonnegative-integer?]) + void?]{ + Called to indicate that there are two expressions, beginning at @racket[from-pos] and @racket[to-pos] + that are in tail position with respect to each other. + } + @defmethod[(syncheck:add-mouse-over-status [source-obj (not/c #f)] + [pos-left exact-nonnegative-integer?] + [pos-right exact-nonnegative-integer?] + [str string?]) + void?]{ + Called to indicate that the message in @racket[str] should be shown when the mouse passes over the given position. + } + @defmethod[(syncheck:add-jump-to-definition [source-obj (not/c #f)] + [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [id any/c] + [filename path-string?]) + void?]{ + Called to indicate that there is some identifier at the given location (named @racket[id]) that + is defined in the file @racket[filename]. + } + @defmethod[(syncheck:color-range [source-obj (not/c #f)] + [start exact-nonnegative-integer?] + [finish exact-nonnegative-integer?] + [style-name any/c] + [mode any/c]) + void?]{ + Called to indicate that the given location should be colored according to the style @racket[style-name] when + in @racket[mode]. The mode either indicates regular check syntax or is used indicate blame for potential contract + violations (and still experimental). + } +} + +@defmixin[annotations-mixin () (syncheck-annotations<%>)]{ + Supplies all of the methods in @racket[syncheck-annotations<%>] + with default behavior. Be sure to use this mixin to future-proof + your code and then override the methods you're interested in. +} + +@(define-syntax-rule + (syncheck-method-id x ...) + (begin @defidform[x]{Bound to an identifier created with @racket[define-local-member-name] + that is used in @racket[syncheck-annotations<%>].} + ...)) +@syncheck-method-id[syncheck:find-source-editor + syncheck:add-background-color + syncheck:add-require-open-menu + syncheck:add-docs-menu + syncheck:add-rename-menu + syncheck:add-arrow + syncheck:add-tail-arrow + syncheck:add-mouse-over-status + syncheck:add-jump-to-definition + syncheck:color-range] + +@subsection{Check Syntax Button} + @defmodule[drracket/syncheck-drracket-button] @defthing[syncheck-drracket-button diff --git a/collects/scribblings/tools/unit.scrbl b/collects/scribblings/tools/unit.scrbl index 453bcc836a..36226053de 100644 --- a/collects/scribblings/tools/unit.scrbl +++ b/collects/scribblings/tools/unit.scrbl @@ -132,27 +132,45 @@ Calls the definitions text's @defmethod[#:mode override (set-breakables [thread (or/c thread? false/c)] [custodian (or/c custodian? false/c)]) - void?]{}} + void?]{} + +@defmethod[#:mode public-final + (add-bkg-running-color [id symbol?] + [color (or/c string? (is-a?/c color%))] + [label string?]) + void?]{ + + Sets the color of the circle in the bottom-right corner of the + DrRacket window to @racket[color] with the tooltip window that + appears over it containing @racket[label]. If multiple coors are + registered they are all shown. + + See also @method[drracket:unit:tab<%> remove-bkg-running-color]. +} +@defmethod[#:mode public-final + (remove-bkg-running-color [id symbol?]) + void?]{ + + Removes the color and label added with @racket[id]. + + See also @method[drracket:unit:tab<%> add-bkg-running-color]. + } + +} @defclass[drracket:unit:tab% object% (drracket:unit:tab<%>)]{ The base class that implements the tab's functionality. - - @defconstructor/make[()]{} @defmethod[#:mode override (clear-annotations) void?]{ - -Clears any error highlighting. - - - - -}} + Clears any error highlighting. + } +} @defmixin[drracket:unit:program-editor-mixin (text% editor:basic<%>) ()]{ diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index cc6d97c24e..061dcb51bf 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -216,6 +216,12 @@ please adhere to these guidelines: (cs-mode-menu-show-client-obligations "Client Contract Obligations") (cs-mode-menu-show-syntax "Syntactic Categories") + ;; the online check syntax status messages (mouse over the bottom right of drracket's window to see the messages during online expansion's various phases) + (online-expansion-running "Online expansion running") + (only-raw-text-files-supported "Only pure text files supported") + (abnormal-termination "Online expansion terminated abnormally") + (jump-to-error "Jump to Error") + ;;; info bar at botttom of drscheme frame (collect-button-label "GC") (read-only "Read only") @@ -223,7 +229,8 @@ please adhere to these guidelines: (overwrite "Overwrite") (running "running") (not-running "not running") - + + ;;; misc (welcome-to-something "Welcome to ~a") diff --git a/collects/tests/drracket/syncheck-test.rkt b/collects/tests/drracket/syncheck-test.rkt index 49f2436ee4..d033cfd627 100644 --- a/collects/tests/drracket/syncheck-test.rkt +++ b/collects/tests/drracket/syncheck-test.rkt @@ -133,7 +133,7 @@ trigger runtime errors in check syntax. (" ([" default-color) ("x" lexically-bound-variable) (" " default-color) - ("x" error) + ("x" free-variable) ("]) " default-color) ("x" lexically-bound-variable) (")" default-color)) @@ -153,13 +153,13 @@ trigger runtime errors in check syntax. '(("(" default-color) ("#%top" imported-syntax) (" . " default-color) - ("x" error) + ("x" free-variable) (")" default-color))) (build-test "(set! x 1)" '(("(" default-color) ("set!" imported-syntax) (" " default-color) - ("x" error) + ("x" free-variable) (" " default-color) ("1" constant) (")" default-color))) @@ -195,7 +195,7 @@ trigger runtime errors in check syntax. (build-test "object%" '(("object%" imported-syntax))) ; used to be lexically-bound-variable (build-test "unbound-id" - '(("unbound-id" error))) + '(("unbound-id" free-variable))) (build-test "(define bd 1) bd" '(("(" default-color) ("define" imported-syntax) @@ -221,9 +221,9 @@ trigger runtime errors in check syntax. (")" default-color))) (build-test "(f x)" '(("(" default-color) - ("f" error) + ("f" free-variable) (" " default-color) - ("x" error) + ("x" free-variable) (")" default-color))) (build-test "(define-syntax (f stx) (syntax 1))" '(("(" default-color) @@ -287,19 +287,19 @@ trigger runtime errors in check syntax. '(("(" default-color) ("module" imported-syntax) (" m " default-color) - ("mzscheme" error) + ("mzscheme" unused-require) (")" default-color))) (build-test "(require-for-syntax mzscheme)" '(("(" default-color) ("require-for-syntax" imported-syntax) (" " default-color) - ("mzscheme" error) + ("mzscheme" unused-require) (")" default-color))) (build-test "(require mzlib/list)" '(("(" default-color) ("require" imported-syntax) (" " default-color) - ("mzlib/list" error) + ("mzlib/list" unused-require) (")" default-color))) (build-test "(module m mzscheme (provide x) (define x 1))" '(("(" default-color) @@ -336,7 +336,7 @@ trigger runtime errors in check syntax. (" m mzscheme (" default-color) ("require" imported-syntax) (" " default-color) - ("mzlib/list" error) + ("mzlib/list" unused-require) ("))" default-color)) (list '((10 18) (20 27)))) @@ -542,7 +542,7 @@ trigger runtime errors in check syntax. ("(" default-color) ("1" constant) (" ," default-color) - ("x" error) + ("x" free-variable) (" " default-color) ("2" constant) (")" default-color))) @@ -864,7 +864,7 @@ trigger runtime errors in check syntax. (build-test "#lang scheme/base\n(require scheme)\n(define-syntax m (lambda (x) #'1))" '(("#lang " default-color) - ("scheme/base" error) + ("scheme/base" unused-require) ("\n(" default-color) ("require" imported) (" scheme)\n(" default-color) diff --git a/collects/tests/drracket/test-docs-complete.rkt b/collects/tests/drracket/test-docs-complete.rkt new file mode 100644 index 0000000000..9165956312 --- /dev/null +++ b/collects/tests/drracket/test-docs-complete.rkt @@ -0,0 +1,3 @@ +#lang racket/base +(require rackunit/docs-complete) +(check-docs 'drracket/check-syntax) diff --git a/collects/typed-scheme/base-env/base-types-extra.rkt b/collects/typed-scheme/base-env/base-types-extra.rkt index 13ecfa0a73..f3b412e351 100644 --- a/collects/typed-scheme/base-env/base-types-extra.rkt +++ b/collects/typed-scheme/base-env/base-types-extra.rkt @@ -12,10 +12,15 @@ ;; special type names that are not bound to particular types (define-other-types - -> case-> U Rec All Opaque Vector + #;-> case-> U Rec All Opaque Vector Parameterof List List* Class Values Instance Refinement pred) +(define-syntax -> + (lambda (stx) + (raise-syntax-error 'type-check "type name used out of context" stx))) +(provide ->) + (provide (rename-out [All ∀] [U Un] [-> →]