1#lang racket/base 2 3(require racket/contract 4 racket/unit 5 racket/class 6 racket/path 7 racket/port 8 racket/list 9 racket/match 10 racket/format 11 string-constants 12 framework 13 framework/private/srcloc-panel 14 mrlib/name-message 15 mrlib/switchable-button 16 mrlib/cache-image-snip 17 (prefix-in image-core: mrlib/image-core) 18 mrlib/close-icon 19 mrlib/panel-wob 20 net/sendurl 21 net/url 22 23 drracket/private/drsig 24 "insulated-read-language.rkt" 25 "insert-large-letters.rkt" 26 "get-defs.rkt" 27 "local-member-names.rkt" 28 "eval-helpers-and-pref-init.rkt" 29 "parse-logger-args.rkt" 30 drracket/get-module-path 31 "named-undefined.rkt" 32 (prefix-in drracket:arrow: "../arrow.rkt") 33 (prefix-in icons: images/compile-time) 34 mred 35 (prefix-in mred: mred) 36 37 mzlib/date 38 39 framework/private/aspell 40 framework/private/logging-timer 41 42 setup/collects 43 scribble/xref 44 setup/xref 45 scribble/tag 46 (only-in scribble/base doc-prefix)) 47 48(provide unit@) 49 50(define define-menu-configure (string-constant define-menu-configure)) 51 52(define module-browser-progress-constant (string-constant module-browser-progress)) 53(define status-compiling-definitions (string-constant module-browser-compiling-defns)) 54(define show-lib-paths (string-constant module-browser-show-lib-paths/short)) 55(define show-planet-paths (string-constant module-browser-show-planet-paths/short)) 56(define refresh (string-constant module-browser-refresh)) 57 58(define oprintf 59 (let ([op (current-output-port)]) 60 (λ args 61 (apply fprintf op args)))) 62 63;; =================================================================================================== 64;; Compiled bitmaps 65 66(require (for-syntax 67 racket/base 68 (prefix-in icons: (combine-in images/icons/file images/icons/control images/icons/style 69 images/icons/stickman images/logos)))) 70 71(define execute-bitmap 72 (icons:compiled-bitmap (icons:play-icon #:color icons:run-icon-color 73 #:height (icons:toolbar-icon-height)))) 74(define break-bitmap 75 (icons:compiled-bitmap (icons:stop-icon #:color icons:halt-icon-color 76 #:height (icons:toolbar-icon-height)))) 77(define small-save-bitmap 78 (icons:compiled-bitmap (icons:small-save-icon #:height (icons:toolbar-icon-height)))) 79(define save-bitmap 80 (icons:compiled-bitmap (icons:save-icon #:height (icons:toolbar-icon-height)))) 81 82(begin-for-syntax 83 (define stickman-height 18) 84 (define num-running-frames 12)) 85 86(define running-frame-list 87 (icons:compiled-bitmap-list 88 (for/list ([t (in-range 0 1 (/ 1 num-running-frames))]) 89 (icons:running-stickman-icon t #:height stickman-height)))) 90(define running-frames (list->vector running-frame-list)) 91 92(define standing-frame 93 (icons:compiled-bitmap 94 (icons:standing-stickman-icon #:height stickman-height))) 95 96(define very-small-planet-bitmap 97 (icons:compiled-bitmap (icons:planet-logo #:height (icons:toolbar-icon-height)))) 98 99;; =================================================================================================== 100 101(define-local-member-name 102 update-kill-button-label 103 does-break-kill? 104 get-panel-percentages-and-orientation 105 set-panel-percentages-and-orientation) 106 107(define-unit unit@ 108 (import [prefix help-desk: drracket:help-desk^] 109 [prefix drracket:app: drracket:app^] 110 [prefix drracket:frame: drracket:frame^] 111 [prefix drracket:text: drracket:text^] 112 [prefix drracket:rep: drracket:rep/int^] 113 [prefix drracket:language-configuration: drracket:language-configuration/internal^] 114 [prefix drracket:language: drracket:language^] 115 [prefix drracket:get/extend: drracket:get/extend^] 116 [prefix drracket:module-overview: drracket:module-overview^] 117 [prefix drracket:tools: drracket:tools^] 118 [prefix drracket:init: drracket:init/int^] 119 [prefix drracket:module-language: drracket:module-language/int^] 120 [prefix drracket:module-language-tools: drracket:module-language-tools^] 121 [prefix drracket:modes: drracket:modes^] 122 [prefix drracket:debug: drracket:debug^] 123 [prefix drracket: drracket:interface^]) 124 (export (rename drracket:unit/int^ [-frame% frame%])) 125 (init-depend drracket:module-language/int^) 126 127 (define struct:teachpack-callbacks struct:drracket:unit:teachpack-callbacks) 128 (define teachpack-callbacks? drracket:unit:teachpack-callbacks?) 129 (define teachpack-callbacks-get-names drracket:unit:teachpack-callbacks-get-names) 130 (define teachpack-callbacks-add drracket:unit:teachpack-callbacks-add) 131 (define teachpack-callbacks-remove drracket:unit:teachpack-callbacks-remove) 132 (define teachpack-callbacks-remove-all drracket:unit:teachpack-callbacks-remove-all) 133 (define make-teachpack-callbacks drracket:unit:teachpack-callbacks) 134 (define teachpack-callbacks drracket:unit:teachpack-callbacks) 135 136 (keymap:add-to-right-button-menu 137 (let ([old (keymap:add-to-right-button-menu)]) 138 (λ (menu text event) 139 (old menu text event) 140 (when (and (is-a? text text%) 141 (or (is-a? text (get-definitions-text%)) 142 (is-a? text drracket:rep:text%)) 143 (is-a? event mouse-event%)) 144 145 (let ([add-sep 146 (let ([added? #f]) 147 (λ () 148 (unless added? 149 (set! added? #t) 150 (new separator-menu-item% [parent menu]))))]) 151 152 (add-search-help-desk-menu-item text menu 153 (let-values ([(x y) 154 (send text dc-location-to-editor-location 155 (send event get-x) 156 (send event get-y))]) 157 (send text find-position x y)) 158 add-sep) 159 160 (when (is-a? text editor:basic<%>) 161 (let-values ([(pos text) (send text get-pos/text event)]) 162 (when (and pos (is-a? text text%)) 163 (send text split-snip pos) 164 (send text split-snip (+ pos 1)) 165 (let ([snip (send text find-snip pos 'after-or-none)]) 166 (when (or (is-a? snip image-snip%) 167 (is-a? snip image-core:image%) 168 (is-a? snip cache-image-snip%)) 169 (add-sep) 170 (define (save-image-callback _1 _2) 171 (define fn 172 (put-file #f 173 (send text get-top-level-window) 174 #f "untitled.png" "png")) 175 (when fn 176 (define kind (filename->kind fn)) 177 (cond 178 [kind 179 (cond 180 [(or (is-a? snip image-snip%) 181 (is-a? snip cache-image-snip%)) 182 (send (send snip get-bitmap) save-file fn kind)] 183 [else 184 (image-core:save-image-as-bitmap snip fn kind)])] 185 [else 186 (message-box 187 (string-constant drscheme) 188 "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm" 189 #:dialog-mixin frame:focus-table-mixin)]))) 190 (new menu-item% 191 [parent menu] 192 [label (string-constant save-image)] 193 [callback save-image-callback])))))) 194 195 (void)))))) 196 197 (define (add-search-help-desk-menu-item text menu position [add-sep void]) 198 (let* ([end (send text get-end-position)] 199 [start (send text get-start-position)]) 200 (unless (= 0 (send text last-position)) 201 (let* ([str (if (= end start) 202 (find-symbol text position) 203 (send text get-text start end))] 204 ;; almost the same code as "search-help-desk" in "rep.rkt" 205 [l (send text get-canvas)] 206 [l (and l (send l get-top-level-window))] 207 [l (and l (is-a? l drracket:unit:frame<%>) (send l get-definitions-text))] 208 [l (and l (send l get-next-settings))] 209 [l (and l (drracket:language-configuration:language-settings-language l))] 210 [ctxt (and l (send l capability-value 'drscheme:help-context-term))] 211 [name (and l (send l get-language-name))]) 212 (unless (string=? str "") 213 (add-sep) 214 (let ([short-str (shorten-str str 50)]) 215 (make-object menu-item% 216 (gui-utils:format-literal-label 217 (string-constant search-help-desk-for) 218 (if (equal? short-str str) 219 str 220 (string-append short-str "..."))) 221 menu 222 (λ x (help-desk:help-desk str (list ctxt name)))) 223 (void))))))) 224 225 (define (filename->kind fn) 226 (let ([ext (filename-extension fn)]) 227 (and ext 228 (let ([sym (string->symbol (bytes->string/utf-8 ext))]) 229 (ormap (λ (pr) (and (equal? sym (car pr)) (cadr pr))) 230 allowed-extensions))))) 231 232 (define allowed-extensions '((png png) 233 (jpg jpeg) 234 (xbm xbm) 235 (xpm xpm))) 236 237 238 239 ;; find-symbol : number -> string 240 ;; finds the symbol around the position `pos' (approx) 241 (define (find-symbol text pos) 242 (cond 243 [(and (is-a? text racket:text<%>) 244 (not (send text is-stopped?))) 245 (let* ([before (send text get-backward-sexp pos)] 246 [before+ (and before (send text get-forward-sexp before))] 247 [after (send text get-forward-sexp pos)] 248 [after- (and after (send text get-backward-sexp after))]) 249 250 (define (get-tokens start end) 251 (let loop ([i start]) 252 (cond 253 [(and (< i end) 254 (< i (send text last-position))) 255 (define-values (tstart tend) (send text get-token-range i)) 256 (cons (list (send text classify-position i) tstart tend) 257 (loop tend))] 258 [else '()]))) 259 260 ;; find-searchable-tokens : number number -> (or/c #f (list symbol number number)) 261 (define (find-searchable-tokens start end) 262 (define tokens (get-tokens start end)) 263 (for/or ([tok tokens]) 264 (define type (list-ref tok 0)) 265 (cond [(or (equal? type 'symbol) 266 (equal? type 'hash-colon-keyword) 267 ;; The token may have been categorized as a keyword due to 268 ;; its presence in the tabification preferences: 269 (equal? type 'keyword)) 270 tok] 271 [else 272 #f]))) 273 274 (define searchable-token 275 (or (and before before+ 276 (<= before pos before+) 277 (find-searchable-tokens before before+)) 278 (and after after- 279 (<= after- pos after) 280 (find-searchable-tokens after- after)))) 281 (if searchable-token 282 (send text get-text (list-ref searchable-token 1) (list-ref searchable-token 2)) 283 ""))] 284 [else 285 (send text split-snip pos) 286 (send text split-snip (+ pos 1)) 287 (let ([snip (send text find-snip pos 'after)]) 288 (if (is-a? snip string-snip%) 289 (let* ([before 290 (let loop ([i (- pos 1)] 291 [chars null]) 292 (if (< i 0) 293 chars 294 (let ([char (send text get-character i)]) 295 (if (non-letter? char) 296 chars 297 (loop (- i 1) 298 (cons char chars))))))] 299 [after 300 (let loop ([i pos]) 301 (if (< i (send text last-position)) 302 (let ([char (send text get-character i)]) 303 (if (non-letter? char) 304 null 305 (cons char (loop (+ i 1))))) 306 null))]) 307 (apply string (append before after))) 308 ""))])) 309 310 ;; non-letter? : char -> boolean 311 ;; returns #t if the character belongs in a symbol (approx) and #f it is 312 ;; a divider between symbols (approx) 313 (define (non-letter? x) 314 (or (char-whitespace? x) 315 (memq x '(#\` #\' #\, #\; #\" 316 #\{ #\( #\[ #\] #\) #\})))) 317 (define (shorten-str str len) 318 (if ((string-length str) . <= . len) 319 str 320 (substring str 0 len))) 321 322 323 ; 324 ; 325 ; 326 ; ;;; ; ; ; ; 327 ; ; ; ; 328 ; ; ; ; ; 329 ; ;;;; ; ; ;;; ;;; ;;;; ; ;;; ; ;; ;; ; ; ;;; ; ;;; ;; ; 330 ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ;; 331 ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 332 ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; 333 ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 334 ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; 335 ; ; ; ;;;;; ;;; ;; ; ;;; ; ; ;; ; ; ;;;;; ; ;;; ;; ; 336 ; ; 337 ; ; ; 338 ; ;;;; 339 340 (define (get-fraction-from-user parent) 341 (define dlg (make-object dialog% (string-constant enter-fraction))) 342 (define hp (make-object horizontal-panel% dlg)) 343 (make-object message% (string-constant whole-part) hp) 344 (define whole 345 (keymap:call/text-keymap-initializer 346 (λ () 347 (make-object text-field% #f hp void)))) 348 (define vp (new-vertical-panel% [parent hp])) 349 (define hp2 (new-horizontal-panel% [parent vp])) 350 (define num 351 (keymap:call/text-keymap-initializer 352 (λ () 353 (make-object text-field% #f hp2 void)))) 354 (define num-m (make-object message% (string-constant numerator) hp2)) 355 (define hp3 (make-object horizontal-panel% vp)) 356 (define den 357 (keymap:call/text-keymap-initializer 358 (λ () 359 (make-object text-field% #f hp3 void)))) 360 (define den-m (make-object message% (string-constant denominator) hp3)) 361 (define bp (make-object horizontal-panel% dlg)) 362 (define ok? #f) 363 (define (validate-number) 364 (define num-s (string->number (send num get-value))) 365 (define den-s (string->number (send den get-value))) 366 (define whole-s (if (string=? (send whole get-value) "") 367 0 368 (string->number (send whole get-value)))) 369 (cond 370 [(or (not whole-s) (not (integer? whole-s))) 371 (string-constant insert-number/bad-whole-part)] 372 [(or (not num-s) (not (integer? num-s)) (< num-s 0)) 373 (string-constant insert-number/bad-numerator)] 374 [(or (not den-s) (not (integer? den-s)) (<= den-s 0)) 375 (string-constant insert-number/bad-denominator)] 376 [else 377 (if (< whole-s 0) 378 (- whole-s (/ num-s den-s)) 379 (+ whole-s (/ num-s den-s)))])) 380 (define (ok-callback) 381 (define v (validate-number)) 382 (cond 383 [(number? v) 384 (set! ok? #t) 385 (send dlg show #f)] 386 [else 387 (message-box 388 (string-constant drscheme) 389 v 390 dlg 391 #:dialog-mixin frame:focus-table-mixin)])) 392 (define (cancel-callback) (send dlg show #f)) 393 (define-values (ok cancel) 394 (gui-utils:ok/cancel-buttons 395 bp 396 (λ (x y) (ok-callback)) 397 (λ (x y) (cancel-callback)))) 398 (let ([mw (max (send den-m get-width) (send num-m get-width))]) 399 (send den-m min-width mw) 400 (send num-m min-width mw)) 401 (send bp set-alignment 'right 'center) 402 (send dlg show #t) 403 (and ok? 404 (let ([v (validate-number)]) 405 (and (number? v) 406 v)))) 407 408 ;; create-executable : (instanceof drracket:unit:frame<%>) -> void 409 (define (create-executable frame) 410 (define definitions-text (send frame get-definitions-text)) 411 (define program-filename (send definitions-text get-filename)) 412 (define settings (send definitions-text get-next-settings)) 413 (cond 414 [(not (drracket:language-configuration:language-allows-executable-creation? 415 (drracket:language-configuration:language-settings-language settings))) 416 (message-box (string-constant drscheme) 417 (string-constant drracket-creates-executables-only-in-some-languages) 418 frame 419 #:dialog-mixin frame:focus-table-mixin)] 420 [(not program-filename) 421 (message-box (string-constant create-executable-title) 422 (string-constant must-save-before-executable) 423 frame 424 #:dialog-mixin frame:focus-table-mixin)] 425 [else 426 (when (or (not (send definitions-text is-modified?)) 427 (gui-utils:get-choice 428 (string-constant definitions-not-saved) 429 (string-constant yes) 430 (string-constant no) 431 (string-constant drscheme) 432 #f 433 frame)) 434 (send (drracket:language-configuration:language-settings-language settings) 435 create-executable 436 (drracket:language-configuration:language-settings-settings settings) 437 frame 438 program-filename))])) 439 440 (define-values (get-program-editor-mixin add-to-program-editor-mixin) 441 (let* ([program-editor-mixin 442 (mixin (editor:basic<%> (class->interface text%)) () 443 (init-rest args) 444 (inherit get-top-level-window) 445 446 (define/private (reset-highlighting) 447 (let ([f (get-top-level-window)]) 448 (when (and f 449 (is-a? f drracket:unit:frame<%>)) 450 (let ([interactions-text (send f get-interactions-text)]) 451 (when (object? interactions-text) 452 (send interactions-text reset-highlighting)))))) 453 454 (define/augment (after-insert x y) 455 (reset-highlighting) 456 (inner (void) after-insert x y)) 457 458 (define/augment (after-delete x y) 459 (reset-highlighting) 460 (inner (void) after-delete x y)) 461 462 (apply super-make-object args))] 463 [get-program-editor-mixin 464 (λ () 465 (drracket:tools:only-in-phase 'drracket:unit:get-program-editor-mixin 466 'phase2 467 'init-complete) 468 program-editor-mixin)] 469 [add-to-program-editor-mixin 470 (λ (mixin) 471 (drracket:tools:only-in-phase 'drracket:unit:add-to-program-editor-mixin 'phase1) 472 (let ([old program-editor-mixin]) 473 (set! program-editor-mixin (λ (x) (mixin (old x))))))]) 474 (values get-program-editor-mixin 475 add-to-program-editor-mixin))) 476 477 ;; this sends a message to its frame when it gets the focus 478 (define make-searchable-canvas% 479 (λ (%) 480 (class % 481 (inherit get-top-level-window) 482 (define/override (on-focus on?) 483 (when on? 484 (send (get-top-level-window) make-searchable this)) 485 (super on-focus on?)) 486 (super-new)))) 487 488 (define interactions-canvas% 489 (class (make-searchable-canvas% 490 (canvas:info-mixin 491 (canvas:wide-snip-mixin 492 (canvas:info-mixin 493 canvas:color%)))) 494 (init [style '()]) 495 (super-new (style (cons 'auto-hscroll style))) 496 (inherit set-scroll-via-copy) 497 (set-scroll-via-copy #t))) 498 499 500 (define definitions-canvas% 501 (class (make-searchable-canvas% (canvas:info-mixin canvas:color%)) 502 (init [style '()]) 503 (super-new (style (cons 'auto-hscroll style))) 504 (inherit set-scroll-via-copy) 505 (set-scroll-via-copy #t))) 506 507 ; 508 ; 509 ; 510 ; ; ;;; ; ; 511 ; ; ; ; 512 ; ; ; ; ; ; 513 ; ;; ; ;;; ;;;;;;; ; ;; ; ;;;; ; ;;; ; ;; ;;; ;;;; ;;; ; ; ;;;; 514 ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; 515 ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; 516 ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;;;;; ; ; 517 ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 518 ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 519 ; ;; ; ;;;; ; ; ; ; ; ;; ; ;;; ; ; ;;; ;; ;;;; ; ; ;; 520 ; 521 ; 522 ; 523 524 525 (define get-definitions-text% 526 (let ([definitions-text% #f]) 527 (λ () 528 (drracket:tools:only-in-phase 'phase2 'init-complete) 529 (unless definitions-text% 530 (set! definitions-text% (make-definitions-text%))) 531 definitions-text%))) 532 533 (define (show-line-numbers?) 534 (preferences:get 'drracket:show-line-numbers?)) 535 536 (define (make-definitions-text%) 537 (let ([definitions-super% 538 (text:line-numbers-mixin 539 (text:first-line-mixin 540 (drracket:module-language:module-language-put-file-mixin 541 (racket:text-mixin 542 (color:text-mixin 543 (drracket:rep:drs-bindings-keymap-mixin 544 (mode:host-text-mixin 545 (text:foreground-color-mixin 546 (drracket:rep:drs-autocomplete-mixin 547 (λ (x) x) 548 (text:normalize-paste-mixin 549 (text:column-guide-mixin 550 (text:inline-overview-mixin 551 (text:all-string-snips-mixin 552 (text:ascii-art-enlarge-boxes-mixin 553 (number-snip:remove-decimal-looking-number-snips-on-insertion-mixin 554 text:info%)))))))))))))))]) 555 ((get-program-editor-mixin) 556 (class* definitions-super% (drracket:unit:definitions-text<%>) 557 (inherit is-locked? lock while-unlocked 558 highlight-first-line is-printing?) 559 560 (define interactions-text #f) 561 (define/public (set-interactions-text it) 562 (set! interactions-text it)) 563 564 (define tab #f) 565 (define/public (get-tab) tab) 566 (define/public (set-tab t) (set! tab t)) 567 568 (inherit begin-edit-sequence end-edit-sequence 569 delete insert last-position paragraph-start-position 570 get-character) 571 572 (define save-file-metadata #f) 573 574 (define/pubment (begin-metadata-changes) 575 (set! ignore-edits? #t) 576 (inner (void) begin-metadata-changes)) 577 (define/pubment (end-metadata-changes) 578 (set! ignore-edits? #f) 579 (inner (void) end-metadata-changes)) 580 581 (define/augment (on-save-file filename fmt) 582 (inner (void) on-save-file filename fmt) 583 (define lang (drracket:language-configuration:language-settings-language next-settings)) 584 (define settings (drracket:language-configuration:language-settings-settings 585 next-settings)) 586 (define name-mod (send lang get-reader-module)) 587 (when name-mod 588 ;; the reader-module method's result is used a test of whether or 589 ;; not the get-metadata method is used for this language 590 (let ([metadata (send lang get-metadata (filename->modname filename) settings)]) 591 (begin-edit-sequence #f #f) 592 (begin-metadata-changes) 593 (let ([locked? (is-locked?)]) 594 (when locked? (lock #f)) 595 (set! save-file-metadata metadata) 596 (while-unlocked 597 (λ () 598 (insert metadata 0 0))) 599 (when locked? (lock #t)))))) 600 (define/private (filename->modname filename) 601 (let-values ([(base name dir) (split-path filename)]) 602 (string->symbol (regexp-replace #rx"\\.[^.]*$" 603 (path->string name) 604 "")))) 605 606 (define/augment (after-save-file success?) 607 (when save-file-metadata 608 (let ([modified? (is-modified?)] 609 [locked? (is-locked?)]) 610 (when locked? (lock #f)) 611 (while-unlocked 612 (λ () 613 (delete 0 (string-length save-file-metadata)))) 614 (when locked? (lock #t)) 615 (set! save-file-metadata #f) 616 ;; restore modification status to where it was before the metadata is removed 617 (set-modified modified?) 618 (end-metadata-changes) 619 (end-edit-sequence))) 620 (inner (void) after-save-file success?)) 621 622 (define/augment (on-load-file filename format) 623 (inner (void) on-load-file filename format) 624 (begin-edit-sequence #f #f)) 625 (define/augment (after-load-file success?) 626 (when success? 627 (let-values ([(module-language module-language-settings) 628 (get-module-language/settings)]) 629 (let-values ([(matching-language settings) 630 (pick-new-language 631 this 632 (drracket:language-configuration:get-languages) 633 module-language 634 module-language-settings)]) 635 (cond 636 [matching-language 637 (set-next-settings 638 (drracket:language-configuration:language-settings 639 matching-language 640 settings) 641 #f)] 642 [else 643 (define lang (drracket:language-configuration:language-settings-language 644 (get-next-settings))) 645 (when (send lang get-reader-module) 646 (set-next-settings 647 (drracket:language-configuration:get-default-language-settings) 648 #f))]))) 649 (set-modified #f)) 650 651 (end-edit-sequence) 652 (inner (void) after-load-file success?)) 653 654 (define/augment (on-lexer-valid valid?) 655 (inner (void) on-lexer-valid valid?) 656 (let ([f (get-top-level-window)]) 657 (when (and f 658 (is-a? f drracket:unit:frame<%>)) 659 (send f set-color-status! valid?)))) 660 661 (define/override (get-can-close-parent) 662 (and tab (send tab get-frame))) 663 664 ;; if we use the tab to get to the top-level frame too 665 ;; soon then we use some GUI controls before they are 666 ;; initialized, so delay this until the file is 667 ;; opened in the definitions window 668 (define allow-top-level-connection #f) 669 (define/public (enable-top-level-window-connection) 670 (set! allow-top-level-connection #t)) 671 (define/override (get-top-level-window) 672 (or (super get-top-level-window) 673 (and allow-top-level-connection 674 tab 675 (send tab get-frame)))) 676 677 (inherit is-modified? run-after-edit-sequence) 678 (define/override (set-modified mod?) 679 (super set-modified mod?) 680 (run-after-edit-sequence 681 (λ () 682 (let ([f (get-top-level-window)]) 683 (when (and f 684 (is-a? f drracket:unit:frame<%>)) 685 (send f update-save-button)))))) 686 (define/override set-filename 687 (case-lambda 688 [(fn) (set-filename fn #f)] 689 [(fn tmp?) 690 (super set-filename fn tmp?) 691 (let ([f (get-top-level-window)]) 692 (when (and f 693 (is-a? f drracket:unit:frame<%>)) 694 (send (send f get-interactions-text) set-port-unsaved-name 695 (if fn 696 "interactions from an unsaved editor" 697 (format "interactions from ~a" fn))) 698 (send f update-save-message)))])) 699 700 (field 701 [needs-execution-state #f] 702 [already-warned-state #f] 703 [execute-settings (preferences:get 704 drracket:language-configuration:settings-preferences-symbol)] 705 [next-settings execute-settings]) 706 707 (define/private (set-needs-execution-state! s) (set! needs-execution-state s)) 708 709 ;; get-needs-execution-message : -> (or/c string #f) 710 ;; returns the current warning message if "Run" should be clicked (ie, if the 711 ;; state of the REPL is out of sync with drscheme). 712 (define/public (get-needs-execution-message) 713 (and (not already-warned-state) 714 (or (and (not (this-and-next-language-the-same?)) 715 (string-constant needs-execute-language-changed)) 716 needs-execution-state))) 717 718 (define/pubment (get-next-settings) next-settings) 719 (define/pubment (set-next-settings _next-settings [update-prefs? #t]) 720 (when (or 721 (send (drracket:language-configuration:language-settings-language _next-settings) 722 get-reader-module) 723 (send (drracket:language-configuration:language-settings-language next-settings) 724 get-reader-module)) 725 (set-modified #t)) 726 (set! next-settings _next-settings) 727 (let ([f (get-top-level-window)]) 728 (when (and f 729 (is-a? f drracket:unit:frame<%>)) 730 (send f language-changed))) 731 732 (highlight-first-line 733 (is-a? (drracket:language-configuration:language-settings-language _next-settings) 734 drracket:module-language:module-language<%>)) 735 736 (let ([lang (drracket:language-configuration:language-settings-language next-settings)] 737 [sets (drracket:language-configuration:language-settings-settings next-settings)]) 738 (preferences:set 739 'drracket:recent-language-names 740 (limit-length 741 (remove-duplicate-languages 742 (cons (cons (send lang get-language-name) 743 (send lang marshall-settings sets)) 744 (preferences:get 'drracket:recent-language-names))) 745 10))) 746 747 (when update-prefs? 748 (preferences:set 749 drracket:language-configuration:settings-preferences-symbol 750 next-settings)) 751 752 (remove-auto-text) 753 (insert-auto-text) 754 (after-set-next-settings _next-settings)) 755 756 (define/pubment (after-set-next-settings s) 757 (inner (void) after-set-next-settings s)) 758 759 (define/public (this-and-next-language-the-same?) 760 (define execute-lang 761 (drracket:language-configuration:language-settings-language execute-settings)) 762 (define next-lang 763 (drracket:language-configuration:language-settings-language next-settings)) 764 (and (equal? (send execute-lang get-language-position) 765 (send next-lang get-language-position)) 766 (equal? (send execute-lang marshall-settings 767 (drracket:language-configuration:language-settings-settings 768 execute-settings)) 769 (send execute-lang marshall-settings 770 (drracket:language-configuration:language-settings-settings 771 next-settings))))) 772 773 (define/pubment (set-needs-execution-message msg) 774 (set-needs-execution-state! msg)) 775 (define/pubment (teachpack-changed) 776 (set-needs-execution-state! (string-constant needs-execute-teachpack-changed))) 777 (define/pubment (just-executed) 778 (set! execute-settings next-settings) 779 (set-needs-execution-state! #f) 780 (send tab clear-execution-state) 781 (set! already-warned-state #f)) 782 (define/pubment (already-warned?) 783 already-warned-state) 784 (define/pubment (already-warned) 785 (set! already-warned-state #t)) 786 787 ;; the really-modified? flag determines if there 788 ;; is a modification that is not the insertion of the auto-text 789 (define really-modified? #f) 790 791 ;; when this flag is #t, edits to the buffer do not count as 792 ;; user's edits and so the yellow warning does not appear 793 (define ignore-edits? #f) 794 795 (define/augment (after-insert x y) 796 (unless ignore-edits? 797 (set! really-modified? #t) 798 (set-needs-execution-state! (string-constant needs-execute-defns-edited))) 799 (inner (void) after-insert x y)) 800 (define/augment (after-delete x y) 801 (unless ignore-edits? 802 (set! really-modified? #t) 803 (set-needs-execution-state! (string-constant needs-execute-defns-edited))) 804 (inner (void) after-delete x y)) 805 806 (define/override (is-special-first-line? l) 807 (and (preferences:get 'drracket:module-language-first-line-special?) 808 (is-lang-line? l))) 809 810 (inherit get-filename) 811 812 (inherit get-filename/untitled-name) 813 (define/private (get-date-string) 814 (string-append 815 (date->string (seconds->date (current-seconds))) 816 " " 817 (get-filename/untitled-name))) 818 819 (define/override (on-paint before dc left top right bottom dx dy draw-caret) 820 (super on-paint before dc left top right bottom dx dy draw-caret) 821 822 ;; [Disabled] For printing, put date and filename in the top margin: 823 (when (and #f before (is-printing?)) 824 (let ([h (box 0)] 825 [w (box 0)]) 826 (send (current-ps-setup) get-editor-margin w h) 827 (unless ((unbox h) . < . 2) 828 (let ([font (make-font #:size (inexact->exact (ceiling (* 1/2 (unbox h)))) 829 #:family 'modern)] 830 [old-font (send dc get-font)]) 831 (send dc set-font font) 832 (send dc draw-text (get-date-string) 0 0) 833 (send dc set-font old-font))))) 834 835 ;; draw the arrows 836 (when before 837 (when error-arrows 838 (define old-pen (send dc get-pen)) 839 (define old-brush (send dc get-brush)) 840 (send dc set-brush "red" 'solid) 841 (define font-size-factor 842 (cond 843 [(<= (editor:get-current-preferred-font-size) 12) 1] 844 [else (* (editor:get-current-preferred-font-size) 1/8)])) 845 (define pen-width font-size-factor) 846 (define arrow-head-size (* 8 font-size-factor)) 847 (define arrow-root-radius (* 1 font-size-factor)) 848 (send dc set-pen (send the-pen-list find-or-create-pen "red" 1 'solid)) 849 (let loop ([pts error-arrows]) 850 (cond 851 [(null? pts) (void)] 852 [(null? (cdr pts)) (void)] 853 [else (define pt1 (car pts)) 854 (define pt2 (cadr pts)) 855 (draw-arrow dc dx dy pt1 pt2 856 pen-width arrow-head-size arrow-root-radius) 857 (loop (cdr pts))])) 858 (send dc set-pen old-pen) 859 (send dc set-brush old-brush)))) 860 861 (define/private (draw-arrow dc dx dy pt1 pt2 pen-width arrow-head-size arrow-root-radius) 862 (define-values (x1 y1) 863 (find-poss (srcloc-source pt1) (- (srcloc-position pt1) 1) (srcloc-position pt1))) 864 (define-values (x2 y2) 865 (find-poss (srcloc-source pt2) (- (srcloc-position pt2) 1) (srcloc-position pt2))) 866 (drracket:arrow:draw-arrow dc x1 y1 x2 y2 dx dy 867 #:pen-width pen-width 868 #:arrow-head-size arrow-head-size 869 #:arrow-root-radius arrow-root-radius)) 870 871 (inherit dc-location-to-editor-location) 872 (define/private (find-poss text left-pos right-pos) 873 (let ([xlb (box 0)] 874 [ylb (box 0)] 875 [xrb (box 0)] 876 [yrb (box 0)]) 877 (send text position-location left-pos xlb ylb #t) 878 (send text position-location right-pos xrb yrb #f) 879 (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location 880 (unbox xlb) 881 (unbox ylb))] 882 [(xl yl) (dc-location-to-editor-location xl-off yl-off)] 883 [(xr-off yr-off) (send text editor-location-to-dc-location 884 (unbox xrb) 885 (unbox yrb))] 886 [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) 887 (values (/ (+ xl xr) 2) 888 (/ (+ yl yr) 2))))) 889 890 (define/public (still-untouched?) 891 (and (or (= (last-position) 0) (not really-modified?)) 892 (not (is-modified?)) 893 (not (get-filename)))) 894 ;; inserts the auto-text if any 895 (define/public (insert-auto-text) 896 (define lang 897 (drracket:language-configuration:language-settings-language 898 next-settings)) 899 (define auto-text 900 (and (not really-modified?) 901 (not (get-filename)) 902 (is-a? lang drracket:module-language:module-language<%>) 903 (send lang get-auto-text 904 (drracket:language-configuration:language-settings-settings 905 next-settings)))) 906 (when auto-text 907 (set! ignore-edits? #t) 908 (begin-edit-sequence #f #f) 909 (insert auto-text) 910 (set-modified #f) 911 (set! ignore-edits? #f) 912 (end-edit-sequence) 913 (set! really-modified? #f))) 914 (define/private (remove-auto-text) 915 (when (and (not really-modified?) 916 (not (get-filename)) 917 (> (last-position) 0)) 918 (begin-edit-sequence #f #f) 919 (send this erase) 920 (set-modified #f) 921 (end-edit-sequence) 922 (set! really-modified? #f))) 923 924 (inherit invalidate-bitmap-cache) 925 (define/public (set-error-arrows arrows) 926 (unless (eq? arrows error-arrows) 927 (set! error-arrows arrows) 928 (invalidate-bitmap-cache))) 929 930 (define error-arrows #f) 931 932 (super-new [show-line-numbers? (show-line-numbers?)]) 933 934 (highlight-first-line 935 (is-a? (drracket:language-configuration:language-settings-language next-settings) 936 drracket:module-language:module-language<%>)) 937 (inherit set-max-undo-history) 938 (set-max-undo-history 'forever) 939 940 (inherit set-inline-overview-enabled?) 941 (set-inline-overview-enabled? (preferences:get 'drracket:inline-overview-shown?)) 942 943 (inherit set-file-creator-and-type) 944 (set-file-creator-and-type #"DrSc" #f))))) 945 946 (define (get-module-language/settings) 947 (let* ([module-language 948 (and (preferences:get 'drracket:switch-to-module-language-automatically?) 949 (ormap 950 (λ (lang) 951 (and (is-a? lang drracket:module-language:module-language<%>) 952 lang)) 953 (drracket:language-configuration:get-languages)))] 954 [module-language-settings 955 (let ([prefs-setting (preferences:get 956 drracket:language-configuration:settings-preferences-symbol)]) 957 (cond 958 [(eq? (drracket:language-configuration:language-settings-language prefs-setting) 959 module-language) 960 (drracket:language-configuration:language-settings-settings prefs-setting)] 961 [else 962 (and module-language 963 (send module-language default-settings))]))]) 964 (values module-language module-language-settings))) 965 966 967 968 969 ; 970 ; 971 ; 972 ; 973 ; ;;; ;;;;;;; 974 ; ;;; ;;; 975 ; ;; ;;; ;;;; ;;;;; ;;; ;;; ;; ;;;; 976 ; ;;;;;;; ;; ;;;;;;;; ;;; ;;;;;;; ;; ;;; 977 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 978 ; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;;;;;; 979 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 980 ; ;;;;;;; ;;;;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;;; 981 ; ;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; 982 ; 983 ; 984 ; 985 ; 986 987 ;; get-pos : text mouse-event% -> (union #f number) 988 (define (get-pos text event) 989 (let*-values ([(event-x event-y) 990 (values (send event get-x) 991 (send event get-y))] 992 [(x y) (send text dc-location-to-editor-location 993 event-x 994 event-y)]) 995 (let* ([on-it? (box #f)] 996 [pos (send text find-position x y #f on-it?)]) 997 (and (unbox on-it?) 998 pos)))) 999 1000 (let ([old (keymap:add-to-right-button-menu)]) 1001 (keymap:add-to-right-button-menu 1002 (λ (menu editor event) 1003 (when (is-a? editor text%) 1004 (let* ([canvas (send editor get-canvas)] 1005 [frame (and canvas (send canvas get-top-level-window))]) 1006 (when (is-a? frame drracket:unit:frame<%>) 1007 (let* ([language-settings (send (send frame get-definitions-text) get-next-settings)] 1008 [new-language (drracket:language-configuration:language-settings-language 1009 language-settings)] 1010 [capability-info 1011 (get-define-popup-info 1012 (send new-language capability-value 'drscheme:define-popup))]) 1013 (when capability-info 1014 (let* ([current-pos (get-pos editor event)] 1015 [current-word (and current-pos (get-current-word editor current-pos))] 1016 [defn (and current-word 1017 (ormap (λ (defn) (and (string=? current-word (defn-name defn)) 1018 defn)) 1019 (get-definitions capability-info 1020 #f 1021 editor)))]) 1022 (when defn 1023 (new separator-menu-item% (parent menu)) 1024 (new menu-item% 1025 (parent menu) 1026 (label (gui-utils:format-literal-label (string-constant jump-to-defn) 1027 (defn-name defn))) 1028 (callback (λ (x y) 1029 (send editor set-position (defn-start-pos defn)))))))))))) 1030 (old menu editor event)))) 1031 1032 ;; get-current-word : editor number -> string 1033 ;; returns the string that is being clicked on 1034 (define (get-current-word editor pos) 1035 (let* ([search 1036 (λ (dir offset) 1037 (let loop ([pos pos]) 1038 (cond 1039 [(or (= pos 0) 1040 (= pos (send editor last-position))) 1041 pos] 1042 [(memq (send editor get-character pos) 1043 '(#\space #\return #\newline #\( #\) #\[ #\] #\tab)) 1044 (offset pos)] 1045 [else (loop (dir pos))])))] 1046 [before (search sub1 add1)] 1047 [after (search add1 (λ (x) x))]) 1048 (send editor get-text before after))) 1049 1050 (define func-defs-canvas% 1051 (class name-message% 1052 (init-field frame) 1053 1054 (unless (is-a? frame drracket:unit:frame<%>) 1055 (error 'func-defs-canvas "frame is not a drracket:unit:frame<%>")) 1056 1057 (define sort-by-name? (preferences:get 'drracket:defns-popup-sort-by-name?)) 1058 (define sorting-name (if sort-by-name? 1059 (string-constant sort-by-position) 1060 (string-constant sort-by-name))) 1061 (define/private (change-sorting-order) 1062 (set! sort-by-name? (not sort-by-name?)) 1063 (preferences:set 'drracket:defns-popup-sort-by-name? sort-by-name?) 1064 (set! sorting-name (if sort-by-name? 1065 (string-constant sort-by-position) 1066 (string-constant sort-by-name)))) 1067 1068 (define define-popup-capability-info 1069 (get-define-popup-info 1070 (drracket:language:get-capability-default 'drscheme:define-popup))) 1071 1072 (inherit set-message set-hidden?) 1073 (define/public (language-changed new-language vertical?) 1074 (set! define-popup-capability-info 1075 (get-define-popup-info 1076 (send new-language capability-value 'drscheme:define-popup))) 1077 (define define-name 1078 (get-define-popup-name define-popup-capability-info 1079 vertical?)) 1080 (cond 1081 [define-name 1082 (set-message #f define-name) 1083 (set-hidden? #f)] 1084 [else 1085 (set-hidden? #t)])) 1086 (define/override (fill-popup menu reset) 1087 (when define-popup-capability-info 1088 (define text (send frame get-definitions-text)) 1089 (define hidden-prefixes (preferences:get 'drracket:define-popup-hidden-prefixes)) 1090 (define popup-infos-to-use 1091 (for/list ([a-define-popup-capability-info (in-list define-popup-capability-info)] 1092 #:unless (member (define-popup-info-long-name a-define-popup-capability-info) 1093 hidden-prefixes)) 1094 a-define-popup-capability-info)) 1095 (define unsorted-defns (get-definitions popup-infos-to-use (not sort-by-name?) text)) 1096 (define defns (if sort-by-name? 1097 (sort 1098 unsorted-defns 1099 (λ (x y) (string-ci<=? (defn-name x) (defn-name y)))) 1100 unsorted-defns)) 1101 (cond 1102 [(= 1 (length define-popup-capability-info)) 1103 (new menu:can-restore-menu-item% 1104 [label sorting-name] 1105 [parent menu] 1106 [callback (λ (x y) (change-sorting-order))])] 1107 [else 1108 (define config-menu (new menu% [parent menu] [label define-menu-configure])) 1109 (new menu:can-restore-menu-item% 1110 [label sorting-name] 1111 [parent config-menu] 1112 [callback (λ (x y) (change-sorting-order))]) 1113 (for ([a-define-popup-capability-info (in-list define-popup-capability-info)]) 1114 (define lab (define-popup-info-long-name a-define-popup-capability-info)) 1115 (define item 1116 (new menu:can-restore-checkable-menu-item% 1117 [label lab] 1118 [parent config-menu] 1119 [callback 1120 (λ (_1 _2) 1121 (define curr (preferences:get 'drracket:define-popup-hidden-prefixes)) 1122 (define new 1123 (if (send item is-checked?) 1124 (remove lab curr) 1125 (remove-duplicates (cons lab curr)))) 1126 (preferences:set 'drracket:define-popup-hidden-prefixes new))])) 1127 (send item check (not (member lab hidden-prefixes))))]) 1128 1129 (make-object separator-menu-item% menu) 1130 (if (null? defns) 1131 (send (make-object menu:can-restore-menu-item% 1132 (string-constant no-definitions-found) 1133 menu 1134 void) 1135 enable #f) 1136 (let loop ([defns defns]) 1137 (unless (null? defns) 1138 (let* ([defn (car defns)] 1139 [checked? 1140 (let ([t-start (send text get-start-position)] 1141 [t-end (send text get-end-position)] 1142 [d-start (defn-start-pos defn)] 1143 [d-end (defn-end-pos defn)]) 1144 (or (<= t-start d-start t-end) 1145 (<= t-start d-end t-end) 1146 (<= d-start t-start t-end d-end)))] 1147 [item 1148 (make-object (if checked? 1149 menu:can-restore-checkable-menu-item% 1150 menu:can-restore-menu-item%) 1151 (gui-utils:quote-literal-label (defn-name defn)) 1152 1153 menu 1154 (λ (x y) 1155 (reset) 1156 (send text set-position (defn-start-pos defn) (defn-start-pos defn)) 1157 (let ([canvas (send text get-canvas)]) 1158 (when canvas 1159 (send canvas focus)))))]) 1160 (when checked? 1161 (send item check #t)) 1162 (loop (cdr defns)))))))) 1163 1164 (super-new (label "(define ...)") ;; this default is quickly changed 1165 [string-constant-untitled (string-constant untitled)] 1166 [string-constant-no-full-name-since-not-saved 1167 (string-constant no-full-name-since-not-saved)]))) 1168 1169 (define (set-box/f! b v) (when (box? b) (set-box! b v))) 1170 1171 ; 1172 ; 1173 ; 1174 ; 1175 ; ;;;; 1176 ; ;;; 1177 ; ;;;; ;;; ;;;;;;; ;;; ;; ;;; ;;;; 1178 ; ;;;; ;;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; 1179 ; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; 1180 ; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;; 1181 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 1182 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; 1183 ; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;; 1184 ; 1185 ; 1186 ; 1187 ; 1188 1189 (define dragable/def-int-mixin 1190 (mixin (panel:dragable<%>) () 1191 (init-field unit-frame) 1192 (inherit get-percentages popup-menu 1193 set-orientation get-vertical?) 1194 (define/augment (after-percentage-change) 1195 (define percentages (get-percentages)) 1196 (when (and (= 1 1197 (length (send unit-frame get-definitions-canvases)) 1198 (length (send unit-frame get-interactions-canvases))) 1199 (= 2 (length percentages))) 1200 (preferences:set 'drracket:unit-window-size-percentage (car percentages))) 1201 (inner (void) after-percentage-change)) 1202 (define/override (right-click-in-gap evt before after) 1203 (define menu (new popup-menu%)) 1204 (define vertical? (get-vertical?)) 1205 (new menu-item% 1206 [parent menu] 1207 [label 1208 ;; something seems to be wrong with the get-vertical? method... 1209 (if vertical? 1210 (string-constant change-to-vertical-alignment) 1211 (string-constant change-to-horizontal-alignment))] 1212 [callback 1213 (λ (a b) 1214 (preferences:set 'drracket:defs/ints-horizontal vertical?) 1215 (set-orientation vertical?))]) 1216 (popup-menu menu (send evt get-x) (send evt get-y))) 1217 (super-new))) 1218 1219 (define vertical-dragable/def-int% (dragable/def-int-mixin panel:vertical-dragable%)) 1220 (define horizontal-dragable/def-int% (dragable/def-int-mixin panel:horizontal-dragable%)) 1221 1222 (define tab% 1223 (class* object% (drracket:rep:context<%> drracket:unit:tab<%>) 1224 (init-field frame 1225 defs 1226 i 1227 defs-shown? 1228 ints-shown?) 1229 (define enabled? #t) 1230 (field [ints #f] 1231 [visible-defs #f] 1232 [visible-ints #f] 1233 [focus-d/i 'defs]) 1234 1235 ;; only called to initialize this tab. 1236 ;; the interactions editor should be invariant. 1237 (define/public (set-ints i) (set! ints i)) 1238 1239 (define/public-final (get-frame) frame) 1240 (define/public-final (get-defs) defs) 1241 (define/public-final (get-ints) ints) 1242 (define/public-final (get-visible-defs) (values visible-defs defs-shown?)) 1243 (define/public-final (set-visible-defs vd ds?) 1244 (set! visible-defs vd) 1245 (set! defs-shown? ds?)) 1246 (define/public-final (get-visible-ints) (values visible-ints ints-shown?)) 1247 (define/public-final (set-visible-ints vi is?) 1248 (set! visible-ints vi) 1249 (set! ints-shown? is?)) 1250 (define/public-final (set-focus-d/i di) 1251 (set! focus-d/i di)) 1252 (define/public-final (get-focus-d/i) focus-d/i) 1253 (define/public-final (get-i) i) 1254 (define/public-final (set-i _i) (set! i _i)) 1255 (define/public (disable-evaluation) 1256 (set! enabled? #f) 1257 (send ints lock #t) 1258 (send frame disable-evaluation-in-tab this)) 1259 (define/public (enable-evaluation) 1260 (set! enabled? #t) 1261 (send ints lock #f) 1262 (send frame enable-evaluation-in-tab this)) 1263 (define/public (get-enabled) enabled?) 1264 1265 (define last-touched (current-inexact-milliseconds)) 1266 (define/public-final (touched) (set! last-touched (current-inexact-milliseconds))) 1267 (define/public-final (get-last-touched) last-touched) 1268 1269 (define panel-percentages #f) 1270 (define panel-orientation #f) 1271 (define/public (set-panel-percentages-and-orientation p o) 1272 (set! panel-percentages p) 1273 (set! panel-orientation o)) 1274 (define/public (get-panel-percentages-and-orientation) 1275 (values panel-percentages panel-orientation)) 1276 1277 1278 ;; current-execute-warning is a snapshot of the needs-execution-message 1279 ;; that is taken each time repl submission happens, and it gets reset 1280 ;; when "Run" is clicked. 1281 (define current-execute-warning #f) 1282 (define/pubment (repl-submit-happened) 1283 (set! current-execute-warning (send defs get-needs-execution-message)) 1284 (update-execute-warning-gui)) 1285 (define/public (get-current-execute-warning) current-execute-warning) 1286 (define/public (clear-execution-state) 1287 (set! current-execute-warning #f) 1288 (update-execute-warning-gui) 1289 (send defs already-warned)) 1290 (define/public (update-execute-warning-gui) 1291 (when (is-current-tab?) 1292 (send frame show/hide-warning-message 1293 (get-current-execute-warning) 1294 (λ () 1295 ;; this callback might be run with a different tab ... 1296 (send (send frame get-current-tab) clear-execution-state))))) 1297 1298 (define/public (get-directory) 1299 (define bx (box #f)) 1300 (define filename (send defs get-filename bx)) 1301 (get-init-dir 1302 (and (not (unbox bx)) filename))) 1303 1304 (define/pubment (can-close?) 1305 (and (send defs can-close?) 1306 (send ints can-close?) 1307 (inner #t can-close?))) 1308 (define/pubment (on-close) 1309 (send defs on-close) 1310 (send ints on-close) 1311 (inner (void) on-close)) 1312 1313 ;; this should really do something local to the tab, but 1314 ;; for now it doesn't. 1315 (define/public (ensure-rep-shown rep) 1316 (send frame ensure-rep-shown rep)) 1317 1318 (field [thread-to-break-box (make-weak-box #f)] 1319 [custodian-to-kill-box (make-weak-box #f)] 1320 [do-kill? #f]) 1321 1322 (define/public (does-break-kill?) do-kill?) 1323 ;; break-callback : -> void 1324 (define/public (break-callback) 1325 (let ([thread-to-break (weak-box-value thread-to-break-box)] 1326 [custodian-to-kill (weak-box-value custodian-to-kill-box)]) 1327 (cond 1328 [(or (not thread-to-break) 1329 (not custodian-to-kill)) 1330 (bell)] 1331 [do-kill? 1332 (when custodian-to-kill 1333 (custodian-shutdown-all custodian-to-kill)) 1334 (set! do-kill? #f) 1335 (send (get-frame) update-kill-button-label)] 1336 [else 1337 (when thread-to-break 1338 (break-thread thread-to-break)) 1339 ;; only offer a kill the next time if 1340 ;; something got broken. 1341 (set! do-kill? #t) 1342 (send (get-frame) update-kill-button-label)]))) 1343 1344 ;; reset-offer-kill 1345 (define/public (reset-offer-kill) 1346 (set! do-kill? #f) 1347 (send (get-frame) update-kill-button-label)) 1348 1349 ;; get-breakables : -> (union #f thread) (union #f cust) -> void 1350 (define/public (get-breakables) 1351 (values (weak-box-value thread-to-break-box) (weak-box-value custodian-to-kill-box))) 1352 1353 ;; set-breakables : (union #f thread) (union #f cust) -> void 1354 (define/public (set-breakables thd cust) 1355 (set! thread-to-break-box (make-weak-box thd)) 1356 (set! custodian-to-kill-box (make-weak-box cust))) 1357 1358 (define/pubment (clear-annotations) 1359 (inner (void) clear-annotations) 1360 (send ints reset-highlighting)) 1361 1362 (define running? #f) 1363 (define/public-final (is-running?) running?) 1364 (define/public (update-running b?) 1365 (set! running? b?) 1366 (send frame update-running b?)) 1367 1368 (define/public-final (is-current-tab?) (eq? this (send frame get-current-tab))) 1369 1370 (define log-visible? #f) 1371 (define/public-final (toggle-log) 1372 (set! log-visible? (not log-visible?)) 1373 (send frame show/hide-log log-visible?) 1374 (send (get-ints) enable/disable-capture-log log-visible?)) 1375 (define/public-final (hide-log) 1376 (when log-visible? (toggle-log))) 1377 (define/public-final (update-log) 1378 (send frame show/hide-log log-visible?) 1379 (send frame set-logger-text-field-value (send (get-ints) get-user-log-receiver-args-str))) 1380 (define/public-final (update-logger-window command) 1381 (when (is-current-tab?) 1382 (send frame update-logger-window command))) 1383 1384 (define current-planet-status #f) 1385 (define/public-final (new-planet-status a b) 1386 (set! current-planet-status (cons a b)) 1387 (update-planet-status)) 1388 (define/public-final (clear-planet-status) 1389 (set! current-planet-status #f) 1390 (update-planet-status)) 1391 (define/public-final (update-planet-status) 1392 (send frame show-planet-status 1393 (and current-planet-status 1394 (car current-planet-status)) 1395 (and current-planet-status 1396 (cdr current-planet-status)))) 1397 1398 (super-new))) 1399 1400 ;; should only be called by the tab% object (and the class itself) 1401 (define-local-member-name 1402 disable-evaluation-in-tab 1403 enable-evaluation-in-tab 1404 update-toolbar-visibility 1405 show/hide-log 1406 set-logger-text-field-value 1407 show-planet-status 1408 enable-top-level-window-connection) 1409 1410 (define frame-mixin 1411 (mixin (drracket:frame:<%> frame:status-line<%> frame:searchable-text<%> frame:size-pref<%>) 1412 (drracket:unit:frame<%>) 1413 (init filename) 1414 (inherit set-label-prefix get-show-menu 1415 get-menu% 1416 get-area-container 1417 update-info 1418 get-file-menu 1419 search-hidden? 1420 unhide-search 1421 hide-search 1422 file-menu:get-close-item 1423 file-menu:get-save-item 1424 file-menu:get-save-as-item 1425 file-menu:get-revert-item 1426 file-menu:get-print-item 1427 get-eventspace) 1428 1429 (define resizable-panel (drr-named-undefined 'resizable-panel)) 1430 (define definitions-canvas (drr-named-undefined 'definitions-canvas)) 1431 (define definitions-canvases (drr-named-undefined 'definitions-canvases)) 1432 (define interactions-canvas (drr-named-undefined 'interactions-canvas)) 1433 (define interactions-canvases (drr-named-undefined 'interactions-canvases)) 1434 (define button-panel (drr-named-undefined 'button-panel)) 1435 1436 1437 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1438 ;; 1439 ;; execute warning 1440 ;; 1441 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1442 1443 (define execute-warning-panel #f) 1444 (define execute-warning-parent-panel #f) 1445 (define execute-warning-canvas #f) 1446 (define/public-final (show/hide-warning-message msg hide-canvas) 1447 (when (and execute-warning-parent-panel 1448 execute-warning-panel) 1449 (cond 1450 [msg 1451 (cond 1452 [execute-warning-canvas 1453 (send execute-warning-canvas set-message msg)] 1454 [else 1455 (set! execute-warning-canvas 1456 (new execute-warning-canvas% 1457 [stretchable-height #t] 1458 [parent execute-warning-panel] 1459 [message msg])) 1460 (new close-icon% 1461 [parent execute-warning-panel] 1462 [bg-color "yellow"] 1463 [callback (λ () (hide-canvas))])]) 1464 (send execute-warning-parent-panel 1465 change-children 1466 (λ (l) (append (remq execute-warning-panel l) 1467 (list execute-warning-panel))))] 1468 [else 1469 (when execute-warning-canvas 1470 (send execute-warning-parent-panel 1471 change-children 1472 (λ (l) (remq execute-warning-panel l))) 1473 (send execute-warning-canvas set-message #f))]))) 1474 1475 1476 ;; bind the proc to a field 1477 ;; so it stays alive as long 1478 ;; as the frame stays alive 1479 (define show-line-numbers-pref-fn 1480 (let ([fn (lambda (pref value) 1481 (when show-line-numbers-menu-item 1482 (send show-line-numbers-menu-item set-label 1483 (if value 1484 (string-constant hide-line-numbers/menu) 1485 (string-constant show-line-numbers/menu)))) 1486 (show-line-numbers! value))]) 1487 (preferences:add-callback 1488 'drracket:show-line-numbers? 1489 fn 1490 #t) 1491 fn)) 1492 (define show-line-numbers-menu-item #f) 1493 1494 (define/override (add-line-number-menu-items menu) 1495 (define on? (preferences:get 'drracket:show-line-numbers?)) 1496 (new separator-menu-item% [parent menu]) 1497 (new checkable-menu-item% 1498 [label (string-constant show-line-numbers-in-definitions)] 1499 [parent menu] 1500 [checked on?] 1501 [callback 1502 (λ (c dc) 1503 (preferences:set 'drracket:show-line-numbers? (not on?)))]) 1504 (super add-line-number-menu-items menu)) 1505 1506 (define/private (show-line-numbers! show) 1507 (for ([tab tabs]) 1508 (define text (send tab get-defs)) 1509 (send text show-line-numbers! show)) 1510 (send definitions-canvas refresh)) 1511 1512 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1513 ;; 1514 ;; logging 1515 ;; 1516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1517 1518 (define logger-panel #f) 1519 (define logger-parent-panel #f) 1520 1521 ;; logger-gui-content-panel: (or/c #f (is-a?/c vertical-panel%)) 1522 ;; this is #f when the GUI has not been built yet. After 1523 ;; it becomes a panel, it is always a panel 1524 ;; (altho the panel might not always be shown) 1525 (define logger-gui-content-panel #f) 1526 (define logger-gui-canvas #f) 1527 (define logger-checkbox #f) 1528 (define logger-text-field #f) 1529 1530 ;; logger-gui-text: (or/c #f (is-a?/c text%)) 1531 ;; this is #f when the GUI has not been built or when the logging panel is hidden 1532 ;; in that case, the logging messages aren't begin saved in an editor anywhere 1533 (define logger-gui-text #f) 1534 1535 (define logger-menu-item #f) 1536 1537 (define/public-final (show/hide-log show?) 1538 (let ([p (preferences:get 'drracket:logging-size-percentage)]) 1539 (begin-container-sequence) 1540 (cond 1541 [logger-gui-content-panel 1542 (send logger-parent-panel change-children 1543 (λ (l) 1544 (cond 1545 [(or (and show? (member logger-panel l)) 1546 (and (not show?) 1547 (not (member logger-panel l)))) 1548 ;; if things are already up to date, only update the logger text 1549 (when show? 1550 (update-logger-window #f)) 1551 l] 1552 [show? 1553 (new-logger-text) 1554 (send logger-gui-canvas set-editor logger-gui-text) 1555 (update-logger-window #f) 1556 (send logger-menu-item set-label (string-constant hide-log)) 1557 (append (remq logger-panel l) (list logger-panel))] 1558 [else 1559 (send logger-menu-item set-label (string-constant show-log)) 1560 (set! logger-gui-text #f) 1561 (send logger-gui-canvas set-editor #f) 1562 (remq logger-panel l)])))] 1563 [else 1564 (when show? ;; if we want to hide and it isn't built yet, do nothing 1565 (define logger-gui-content-panel-parent (new-vertical-panel% 1566 [style '(border)] 1567 [parent logger-panel] 1568 [stretchable-height #t])) 1569 (set! logger-gui-content-panel 1570 (new-horizontal-panel% 1571 [parent logger-gui-content-panel-parent] 1572 [stretchable-height #f])) 1573 (new-logger-text) 1574 (set! logger-gui-canvas 1575 (new editor-canvas% 1576 [parent logger-gui-content-panel-parent] 1577 [style '(transparent no-border)] 1578 [editor logger-gui-text])) 1579 (new message% [label (string-constant log-messages)] [parent logger-gui-content-panel]) 1580 (new button% 1581 [label (string-constant help)] 1582 [callback (λ (x y) 1583 (define-values (path tag) 1584 (xref-tag->path+anchor 1585 (load-collections-xref) 1586 (make-section-tag 1587 "follow-log" 1588 #:doc '(lib "scribblings/drracket/drracket.scrbl")))) 1589 (define url (path->url path)) 1590 (define url2 (if tag 1591 (make-url (url-scheme url) 1592 (url-user url) 1593 (url-host url) 1594 (url-port url) 1595 (url-path-absolute? url) 1596 (url-path url) 1597 (url-query url) 1598 tag) 1599 url)) 1600 (send-url (url->string url2)))] 1601 [parent logger-gui-content-panel]) 1602 (set! logger-text-field 1603 (keymap:call/text-keymap-initializer 1604 (λ () 1605 (new text-field% 1606 [parent logger-gui-content-panel] 1607 [label "‹level›@‹name› ..."] 1608 [init-value 1609 (send (get-interactions-text) get-user-log-receiver-args-str)] 1610 [callback 1611 (λ (tf evt) 1612 (define str (send (send tf get-editor) get-text)) 1613 (define args (parse-logger-args str)) 1614 (preferences:set 'drracket:logger-receiver-string str) 1615 (send (get-interactions-text) set-user-log-receiver-args 1616 str 1617 (if (null? args) #f args)) 1618 (set-logger-text-field-bg-color args))])))) 1619 (set-logger-text-field-bg-color (parse-logger-args (send logger-text-field get-value))) 1620 (set! logger-checkbox 1621 (new check-box% 1622 [label (string-constant logger-scroll-on-output)] 1623 [callback (λ (a b) (preferences:set 'drracket:logger-scroll-to-bottom? 1624 (send logger-checkbox get-value)))] 1625 [parent logger-gui-content-panel] 1626 [value (preferences:get 'drracket:logger-scroll-to-bottom?)])) 1627 (new button% 1628 [label (string-constant hide-log)] 1629 [callback (λ (x y) (send current-tab hide-log))] 1630 [parent logger-gui-content-panel]) 1631 (send logger-menu-item set-label (string-constant hide-log)) 1632 (update-logger-window #f) 1633 (send logger-parent-panel change-children (λ (l) (append l (list logger-panel)))))]) 1634 (with-handlers ([exn:fail? void]) 1635 (send logger-parent-panel set-percentages (list p (- 1 p)))) 1636 (update-logger-button-label) 1637 (end-container-sequence))) 1638 1639 (define/public (set-logger-text-field-value str) 1640 (when logger-text-field 1641 (send logger-text-field set-value str) 1642 (set-logger-text-field-bg-color (parse-logger-args str)))) 1643 1644 (define/private (set-logger-text-field-bg-color good?) 1645 (send logger-text-field set-field-background 1646 (color-prefs:lookup-in-color-scheme 1647 (if good? 1648 'framework:basic-canvas-background 1649 'framework:failed-search-background-color)))) 1650 1651 (define/private (log-shown?) 1652 (and logger-gui-content-panel 1653 (member logger-panel (send logger-parent-panel get-children)))) 1654 1655 (define/private (new-logger-text) 1656 (set! logger-gui-text (new (text:hide-caret/selection-mixin 1657 (editor:standard-style-list-mixin 1658 text:line-spacing%)))) 1659 (send logger-gui-text lock #t)) 1660 1661 (define/public (update-logger-window command) 1662 (when logger-gui-text 1663 (define admin (send logger-gui-text get-admin)) 1664 (define canvas (send logger-gui-text get-canvas)) 1665 (define (adjust-color start) 1666 (when (white-on-black-panel-scheme?) 1667 (define sd (make-object style-delta%)) 1668 (send sd set-delta-foreground "white") 1669 (send logger-gui-text change-style 1670 sd 1671 start 1672 (send logger-gui-text last-position)))) 1673 (when (and canvas admin) 1674 (define logger-messages (send interactions-text get-logger-messages)) 1675 (cond 1676 [(and (pair? command) 1677 (pair? logger-messages) 1678 ;; just flush and redraw everything if there is one (or zero) logger messages 1679 (pair? (cdr logger-messages))) 1680 (define msg (cdr command)) 1681 (define scroll? (if (object? logger-checkbox) 1682 (send logger-checkbox get-value) 1683 #t)) 1684 (send logger-gui-text begin-edit-sequence) 1685 (send logger-gui-text lock #f) 1686 (define start (send logger-gui-text last-position)) 1687 (case (car command) 1688 [(add-line) (void)] 1689 [(clear-last-and-add-line) 1690 (send logger-gui-text delete 1691 0 1692 (send logger-gui-text paragraph-start-position 1) 1693 #f)]) 1694 (send logger-gui-text insert 1695 "\n" 1696 (send logger-gui-text last-position) 1697 (send logger-gui-text last-position) 1698 #f) 1699 (send logger-gui-text insert 1700 msg 1701 (send logger-gui-text last-position) 1702 (send logger-gui-text last-position) 1703 #f) 1704 (when scroll? 1705 (send logger-gui-text scroll-to-position 1706 (send logger-gui-text 1707 paragraph-start-position 1708 (send logger-gui-text last-paragraph)))) 1709 (adjust-color start) 1710 (send logger-gui-text end-edit-sequence) 1711 (send logger-gui-text lock #t)] 1712 [else 1713 (send logger-gui-text begin-edit-sequence) 1714 (send logger-gui-text lock #f) 1715 (send logger-gui-text erase) 1716 (define start (send logger-gui-text last-position)) 1717 1718 (define (insert-one msg) 1719 (send logger-gui-text insert msg 0 0)) 1720 1721 (unless (null? logger-messages) 1722 ;; skip the last newline in the buffer 1723 (insert-one (car logger-messages)) 1724 (for ([msg (in-list (cdr (send interactions-text get-logger-messages)))]) 1725 (insert-one "\n") 1726 (insert-one msg))) 1727 1728 (adjust-color start) 1729 (send logger-gui-text lock #t) 1730 (send logger-gui-text end-edit-sequence)])))) 1731 1732 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1733 ;; 1734 ;; planet status 1735 ;; 1736 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1737 1738 (define planet-status-parent-panel #f) 1739 (define planet-status-panel #f) 1740 (define planet-message #f) 1741 (define planet-logger-button #f) 1742 ;; local-member-name 1743 (define/public (show-planet-status tag package) 1744 (cond 1745 [(and (not tag) 1746 (not package) 1747 (or (not planet-status-parent-panel) 1748 (not (member planet-status-panel 1749 (send planet-status-parent-panel get-children))))) 1750 ;; if there is no information and there is no GUI there, don't do anything 1751 (void)] 1752 [else 1753 (when planet-status-panel 1754 (unless planet-message 1755 (new message% 1756 [parent planet-status-panel] 1757 [label drracket:debug:small-planet-bitmap]) 1758 (set! planet-message (new message% 1759 [parent planet-status-panel] 1760 [label ""] 1761 [stretchable-width #t])) 1762 (set! planet-logger-button 1763 (new button% 1764 [font small-control-font] 1765 [parent planet-status-panel] 1766 [label (string-constant show-log)] 1767 [callback (λ (a b) (send current-tab toggle-log))])) 1768 (update-logger-button-label) 1769 (new close-icon% 1770 [parent planet-status-panel] 1771 [callback (λ () 1772 (send planet-status-parent-panel change-children 1773 (λ (l) 1774 (remq planet-status-panel l))) 1775 (send current-tab clear-planet-status))])) 1776 (send planet-message set-label 1777 (case tag 1778 [(download) 1779 (format (string-constant planet-downloading) package)] 1780 [(install) 1781 (format (string-constant planet-installing) package)] 1782 [(docs-build) 1783 (format (string-constant planet-docs-building) package)] 1784 [(finish) 1785 (format (string-constant planet-finished) package)] 1786 [else 1787 (string-constant planet-no-status)])) 1788 (send planet-status-parent-panel change-children 1789 (λ (l) 1790 (if (memq planet-status-panel l) 1791 l 1792 (append (remq planet-status-panel l) (list planet-status-panel))))))])) 1793 1794 (define/private (update-logger-button-label) 1795 (when planet-logger-button 1796 (send planet-logger-button set-label 1797 (if (and logger-gui-text 1798 (member logger-panel (send logger-parent-panel get-children))) 1799 (string-constant hide-log) 1800 (string-constant show-log))))) 1801 1802 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1803 ;; 1804 ;; transcript 1805 ;; 1806 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1807 1808 1809 ;; transcript : (union #f string[directory-name]) 1810 (field [transcript #f] 1811 [definitions-transcript-counter 0] ;; number 1812 [interactions-transcript-counter 0] ;; number 1813 [transcript-parent-panel #f] ;; panel (unitialized short time only) 1814 [transcript-panel #f] ;; panel (unitialized short time only) 1815 [transcript-menu-item #f]) ;; menu-item (unitialized short time only) 1816 ;; record-definitions : -> void 1817 (define/private (record-definitions) 1818 (when transcript 1819 (set! definitions-transcript-counter (+ definitions-transcript-counter 1)) 1820 (send definitions-text save-file 1821 (build-path transcript (format "~a-definitions" 1822 (pad-two definitions-transcript-counter))) 1823 'copy))) 1824 1825 ;; record-ineractions : -> void 1826 (define/private (record-interactions) 1827 (when transcript 1828 (set! interactions-transcript-counter (+ interactions-transcript-counter 1)) 1829 (send interactions-text save-file 1830 (build-path transcript (format "~a-interactions" 1831 (pad-two interactions-transcript-counter))) 1832 'copy))) 1833 1834 ;; pad-two : number -> string 1835 ;; pads a number to two digits? 1836 (define/private (pad-two n) 1837 (cond 1838 [(<= 0 n 9) (format "0~a" n)] 1839 [else (format "~a" n)])) 1840 1841 ;; start-transcript : -> void 1842 ;; turns on the transcript and shows the transcript gui 1843 (define/private (start-transcript) 1844 (let ([transcript-directory (mred:get-directory 1845 (string-constant please-choose-a-log-directory) 1846 this)]) 1847 (when (and transcript-directory 1848 (ensure-empty transcript-directory)) 1849 (send transcript-menu-item set-label (string-constant stop-logging)) 1850 (set! transcript transcript-directory) 1851 (set! definitions-transcript-counter 0) 1852 (set! interactions-transcript-counter 0) 1853 (build-transcript-panel) 1854 (record-definitions)))) 1855 1856 ;; stop-transcript : -> void 1857 ;; turns off the transcript procedure 1858 (define/private (stop-transcript) 1859 (record-interactions) 1860 (send transcript-menu-item set-label (string-constant log-definitions-and-interactions)) 1861 (set! transcript #f) 1862 (send transcript-panel change-children (λ (l) null))) 1863 1864 ;; build-transcript-panel : -> void 1865 ;; builds the contents of the transcript panel 1866 (define/private (build-transcript-panel) 1867 (define hp (make-object horizontal-panel% transcript-panel '(border))) 1868 (make-object message% (string-constant logging-to) hp) 1869 (send (make-object message% (path->string transcript) hp) stretchable-width #t) 1870 (make-object button% (string-constant stop-logging) hp (λ (x y) (stop-transcript)))) 1871 1872 ;; ensure-empty : string[directory] -> boolean 1873 ;; if the transcript-directory is empty, just return #t 1874 ;; if not, ask the user about emptying it. 1875 ;; if they say yes, try to empty it. 1876 ;; if that fails, report the error and return #f. 1877 ;; if it succeeds, return #t. 1878 ;; if they say no, return #f. 1879 (define/private (ensure-empty transcript-directory) 1880 (let ([dir-list (directory-list transcript-directory)]) 1881 (or (null? dir-list) 1882 (let ([query (message-box 1883 (string-constant drscheme) 1884 (gui-utils:format-literal-label 1885 (string-constant erase-log-directory-contents) 1886 transcript-directory) 1887 this 1888 '(yes-no) 1889 #:dialog-mixin frame:focus-table-mixin)]) 1890 (cond 1891 [(equal? query 'no) 1892 #f] 1893 [(equal? query 'yes) 1894 (with-handlers ([exn:fail:filesystem? 1895 (λ (exn) 1896 (message-box 1897 (string-constant drscheme) 1898 (gui-utils:format-literal-label 1899 (string-constant error-erasing-log-directory) 1900 (if (exn? exn) 1901 (format "~a" (exn-message exn)) 1902 (format "~s" exn))) 1903 this 1904 #:dialog-mixin frame:focus-table-mixin) 1905 #f)]) 1906 (for-each (λ (file) (delete-file (build-path transcript-directory file))) 1907 dir-list) 1908 #t)]))))) 1909 1910 (define/override (make-root-area-container cls parent) 1911 (let* ([_module-browser-parent-panel 1912 (super make-root-area-container 1913 (make-two-way-prefs-dragable-panel% panel:horizontal-dragable% 1914 'drracket:module-browser-size-percentage) 1915 parent)] 1916 [_module-browser-panel (new-vertical-panel% 1917 (parent _module-browser-parent-panel) 1918 (alignment '(left center)) 1919 (stretchable-width #f))] 1920 [planet-status-outer-panel (new vertical-pane% [parent _module-browser-parent-panel])] 1921 [execute-warning-outer-panel (new vertical-pane% [parent planet-status-outer-panel])] 1922 [logger-outer-panel (new (make-two-way-prefs-dragable-panel% 1923 panel:vertical-dragable% 1924 'drracket:logging-size-percentage) 1925 [parent execute-warning-outer-panel])] 1926 [trans-outer-panel (new vertical-pane% [parent logger-outer-panel])] 1927 [root (make-object cls trans-outer-panel)]) 1928 (set! module-browser-parent-panel _module-browser-parent-panel) 1929 (set! module-browser-panel _module-browser-panel) 1930 (send module-browser-parent-panel change-children (λ (l) (remq module-browser-panel l))) 1931 (set! logger-parent-panel logger-outer-panel) 1932 (set! logger-panel (new-vertical-panel% [parent logger-parent-panel])) 1933 (send logger-parent-panel change-children (lambda (x) (remq logger-panel x))) 1934 1935 (set! execute-warning-parent-panel execute-warning-outer-panel) 1936 (set! execute-warning-panel (new-horizontal-panel% 1937 [parent execute-warning-parent-panel] 1938 [stretchable-height #f])) 1939 (send execute-warning-parent-panel change-children (λ (l) (remq execute-warning-panel l))) 1940 1941 (set! transcript-parent-panel (new-horizontal-panel% 1942 (parent trans-outer-panel) 1943 (stretchable-height #f))) 1944 (set! transcript-panel (make-object horizontal-panel% transcript-parent-panel)) 1945 (set! planet-status-parent-panel (new-vertical-panel% 1946 [parent planet-status-outer-panel] 1947 [stretchable-height #f])) 1948 (set! planet-status-panel (new-horizontal-panel% 1949 [parent planet-status-parent-panel])) 1950 (send planet-status-parent-panel change-children (λ (l) (remq planet-status-panel l))) 1951 (unless (toolbar-shown?) 1952 (send transcript-parent-panel change-children (λ (l) '()))) 1953 (send logger-outer-panel enable-two-way-prefs) 1954 (send _module-browser-parent-panel enable-two-way-prefs) 1955 1956 root)) 1957 1958 (inherit show-info hide-info is-info-hidden?) 1959 (field [toolbar-state (preferences:get 'drracket:toolbar-state)] 1960 [toolbar-top-menu-item #f] 1961 [toolbar-top-no-label-menu-item #f] 1962 [toolbar-left-menu-item #f] 1963 [toolbar-right-menu-item #f] 1964 [toolbar-hidden-menu-item #f] 1965 [toolbar-menu #f]) 1966 1967 ;; returns #t if the toolbar is visible, #f otherwise 1968 (define/private (toolbar-shown?) (car toolbar-state)) 1969 1970 (define/private (change-toolbar-state new-state) 1971 (set! toolbar-state new-state) 1972 (preferences:set 'drracket:toolbar-state new-state) 1973 (update-toolbar-visibility)) 1974 1975 (define/override (on-toolbar-button-click) 1976 (change-toolbar-state (cons (not (car toolbar-state)) (cdr toolbar-state)))) 1977 (define/private (set-toolbar-left) (change-toolbar-state (cons #f 'left))) 1978 (define/private (set-toolbar-right) (change-toolbar-state (cons #f 'right))) 1979 (define/private (set-toolbar-top) (change-toolbar-state (cons #f 'top))) 1980 (define/private (set-toolbar-top-no-label) (change-toolbar-state (cons #f 'top-no-label))) 1981 (define/private (set-toolbar-hidden) (change-toolbar-state (cons #t (cdr toolbar-state)))) 1982 1983 (define/public (update-toolbar-visibility) 1984 (let* ([hidden? (toolbar-is-hidden?)] 1985 [left? (toolbar-is-left?)] 1986 [right? (toolbar-is-right?)] 1987 [top? (toolbar-is-top?)] 1988 [top-no-label? (toolbar-is-top-no-label?)]) 1989 1990 (send toolbar-left-menu-item check left?) 1991 (send toolbar-right-menu-item check right?) 1992 (send toolbar-top-menu-item check top?) 1993 (send toolbar-top-no-label-menu-item check top-no-label?) 1994 (send toolbar-hidden-menu-item check hidden?) 1995 1996 (cond 1997 [hidden? 1998 (hide-info) 1999 (send top-outer-panel change-children (λ (l) '())) 2000 (send transcript-parent-panel change-children (λ (l) '()))] 2001 [top? (orient/show #t)] 2002 [top-no-label? (orient/show #t)] 2003 [left? (orient/show #t)] 2004 [right? (orient/show #f)])) 2005 (update-defs/ints-resize-corner)) 2006 2007 (define/private (toolbar-is-hidden?) 2008 (car (preferences:get 'drracket:toolbar-state))) 2009 (define/private (toolbar-is-top?) 2010 (and (not (toolbar-is-hidden?)) 2011 (equal? (cdr (preferences:get 'drracket:toolbar-state)) 2012 'top))) 2013 (define/private (toolbar-is-right?) 2014 (and (not (toolbar-is-hidden?)) 2015 (equal? (cdr (preferences:get 'drracket:toolbar-state)) 2016 'right))) 2017 (define/private (toolbar-is-left?) 2018 (and (not (toolbar-is-hidden?)) 2019 (equal? (cdr (preferences:get 'drracket:toolbar-state)) 2020 'left))) 2021 (define/private (toolbar-is-top-no-label?) 2022 (and (not (toolbar-is-hidden?)) 2023 (equal? (cdr (preferences:get 'drracket:toolbar-state)) 2024 'top-no-label))) 2025 2026 (define/private (orient/show bar-at-beginning?) 2027 (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) 2028 (begin-container-sequence) 2029 (show-info) 2030 2031 ;; orient the button panel and all panels inside it. 2032 (let loop ([obj button-panel]) 2033 (when (is-a? obj area-container<%>) 2034 (when (or (is-a? obj vertical-panel%) 2035 (is-a? obj horizontal-panel%) 2036 (is-a? obj panel:discrete-sizes<%>)) 2037 (unless (equal? (send obj get-orientation) (not vertical?)) 2038 (send obj set-orientation (not vertical?)))) 2039 (for-each loop (send obj get-children)))) 2040 (sort-toolbar-buttons-panel) 2041 2042 (set-toolbar-label-visibilities/check-registered) 2043 2044 (send top-outer-panel stretchable-height vertical?) 2045 (send top-outer-panel stretchable-width (not vertical?)) 2046 (send top-panel set-orientation (not vertical?)) 2047 (send toolbar/rest-panel set-orientation vertical?) 2048 (send toolbar/rest-panel change-children 2049 (λ (l) 2050 (if bar-at-beginning? 2051 (cons top-outer-panel (remq top-outer-panel l)) 2052 (append (remq top-outer-panel l) (list top-outer-panel))))) 2053 (send top-outer-panel change-children (λ (l) (list top-panel))) 2054 (send transcript-parent-panel change-children (λ (l) (list transcript-panel))) 2055 2056 (let* ([settings (send definitions-text get-next-settings)] 2057 [language (drracket:language-configuration:language-settings-language settings)] 2058 [name (get-define-popup-name 2059 (get-define-popup-info 2060 (send language capability-value 'drscheme:define-popup)) 2061 vertical?)]) 2062 (when name 2063 (send func-defs-canvas set-message #f name))) 2064 (send name-message set-short-title vertical?) 2065 (send name-panel set-orientation (not vertical?)) 2066 (if vertical? 2067 (send name-panel set-alignment 'right 'top) 2068 (send name-panel set-alignment 'left 'center)) 2069 (end-container-sequence))) 2070 2071 ;; this table uses object identity on buttons(!) 2072 (define toolbar-buttons (make-hasheq)) 2073 (define smallest #f) 2074 2075 (define/public (register-toolbar-button b #:number [number/f #f]) 2076 (add-to-toolbar-buttons 'register-toolbar-button b number/f) 2077 (set-toolbar-label-visibilities/check-registered) 2078 (sort-toolbar-buttons-panel)) 2079 2080 (define/public (register-toolbar-buttons bs #:numbers [numbers/fs (make-list (length bs) #f)]) 2081 (for ([b (in-list bs)] 2082 [n (in-list numbers/fs)]) 2083 (add-to-toolbar-buttons 'register-toolbar-buttons b n)) 2084 (set-toolbar-label-visibilities/check-registered) 2085 (sort-toolbar-buttons-panel)) 2086 2087 (define/private (add-to-toolbar-buttons who button number/f) 2088 (define number (or number/f (if smallest (- smallest 1) 100))) 2089 (define prev (hash-ref toolbar-buttons button #f)) 2090 (when (and prev (not (= prev number))) 2091 (error who "cannot add toolbar button ~s with number ~a; already added with ~a" 2092 (send button get-label) 2093 number 2094 prev)) 2095 (when (or (not smallest) (< number smallest)) 2096 (set! smallest number)) 2097 (hash-set! toolbar-buttons button number)) 2098 2099 (define/private (in-toolbar-list? b) (hash-ref toolbar-buttons b #f)) 2100 2101 (define/public (unregister-toolbar-button b) 2102 (hash-remove! toolbar-buttons b) 2103 (set! smallest 2104 (if (zero? (hash-count toolbar-buttons)) 2105 #f 2106 (apply min (hash-map toolbar-buttons (λ (x y) y))))) 2107 (void)) 2108 2109 (define/public (sort-toolbar-buttons-panel) 2110 (define bp (get-button-panel)) 2111 (define (cmp panel) 2112 (cond 2113 [(is-a? panel vertical-pane%) >=] 2114 [(is-a? panel horizontal-pane%) <=] 2115 [else 2116 (if (send panel get-orientation) ;; horizontal is #t 2117 <= 2118 >=)])) 2119 (when (is-a? bp panel%) 2120 (let sort-loop ([panel bp]) 2121 (define min #f) 2122 (send panel change-children 2123 (λ (l) 2124 (define sub-panel-nums (make-hash)) 2125 (for ([x (in-list l)]) 2126 (when (is-a? x area-container<%>) 2127 (define rec-res (sort-loop x)) 2128 (when rec-res 2129 (hash-set! sub-panel-nums x rec-res)))) 2130 (define (key item) 2131 (define missing-num -5000) 2132 (cond 2133 [(is-a? item area-container<%>) 2134 (hash-ref sub-panel-nums item missing-num)] 2135 [else 2136 (hash-ref toolbar-buttons item missing-num)])) 2137 (define ans (sort l (cmp panel) #:key key)) 2138 (set! min (if (null? ans) 2139 #f 2140 (key (car ans)))) 2141 ans)) 2142 min) 2143 (void))) 2144 2145 (define/private (set-toolbar-label-visibilities/check-registered) 2146 (define label-visible? (toolbar-is-top?)) 2147 (for ([(button number) (in-hash toolbar-buttons)]) 2148 (send button set-label-visible label-visible?)) 2149 2150 (let loop ([obj button-panel]) 2151 (cond 2152 [(is-a? obj area-container<%>) 2153 (for-each loop (send obj get-children))] 2154 [(is-a? obj switchable-button%) 2155 (unless (in-toolbar-list? obj) 2156 (error 'register-toolbar-button 2157 "found a switchable-button% that is not registered, label ~s" 2158 (send obj get-label)))] 2159 [else (void)]))) 2160 2161 (field [remove-show-status-line-callback 2162 (preferences:add-callback 2163 'framework:show-status-line 2164 (λ (p v) 2165 (update-defs/ints-resize-corner/pref v)))]) 2166 2167 (define/private (update-defs/ints-resize-corner) 2168 (update-defs/ints-resize-corner/pref 2169 (preferences:get 'framework:show-status-line))) 2170 2171 (define/private (update-defs/ints-resize-corner/pref si-pref) 2172 (let ([bottom-material? (and (not (car toolbar-state)) 2173 si-pref)]) 2174 (let loop ([cs definitions-canvases]) 2175 (cond 2176 [(null? cs) (void)] 2177 [(null? (cdr cs)) 2178 (send (car cs) set-resize-corner (and (not bottom-material?) 2179 (not interactions-shown?)))] 2180 [else 2181 (send (car cs) set-resize-corner #f) 2182 (loop (cdr cs))])) 2183 (let loop ([cs interactions-canvases]) 2184 (cond 2185 [(null? cs) (void)] 2186 [(null? (cdr cs)) 2187 (send (car cs) set-resize-corner (and (not bottom-material?) 2188 interactions-shown?))] 2189 [else 2190 (send (car cs) set-resize-corner #f) 2191 (loop (cdr cs))])))) 2192 2193 [define definitions-item #f] 2194 [define interactions-item #f] 2195 [define name-message #f] 2196 [define save-button #f] 2197 [define save-init-shown? #f] 2198 2199 [define/private set-save-init-shown? (λ (x) (set! save-init-shown? x))] 2200 2201 [define canvas-show-mode #f] 2202 [define allow-split? #f] 2203 [define forced-quit? #f] 2204 [define search-canvas #f] 2205 2206 (define/public (make-searchable canvas) 2207 (update-info) 2208 (set! search-canvas canvas)) 2209 2210 (define was-locked? #f) 2211 2212 (define/public-final (disable-evaluation-in-tab tab) 2213 (when (eq? tab current-tab) 2214 (disable-evaluation))) 2215 2216 (define/pubment (disable-evaluation) 2217 (when execute-menu-item 2218 (send execute-menu-item enable #f)) 2219 (send execute-button enable #f) 2220 (inner (void) disable-evaluation)) 2221 2222 (define/public-final (enable-evaluation-in-tab tab) 2223 (when (eq? tab current-tab) 2224 (enable-evaluation))) 2225 2226 (define/pubment (enable-evaluation) 2227 (when execute-menu-item 2228 (send execute-menu-item enable #t)) 2229 (send execute-button enable #t) 2230 (inner (void) enable-evaluation)) 2231 2232 (inherit set-label) 2233 (inherit modified) 2234 (define/public (update-save-button) 2235 (let ([mod? (send definitions-text is-modified?)]) 2236 (modified mod?) 2237 (if save-button 2238 (unless (equal? mod? (send save-button is-shown?)) 2239 (send save-button show mod?)) 2240 (set! save-init-shown? mod?)) 2241 (update-tab-label current-tab))) 2242 2243 (define/public (language-changed) 2244 (define settings (send definitions-text get-next-settings)) 2245 (define language (drracket:language-configuration:language-settings-language settings)) 2246 (send func-defs-canvas language-changed language (or (toolbar-is-left?) 2247 (toolbar-is-right?))) 2248 (send language-message set-yellow/lang 2249 (not (send definitions-text this-and-next-language-the-same?)) 2250 (string-append (send language get-language-name) 2251 (if (send language default-settings? 2252 (drracket:language-configuration:language-settings-settings 2253 settings)) 2254 "" 2255 (string-append " " (string-constant custom))) 2256 " ")) 2257 (update-teachpack-menu) 2258 (when (is-a? language-specific-menu menu%) 2259 (define label (send language-specific-menu get-label)) 2260 (define new-label (send language capability-value 'drscheme:language-menu-title)) 2261 (unless (equal? label new-label) 2262 (send language-specific-menu set-label new-label)))) 2263 2264 (define/public (get-language-menu) language-specific-menu) 2265 2266 ;; update-save-message : -> void 2267 ;; sets the save message. If input is #f, uses the frame's 2268 ;; title. 2269 (define/public (update-save-message) 2270 (when name-message 2271 (let ([filename (send definitions-text get-filename)]) 2272 (send name-message set-message 2273 (if filename #t #f) 2274 (send definitions-text get-filename/untitled-name)))) 2275 (update-tabs-labels)) 2276 2277 (define/private (update-tabs-labels) 2278 (for-each (λ (tab) (update-tab-label tab)) tabs) 2279 (send tabs-panel set-selection (send current-tab get-i)) 2280 (send (send tabs-panel get-parent) 2281 change-children 2282 (λ (l) 2283 (cond 2284 [(= (send tabs-panel get-number) 1) 2285 (remq tabs-panel l)] 2286 [else 2287 (if (memq tabs-panel l) 2288 l 2289 (cons tabs-panel l))])))) 2290 2291 (define/private (update-tab-label tab) 2292 (let ([label (gui-utils:trim-string (get-defs-tab-label (send tab get-defs) tab) 200)]) 2293 (unless (equal? label (send tabs-panel get-item-label (send tab get-i))) 2294 (send tabs-panel set-item-label (send tab get-i) label)))) 2295 2296 ;; get-tab-filename : (or/c (is-a?/c tab<%>) natural?) -> string? [the tab's label] 2297 (define/public (get-tab-filename _tab) 2298 (define tab 2299 (cond 2300 [(exact-nonnegative-integer? _tab) (list-ref tabs _tab)] 2301 [else _tab])) 2302 (get-defs-tab-filename (send tab get-defs))) 2303 2304 (define/private (get-defs-tab-label defs tab) 2305 (define tab-index 2306 (for/or ([i (in-list tabs)] 2307 [n (in-naturals 1)]) 2308 (and (eq? i tab) n))) 2309 (define i-prefix 2310 (cond 2311 [(not tab-index) ""] 2312 [(<= tab-index 8) (format "~a: " tab-index)] 2313 [(= tab-index (get-tab-count)) "9: "] 2314 [else ""])) 2315 (add-modified-flag 2316 defs 2317 (string-append 2318 i-prefix 2319 (get-defs-tab-filename defs)))) 2320 2321 (define/private (get-defs-tab-filename defs) 2322 (let ([fn (send defs get-filename)]) 2323 (if fn 2324 (get-tab-label-from-filename fn) 2325 (send defs get-filename/untitled-name)))) 2326 2327 ;; tab-label-cache-valid : (listof path) 2328 ;; If the current set of filenames in the tabs is the 2329 ;; same set of filenames as in this list, then the 2330 ;; tab-label-cache is valid; otherwise not 2331 (define tab-label-cache-valid '()) 2332 2333 ;; tab-label-cache : path -o> string 2334 (define tab-label-cache (make-hasheq)) 2335 2336 (define/private (get-tab-label-from-filename fn) 2337 (define current-paths (map (lambda (tab) (send (send tab get-defs) get-filename)) 2338 tabs)) 2339 (unless (and (= (length tab-label-cache-valid) (length current-paths)) 2340 (andmap eq? tab-label-cache-valid current-paths)) 2341 (set! tab-label-cache-valid current-paths) 2342 (set! tab-label-cache (make-hasheq))) 2343 (define nfn (simple-form-path fn)) 2344 (hash-ref! tab-label-cache 2345 fn 2346 (lambda () 2347 (path->string 2348 (or (shrink-path-wrt 2349 nfn 2350 (filter values 2351 (for/list ([other-tab (in-list tabs)]) 2352 (define fn (send (send other-tab get-defs) get-filename)) 2353 (and fn (simple-form-path fn))))) 2354 (let-values ([(base name dir?) (split-path nfn)]) 2355 name)))))) 2356 2357 (define/private (add-modified-flag text string) 2358 (if (send text is-modified?) 2359 (let ([prefix (get-save-diamond-prefix)]) 2360 (if prefix 2361 (string-append prefix string) 2362 string)) 2363 string)) 2364 2365 (define/private (get-save-diamond-prefix) 2366 (let ([candidate-prefixes 2367 ;; be sure asterisk is at the end of each list, 2368 ;; since that's a relatively safe character 2369 (case (system-type) 2370 [(unix windows) '("★ " "◆ " "• " "* ")] 2371 [else '("◆ " "★ " "• " "* ")])]) 2372 (ormap 2373 (lambda (candidate) 2374 (and (andmap (λ (x) (send normal-control-font screen-glyph-exists? x #t)) 2375 (string->list candidate)) 2376 candidate)) 2377 candidate-prefixes))) 2378 2379 [define/override get-canvas% (λ () (drracket:get/extend:get-definitions-canvas))] 2380 2381 (define/public (update-running running?) 2382 (send running-canvas set-running running?)) 2383 (define/public (ensure-defs-shown) 2384 (unless definitions-shown? 2385 (toggle-show/hide-definitions) 2386 (update-shown))) 2387 (define/public (ensure-rep-shown rep) 2388 (unless (is-a? rep drracket:rep:text<%>) 2389 (raise-argument-error 'ensure-rep-shown 2390 (format "~s" '(is-a?/c drracket:rep:text<%>)) 2391 rep)) 2392 (unless (eq? rep interactions-text) 2393 (let loop ([tabs tabs]) 2394 (unless (null? tabs) 2395 (let ([tab (car tabs)]) 2396 (if (eq? (send tab get-ints) rep) 2397 (change-to-tab tab) 2398 (loop (cdr tabs))))))) 2399 (unless interactions-shown? 2400 (toggle-show/hide-interactions) 2401 (update-shown))) 2402 (define/public (ensure-rep-hidden) 2403 (when interactions-shown? 2404 (toggle-show/hide-interactions) 2405 (update-shown))) 2406 2407 (define/override (get-editor%) (drracket:get/extend:get-definitions-text)) 2408 (define/public (still-untouched?) 2409 (and (send definitions-text still-untouched?) 2410 (let* ([prompt (send interactions-text get-prompt)] 2411 [first-prompt-para 2412 (let loop ([n 0]) 2413 (cond 2414 [(n . <= . (send interactions-text last-paragraph)) 2415 (if (string=? 2416 (send interactions-text get-text 2417 (send interactions-text paragraph-start-position n) 2418 (+ (send interactions-text paragraph-start-position n) 2419 (string-length prompt))) 2420 prompt) 2421 n 2422 (loop (+ n 1)))] 2423 [else #f]))]) 2424 (and first-prompt-para 2425 (= first-prompt-para (send interactions-text last-paragraph)) 2426 (equal? 2427 (send interactions-text get-text 2428 (send interactions-text paragraph-start-position first-prompt-para) 2429 (send interactions-text paragraph-end-position first-prompt-para)) 2430 (send interactions-text get-prompt)))))) 2431 (define/public (change-to-file name) 2432 (cond 2433 [(and name (file-exists? name)) 2434 (ensure-rep-hidden) 2435 (send definitions-text begin-edit-sequence #t #f) 2436 (send definitions-text load-file/gui-error name) 2437 (send definitions-text end-edit-sequence) 2438 (send language-message set-yellow #f)] 2439 [name 2440 (send definitions-text set-filename name)] 2441 [else (send definitions-text clear)]) 2442 (send definitions-canvas focus)) 2443 2444 2445 2446 2447 2448 2449 ; 2450 ; 2451 ; 2452 ; ; 2453 ; ; 2454 ; ; 2455 ; ; ;; ;; ;;; ;; ; ;;; ;;; 2456 ; ;; ;; ; ; ; ; ;; ; ; ; 2457 ; ; ; ; ; ; ; ; ; ; ;; 2458 ; ; ; ; ; ; ; ; ;;;;;; ;; 2459 ; ; ; ; ; ; ; ; ; ; 2460 ; ; ; ; ; ; ; ;; ; ; 2461 ; ; ; ; ;;; ;; ; ;;;; ;;; 2462 ; 2463 ; 2464 ; 2465 2466 2467 (define/private (add-modes-submenu edit-menu) 2468 (new menu% 2469 [parent edit-menu] 2470 [label (string-constant mode-submenu-label)] 2471 [demand-callback 2472 (λ (menu) 2473 (for ([item (in-list (send menu get-items))]) 2474 (send item delete)) 2475 (for ([mode (in-list (drracket:modes:get-modes))]) 2476 (define item 2477 (new checkable-menu-item% 2478 (label (drracket:modes:mode-name mode)) 2479 (parent menu) 2480 (callback 2481 (λ (_1 _2) (send definitions-text set-current-mode 2482 mode))))) 2483 (when (send definitions-text is-current-mode? mode) 2484 (send item check #t))))])) 2485 2486 2487 2488 2489 ; 2490 ; 2491 ; 2492 ; ; ; ; ; ; 2493 ; ; ; ; ; 2494 ; ; ; ; ; ; 2495 ; ;;; ; ;; ; ; ;;;; ; ;;; ;;; ; ; ;;; ; ;; ;;; ;;; 2496 ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; 2497 ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; 2498 ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ;; ;;;;;; 2499 ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 2500 ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; 2501 ; ;;; ; ;; ; ; ;; ; ;;; ;;; ; ; ;;;;; ; ;; ;;; ;;;; 2502 ; ; ; ; 2503 ; ; ; ; 2504 ; ; ; 2505 2506 2507 (inherit get-edit-target-window) 2508 2509 (define/public (split) 2510 (let ([canvas-to-be-split (get-edit-target-window)]) 2511 (cond 2512 [(memq canvas-to-be-split definitions-canvases) 2513 (split-definitions canvas-to-be-split)] 2514 [(memq canvas-to-be-split interactions-canvases) 2515 (split-interactions canvas-to-be-split)] 2516 [else (bell)]))) 2517 2518 (define/private (split-definitions canvas-to-be-split) 2519 (handle-split canvas-to-be-split 2520 (λ (x) (set! definitions-canvases x)) 2521 definitions-canvases 2522 (drracket:get/extend:get-definitions-canvas) 2523 definitions-text)) 2524 2525 (define/private (split-interactions canvas-to-be-split) 2526 (handle-split canvas-to-be-split 2527 (λ (x) (set! interactions-canvases x)) 2528 interactions-canvases 2529 (drracket:get/extend:get-interactions-canvas) 2530 interactions-text)) 2531 2532 (define/private (handle-split canvas-to-be-split set-canvases! canvases canvas% text) 2533 (let-values ([(ox oy ow oh cursor-y) 2534 (get-visible-region canvas-to-be-split)]) 2535 (let ([orig-percentages (send resizable-panel get-percentages)] 2536 [orig-canvases (send resizable-panel get-children)] 2537 [new-canvas (new canvas% 2538 (parent resizable-panel) 2539 (editor text) 2540 (style '()))]) 2541 2542 (set-canvases! 2543 (let loop ([canvases canvases]) 2544 (cond 2545 [(null? canvases) (error 'split "couldn't split; didn't find canvas")] 2546 [else 2547 (let ([canvas (car canvases)]) 2548 (if (eq? canvas canvas-to-be-split) 2549 (list* new-canvas 2550 canvas 2551 (cdr canvases)) 2552 (cons canvas (loop (cdr canvases)))))]))) 2553 2554 (update-shown) 2555 2556 ;; with-handlers prevents bad calls to set-percentages 2557 ;; might still leave GUI in bad state, however. 2558 (with-handlers ([exn:fail? (λ (x) (void))]) 2559 (send resizable-panel set-percentages 2560 (let loop ([canvases orig-canvases] 2561 [percentages orig-percentages]) 2562 (cond 2563 [(null? canvases) 2564 (error 'split "couldn't split; didn't find canvas")] 2565 [(null? percentages) 2566 (error 'split "wrong number of percentages: ~s ~s" 2567 orig-percentages 2568 (send resizable-panel get-children))] 2569 [else (let ([canvas (car canvases)]) 2570 (if (eq? canvas-to-be-split canvas) 2571 (list* (/ (car percentages) 2) 2572 (/ (car percentages) 2) 2573 (cdr percentages)) 2574 (cons 2575 (car percentages) 2576 (loop (cdr canvases) 2577 (cdr percentages)))))])))) 2578 2579 (set-visible-region new-canvas ox oy ow oh cursor-y) 2580 (set-visible-region canvas-to-be-split ox oy ow oh cursor-y) 2581 2582 (send new-canvas focus)))) 2583 2584 ;; split-demand : menu-item -> void 2585 ;; enables the menu-item if splitting is allowed, disables otherwise 2586 (define/private (split-demand item) 2587 (let ([canvas-to-be-split (get-edit-target-window)]) 2588 (send item enable 2589 (or (memq canvas-to-be-split definitions-canvases) 2590 (memq canvas-to-be-split interactions-canvases))))) 2591 2592 ;; collapse-demand : menu-item -> void 2593 ;; enables the menu-item if collapsing is allowed, disables otherwise 2594 (define/private (collapse-demand item) 2595 (let ([canvas-to-be-split (get-edit-target-window)]) 2596 (cond 2597 [(memq canvas-to-be-split definitions-canvases) 2598 (send item enable (2 . <= . (length definitions-canvases)))] 2599 [(memq canvas-to-be-split interactions-canvases) 2600 (send item enable (2 . <= . (length interactions-canvases)))] 2601 [else 2602 (send item enable #f)]))) 2603 2604 ;; get-visible-region : editor-canvas -> number number number number (union #f number) 2605 ;; calculates the visible region of the editor in this editor-canvas, returning 2606 ;; four numbers for the x, y, width and height of the visible region 2607 ;; also, the last two booleans indiciate if the beginning and the end 2608 ;; of the selection was visible before the split, respectively. 2609 (define/private (get-visible-region canvas) 2610 (send canvas call-as-primary-owner 2611 (λ () 2612 (let* ([text (send canvas get-editor)] 2613 [admin (send text get-admin)] 2614 [start (send text get-start-position)] 2615 [end (send text get-end-position)]) 2616 (let-values ([(x y w h) (get-visible-area admin)]) 2617 (let ([ysb (box 0)]) 2618 (send text position-location (send text get-start-position) #f ysb) 2619 (values x y w h 2620 (and (= start end) 2621 (<= y (unbox ysb) (+ y h)) 2622 (unbox ysb))))))))) 2623 2624 ;; set-visible-region : editor-canvas number number number number (union #f number) -> void 2625 ;; sets the visible region of the text displayed by the editor canvas 2626 ;; to be the middle of the region (vertically) specified by x, y, w, and h. 2627 ;; if start-visible? and/or end-visible? are true, some special handling 2628 ;; is done to try to keep the start and end visible, with precendence 2629 ;; given to start if both are #t. 2630 (define/private (set-visible-region canvas x y w h cursor-y) 2631 (send canvas call-as-primary-owner 2632 (λ () 2633 (let* ([text (send canvas get-editor)] 2634 [admin (send text get-admin)] 2635 [nwb (box 0)] 2636 [nhb (box 0)]) 2637 (send admin get-view #f #f nwb nhb) 2638 (let* ([nw (unbox nwb)] 2639 [nh (unbox nhb)] 2640 2641 [nx x] 2642 [raw-y (- (+ y (/ h 2)) (/ nh 2))] 2643 [ny (if (and cursor-y 2644 (not (<= raw-y cursor-y (+ raw-y nh)))) 2645 (- cursor-y (/ nh 2)) 2646 raw-y)]) 2647 (send canvas scroll-to nx ny nw nh #t) 2648 (void)))))) 2649 2650 ;; get-visible-area : admin -> number number number number 2651 ;; returns the visible area for this admin 2652 (define/private (get-visible-area admin) 2653 (let ([bx (box 0)] 2654 [by (box 0)] 2655 [bw (box 0)] 2656 [bh (box 0)]) 2657 (send admin get-view bx by bw bh) 2658 (values (unbox bx) 2659 (unbox by) 2660 (unbox bw) 2661 (unbox bh)))) 2662 2663 (define/public (collapse) 2664 (let* ([target (get-edit-target-window)]) 2665 (cond 2666 [(memq target definitions-canvases) 2667 (collapse-definitions target)] 2668 [(memq target interactions-canvases) 2669 (collapse-interactions target)] 2670 [else (bell)]))) 2671 2672 (define/private (collapse-definitions target) 2673 (handle-collapse 2674 target 2675 (λ () definitions-canvases) 2676 (λ (c) (set! definitions-canvases c)))) 2677 2678 (define/private (collapse-interactions target) 2679 (handle-collapse 2680 target 2681 (λ () interactions-canvases) 2682 (λ (c) (set! interactions-canvases c)))) 2683 2684 (define/private (handle-collapse target get-canvases set-canvases!) 2685 (cond 2686 [(= 1 (length (get-canvases))) (bell)] 2687 [else 2688 (define old-percentages (send resizable-panel get-percentages)) 2689 (define soon-to-be-bigger-canvas #f) 2690 (define percentages 2691 (cond 2692 [(and target (eq? (car (get-canvases)) target)) 2693 (set! soon-to-be-bigger-canvas (cadr (get-canvases))) 2694 (cons (+ (car old-percentages) 2695 (cadr old-percentages)) 2696 (cddr old-percentages))] 2697 [else 2698 (let loop ([canvases (cdr (get-canvases))] 2699 [prev-canvas (car (get-canvases))] 2700 [percentages (cdr old-percentages)] 2701 [prev-percentage (car old-percentages)]) 2702 (cond 2703 [(null? canvases) 2704 (error 'collapse "internal error.1")] 2705 [(null? percentages) 2706 (error 'collapse "internal error.2")] 2707 [else 2708 (cond 2709 [(and target (eq? (car canvases) target)) 2710 (set! soon-to-be-bigger-canvas prev-canvas) 2711 (cons (+ (car percentages) 2712 prev-percentage) 2713 (cdr percentages))] 2714 [else 2715 (cons prev-percentage 2716 (loop (cdr canvases) 2717 (car canvases) 2718 (cdr percentages) 2719 (car percentages)))])]))])) 2720 (unless soon-to-be-bigger-canvas 2721 (error 'collapse "internal error.3")) 2722 (set-canvases! (remq target (get-canvases))) 2723 (update-shown) 2724 2725 (define target-admin 2726 (send target call-as-primary-owner 2727 (λ () 2728 (send (send target get-editor) get-admin)))) 2729 (define to-be-bigger-admin 2730 (send soon-to-be-bigger-canvas call-as-primary-owner 2731 (λ () 2732 (send (send soon-to-be-bigger-canvas get-editor) get-admin)))) 2733 (define-values (bx by bw bh) (get-visible-area to-be-bigger-admin)) 2734 2735 ;; this line makes the soon-to-be-bigger-canvas bigger 2736 ;; if it fails, we're out of luck, but at least we don't crash. 2737 (with-handlers ([exn:fail? (λ (x) (void))]) 2738 (send resizable-panel set-percentages percentages)) 2739 2740 (send soon-to-be-bigger-canvas scroll-to bx by bw bh #t) 2741 (send target set-editor #f) 2742 (send soon-to-be-bigger-canvas focus)])) 2743 ; 2744 ; 2745 ; 2746 ; ; 2747 ; ; 2748 ; ; 2749 ; ;;; ; ;; ;;; ; ; ; ; ;; ;; ;;; ; ;; ; ; 2750 ; ; ;; ; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; 2751 ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 2752 ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; 2753 ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 2754 ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; 2755 ; ;;; ; ; ;;; ; ; ; ; ; ;;;; ; ; ;; ; 2756 ; 2757 ; 2758 ; 2759 2760 2761 (define interactions-shown? #t) 2762 (define definitions-shown? #t) 2763 2764 (define/private (toggle-show/hide-definitions) 2765 (set! definitions-shown? (not definitions-shown?)) 2766 (unless definitions-shown? 2767 (set! interactions-shown? #t))) 2768 (define/private (toggle-show/hide-interactions) 2769 (set! interactions-shown? (not interactions-shown?)) 2770 (unless interactions-shown? 2771 (set! definitions-shown? #t))) 2772 2773 (define (immediate-children parent children) 2774 (define (immediate child) 2775 (let loop ([child child]) 2776 (define immediate-parent (send child get-parent)) 2777 (if (and immediate-parent 2778 (eq? immediate-parent parent)) 2779 child 2780 (loop immediate-parent)))) 2781 (for/list ([child children]) 2782 (immediate child))) 2783 2784 (define/override (update-shown) 2785 (super update-shown) 2786 (let ([new-children 2787 (foldl 2788 (λ (shown? children sofar) 2789 (if shown? 2790 (append children sofar) 2791 sofar)) 2792 null 2793 (list interactions-shown? 2794 definitions-shown?) 2795 (list interactions-canvases 2796 definitions-canvases))] 2797 [old-children (send resizable-panel get-children)] 2798 [p (preferences:get 'drracket:unit-window-size-percentage)]) 2799 (update-defs/ints-resize-corner) 2800 (send definitions-item set-label 2801 (if definitions-shown? 2802 (string-constant hide-definitions-menu-item-label) 2803 (string-constant show-definitions-menu-item-label))) 2804 (send interactions-item set-label 2805 (if interactions-shown? 2806 (string-constant hide-interactions-menu-item-label) 2807 (string-constant show-interactions-menu-item-label))) 2808 (send resizable-panel begin-container-sequence) 2809 2810 ;; this might change the unit-window-size-percentage, so save/restore it 2811 (send resizable-panel change-children 2812 (λ (old) 2813 (immediate-children resizable-panel new-children))) 2814 2815 (preferences:set 'drracket:unit-window-size-percentage p) 2816 ;; restore preferred interactions/definitions sizes 2817 (when (and (= 1 (length definitions-canvases)) 2818 (= 1 (length interactions-canvases)) 2819 (= 2 (length new-children))) 2820 (with-handlers ([exn:fail? (λ (x) (void))]) 2821 (send resizable-panel set-percentages 2822 (list p (- 1 p))))) 2823 2824 (send resizable-panel end-container-sequence) 2825 (when (ormap (λ (child) 2826 (and (is-a? child editor-canvas%) 2827 (not (send child has-focus?)))) 2828 (send resizable-panel get-children)) 2829 (let ([new-focus 2830 (let loop ([children (send resizable-panel get-children)]) 2831 (cond 2832 [(null? children) (void)] 2833 [else (let ([child (car children)]) 2834 (if (is-a? child editor-canvas%) 2835 child 2836 (loop (cdr children))))]))] 2837 [old-focus 2838 (ormap (λ (x) (and (is-a? x editor-canvas%) (send x has-focus?) x)) 2839 old-children)]) 2840 2841 ;; conservatively, only scroll when the focus stays in the same place. 2842 (when old-focus 2843 (when (eq? old-focus new-focus) 2844 (let ([ed (send old-focus get-editor)]) 2845 (when ed 2846 (send ed scroll-to-position 2847 (send ed get-start-position) 2848 #f 2849 (send ed get-end-position)))))) 2850 2851 (send new-focus focus))) 2852 2853 (for-each 2854 (λ (get-item) 2855 (let ([item (get-item)]) 2856 (when item 2857 (send item enable definitions-shown?)))) 2858 (list (λ () (file-menu:get-revert-item)) 2859 (λ () (file-menu:get-save-item)) 2860 (λ () (file-menu:get-save-as-item)) 2861 ;(λ () (file-menu:save-as-text-item)) ; Save As Text... 2862 (λ () (file-menu:get-print-item)))) 2863 (send file-menu:print-interactions-item enable interactions-shown?))) 2864 2865 (define/augment (can-close?) 2866 (and (andmap (lambda (tab) 2867 (or (eq? tab current-tab) 2868 (and (send (send tab get-defs) can-close?) 2869 (send (send tab get-ints) can-close?)))) 2870 tabs) 2871 (send interactions-text can-close?) 2872 (inner #t can-close?))) 2873 (define/augment (on-close) 2874 (inner (void) on-close) 2875 (for-each (lambda (tab) 2876 (unless (eq? tab current-tab) 2877 (send (send tab get-defs) on-close) 2878 (send (send tab get-ints) on-close))) 2879 tabs) 2880 (when (eq? this newest-frame) 2881 (set! newest-frame #f)) 2882 (when transcript 2883 (stop-transcript)) 2884 (remove-show-status-line-callback) 2885 (remove-bug-icon-callback) 2886 (send interactions-text on-close)) 2887 2888 ;; execute-callback : -> void 2889 ;; uses the state of the button to determine if an execution is 2890 ;; already running. This function is called from many places, not 2891 ;; just the execute button. 2892 (define/public (execute-callback) 2893 (when (send execute-button is-enabled?) 2894 (when (check-if-unsaved-tabs-and-maybe-save) 2895 2896 ;; if the language is not-a-language, and the buffer looks like a module, 2897 ;; automatically make the switch to the module language 2898 (let ([next-settings (send definitions-text get-next-settings)]) 2899 (when (is-a? (drracket:language-configuration:language-settings-language next-settings) 2900 drracket:language-configuration:not-a-language-language<%>) 2901 (when (looks-like-module? definitions-text) 2902 (define-values (module-language module-language-settings) 2903 (get-module-language/settings)) 2904 (when (and module-language module-language-settings) 2905 (send definitions-text set-next-settings 2906 (drracket:language-configuration:language-settings 2907 module-language 2908 module-language-settings)))))) 2909 2910 (check-if-save-file-up-to-date) 2911 (when (preferences:get 'drracket:show-interactions-on-execute) 2912 (ensure-rep-shown interactions-text)) 2913 (when transcript 2914 (record-definitions) 2915 (record-interactions)) 2916 (send definitions-text just-executed) 2917 (send language-message set-yellow #f) 2918 (send interactions-canvas focus) 2919 (send interactions-text reset-console) 2920 (send interactions-text clear-undos) 2921 2922 (define name (send definitions-text get-port-name)) 2923 (define defs-copy (new text%)) 2924 ;; speeds up the copy 2925 (send defs-copy set-style-list (send definitions-text get-style-list)) 2926 (send definitions-text copy-self-to defs-copy) 2927 (define text-port (open-input-text-editor defs-copy 0 'end values name #t)) 2928 (port-count-lines! text-port) 2929 (send interactions-text evaluate-from-port 2930 text-port 2931 #t 2932 (λ () 2933 (parameterize ([current-eventspace drracket:init:system-eventspace]) 2934 (queue-callback 2935 (λ () 2936 (send interactions-text clear-undos))))))))) 2937 2938 (inherit revert save) 2939 (define/private (check-if-save-file-up-to-date) 2940 (when (send definitions-text save-file-out-of-date?) 2941 (let ([user-choice 2942 (message-box/custom 2943 (string-constant drscheme) 2944 (string-constant definitions-modified) 2945 (string-constant ignore) 2946 (string-constant revert) 2947 #f 2948 this 2949 '(caution default=2 number-order) 2950 1 2951 #:dialog-mixin frame:focus-table-mixin)]) 2952 (case user-choice 2953 [(1) (void)] 2954 [(2) (revert)])))) 2955 2956 ;; returns #f if we should abort `Run`, #t if it is okay to `Run` 2957 (define/private (check-if-unsaved-tabs-and-maybe-save) 2958 (cond 2959 [(preferences:get 'drracket:dont-ask-about-saving-files-on-tab-switch?) #t] 2960 [else 2961 (define save-candidates (get-unsaved-candidate-tabs #t)) 2962 (cond 2963 [(null? save-candidates) #t] 2964 [else 2965 (define-values (cancel-run? do-save?) 2966 (does-user-want-to-save-all-unsaved-files? save-candidates)) 2967 (cond 2968 [cancel-run? #f] 2969 [do-save? 2970 (define continue? 2971 (let/ec k 2972 (for ([tab (in-list save-candidates)]) 2973 (unless (send (send tab get-defs) save-file/gui-error) 2974 (k #f))) 2975 #t)) 2976 (update-tabs-labels) 2977 continue?] 2978 [else #t])])])) 2979 2980 (define/private (save-all-unsaved-files) 2981 (let/ec k 2982 (for ([tab (in-list (get-unsaved-candidate-tabs #f))]) 2983 (parameterize ([editor:silent-cancel-on-save-file-out-of-date? #t]) 2984 (unless (send (send tab get-defs) save-file #f 'same #f) 2985 (k (void)))))) 2986 (update-tabs-labels)) 2987 2988 (define/private (get-unsaved-candidate-tabs skip-me?) 2989 (define focused-frame (or (get-top-level-focus-window) 2990 (let ([ft (frame:lookup-focus-table (get-eventspace))]) 2991 (and (pair? ft) (car ft))))) 2992 (for*/list ([frame (in-list (send (group:get-the-frame-group) get-frames))] 2993 #:when (is-a? frame drracket:unit:frame<%>) 2994 [tab (in-list (send frame get-tabs))] 2995 #:unless (and skip-me? 2996 (eq? focused-frame frame) 2997 (eq? current-tab tab)) 2998 #:when (let ([defs (send tab get-defs)]) 2999 (and (send defs is-modified?) 3000 (send defs get-filename)))) 3001 tab)) 3002 3003 (define/private (does-user-want-to-save-all-unsaved-files? save-candidates) 3004 (define-values (message-box-result checked?) 3005 (message+check-box/custom 3006 (string-constant drracket) 3007 (if (= (length save-candidates) 1) 3008 (format (string-constant one-file-not-saved-do-the-save?) 3009 (get-tab-filename (car save-candidates))) 3010 (apply 3011 string-append 3012 (string-constant many-files-not-saved-do-the-save?) 3013 (for/list ([tab (in-list save-candidates)]) 3014 (~a "\n" (get-tab-filename tab))))) 3015 (string-constant save-after-switching-tabs) 3016 (string-constant save-all-files) 3017 (string-constant dont-save) 3018 #f 3019 this ; parent 3020 (append 3021 (if (preferences:get 'drracket:save-files-on-tab-switch?) 3022 '(checked) 3023 '()) 3024 '(default=1)))) 3025 (preferences:set 'drracket:save-files-on-tab-switch? checked?) 3026 (case message-box-result 3027 [(1) (values #f #t)] ;; clicked save-all -> save (and run) 3028 [(2) (values #f #f)] ;; clicked dont-save -> don't save, but still run 3029 [(#f) (values #t #f)])) ;; closed the dialog (with esc) -> cancel 3030 3031 (inherit get-menu-bar get-focus-object get-edit-target-object) 3032 3033 (define/override (get-editor) definitions-text) 3034 (define/override (get-canvas) 3035 (initialize-definitions-canvas) 3036 definitions-canvas) 3037 3038 (define (create-definitions-canvas) 3039 (new (drracket:get/extend:get-definitions-canvas) 3040 [parent resizable-panel] 3041 [editor definitions-text])) 3042 3043 (define/private (initialize-definitions-canvas) 3044 (unless definitions-canvas 3045 (set! definitions-canvas (create-definitions-canvas)))) 3046 3047 ;; wire the definitions text to the interactions text and initialize it. 3048 (define/private (init-definitions-text tab) 3049 (let ([defs (send tab get-defs)] 3050 [ints (send tab get-ints)]) 3051 (send defs set-interactions-text ints) 3052 (send defs set-tab tab) 3053 (send ints set-definitions-text defs) 3054 (send defs change-mode-to-match) 3055 (send defs insert-auto-text))) 3056 3057 3058 ; 3059 ; 3060 ; @@ 3061 ; @ @ 3062 ; @@@@@ $@$: @-@$ :@@+@ 3063 ; @ -@ @+ *$ @$ -@ 3064 ; @ -$@$@ @ @ :@@$- 3065 ; @ $* @ @ @ *@ 3066 ; @: :$ @- *@ @ +$ @ :@ 3067 ; :@@$- -$$-@@@@+@$ $+@@: 3068 ; 3069 ; 3070 ; 3071 ; 3072 3073 (define/public (get-current-tab) current-tab) 3074 3075 ;; create-new-tab : -> void 3076 ;; creates a new tab and updates the GUI for that new tab 3077 (define/public create-new-tab 3078 (lambda ([filename #f]) 3079 (let* ([defs (new (drracket:get/extend:get-definitions-text))] 3080 [tab-count (length tabs)] 3081 [new-tab (new (drracket:get/extend:get-tab) 3082 (defs defs) 3083 (i tab-count) 3084 (frame this) 3085 (defs-shown? #t) 3086 (ints-shown? (not filename)))] 3087 [ints (make-object (drracket:get/extend:get-interactions-text) new-tab)]) 3088 (send new-tab set-ints ints) 3089 (set! tabs (append tabs (list new-tab))) 3090 (send tabs-panel append 3091 (gui-utils:trim-string 3092 (if filename 3093 (get-tab-label-from-filename filename) 3094 (get-defs-tab-label defs #f)) 3095 200)) 3096 (init-definitions-text new-tab) 3097 (when filename (send defs load-file filename)) 3098 (send defs enable-top-level-window-connection) 3099 (change-to-nth-tab (- (send tabs-panel get-number) 1)) 3100 (send ints initialize-console) 3101 (send tabs-panel set-selection (- (send tabs-panel get-number) 1)) 3102 (set! newest-frame this) 3103 (update-menu-bindings)))) 3104 3105 ;; change-to-tab : tab -> void 3106 ;; updates current-tab, definitions-text, and interactactions-text 3107 ;; to be the nth tab. Also updates the GUI to show the new tab 3108 (inherit begin-container-sequence end-container-sequence) 3109 (define/public (change-to-tab tab) 3110 (unless (eq? current-tab tab) 3111 (let ([old-tab current-tab]) 3112 (save-visible-tab-regions) 3113 (set! current-tab tab) 3114 (set! definitions-text (send current-tab get-defs)) 3115 (set! interactions-text (send current-tab get-ints)) 3116 3117 (begin-container-sequence) 3118 (send definitions-text begin-edit-sequence #t #f) 3119 (send interactions-text begin-edit-sequence #t #f) 3120 (for-each (λ (defs-canvas) (send defs-canvas set-editor definitions-text #f)) 3121 definitions-canvases) 3122 (for-each (λ (ints-canvas) (send ints-canvas set-editor interactions-text #f)) 3123 interactions-canvases) 3124 3125 (update-save-message) 3126 (update-save-button) 3127 (language-changed) 3128 3129 (send definitions-text update-frame-filename) 3130 (update-running (send current-tab is-running?)) 3131 (when (let ([tlw (get-top-level-focus-window)]) 3132 (and tlw (eq? this tlw))) 3133 (send current-tab touched)) 3134 (on-tab-change old-tab current-tab) 3135 (send tab update-log) 3136 (send tab update-planet-status) 3137 (send tab update-execute-warning-gui) 3138 3139 (send old-tab set-panel-percentages-and-orientation 3140 (send resizable-panel get-percentages) 3141 (not (send resizable-panel get-vertical?))) 3142 (restore-visible-tab-regions) 3143 (define-values (panel-percentages panel-orientation) 3144 (send tab get-panel-percentages-and-orientation)) 3145 (when panel-percentages 3146 (send resizable-panel set-percentages panel-percentages) 3147 (send resizable-panel set-orientation panel-orientation)) 3148 3149 (for-each (λ (defs-canvas) (send defs-canvas refresh)) 3150 definitions-canvases) 3151 (for-each (λ (ints-canvas) (send ints-canvas refresh)) 3152 interactions-canvases) 3153 (set-color-status! (send definitions-text is-lexer-valid?)) 3154 3155 (when (preferences:get 'drracket:save-files-on-tab-switch?) 3156 (save-all-unsaved-files)) 3157 (send definitions-text end-edit-sequence) 3158 (send interactions-text end-edit-sequence) 3159 (end-container-sequence) 3160 3161 (case (send current-tab get-focus-d/i) 3162 [(defs) 3163 (send (car definitions-canvases) focus) 3164 (set-text-to-search (send (car definitions-canvases) get-editor))] 3165 [(ints) 3166 (send (car interactions-canvases) focus) 3167 (set-text-to-search (send (car interactions-canvases) get-editor))])))) 3168 3169 (define/pubment (on-tab-change from-tab to-tab) 3170 (let ([old-enabled (send from-tab get-enabled)] 3171 [new-enabled (send to-tab get-enabled)]) 3172 (unless (eq? old-enabled new-enabled) 3173 (if new-enabled 3174 (enable-evaluation) 3175 (disable-evaluation)))) 3176 3177 (inner (void) on-tab-change from-tab to-tab)) 3178 3179 (define/public (next-tab) (change-to-delta-tab +1)) 3180 (define/public (prev-tab) (change-to-delta-tab -1)) 3181 3182 (define/private (change-to-delta-tab dt) 3183 (change-to-nth-tab (modulo (+ (send current-tab get-i) dt) (length tabs)))) 3184 3185 ;; Re-orders the tabs according to the specified order 3186 (define/public (reorder-tabs tab-order) 3187 (unless (and 3188 ((listof exact-nonnegative-integer?) tab-order) 3189 (equal? (sort tab-order <) 3190 (range (length tabs)))) 3191 (raise-argument-error 'reorder-tabs 3192 "list of unique integers from 0 to n where n is the current number of tabs" 3193 tab-order)) 3194 (begin-container-sequence) 3195 (define-values (new-tabs-rev new-labels-rev) 3196 (for/fold ([new-tabs '()] 3197 [new-labels '()]) 3198 ([new-i (in-naturals)] 3199 [old-i tab-order]) 3200 (define t (list-ref tabs old-i)) 3201 (send t set-i new-i) 3202 (values (cons t new-tabs) 3203 (cons (send tabs-panel get-item-label old-i) 3204 new-labels)))) 3205 (set! tabs (reverse new-tabs-rev)) 3206 (send tabs-panel set (reverse new-labels-rev)) 3207 (send tabs-panel set-selection (send current-tab get-i)) 3208 (end-container-sequence) 3209 (update-menu-bindings) 3210 (update-tabs-labels)) 3211 3212 ;; Swaps the current tab with its right-hand neighbor 3213 (define/public (move-current-tab-right) 3214 (define i (send current-tab get-i)) 3215 (unless (= i (- (length tabs) 1)) 3216 (reorder-tabs 3217 (append (range i) 3218 (list (+ i 1) i) 3219 (range (+ i 2) (length tabs)))))) 3220 3221 ;; Swaps the current tab with its left-hand neighbor 3222 (define/public (move-current-tab-left) 3223 (define i (send current-tab get-i)) 3224 (unless (= i 0) 3225 (reorder-tabs 3226 (append (range (- i 1)) 3227 (list i (- i 1)) 3228 (range (+ i 1) (length tabs)))))) 3229 3230 (define/public-final (close-current-tab) 3231 (close-given-tab current-tab)) 3232 3233 (define/public-final (close-ith-tab i) 3234 (when (< i (length tabs)) 3235 (close-given-tab (list-ref tabs i)))) 3236 3237 (define/public-final (close-given-tab tab-to-close) 3238 (define subsequent-tabs 3239 (let loop ([l-tabs tabs]) 3240 (cond 3241 [(null? l-tabs) #f] 3242 [(eq? (car l-tabs) tab-to-close) (cdr l-tabs)] 3243 [else (loop (cdr l-tabs))]))) 3244 ;; make sure we have at least 2 tabs and the tab we're closing exists 3245 (when (and subsequent-tabs (pair? (cdr tabs))) 3246 (when (close-tab tab-to-close) 3247 (for ([tab (in-list subsequent-tabs)]) 3248 (send tab set-i (- (send tab get-i) 1))) 3249 (set! tabs (remq tab-to-close tabs)) 3250 (send tabs-panel delete (send tab-to-close get-i)) 3251 (update-menu-bindings) 3252 (cond 3253 [(eq? tab-to-close current-tab) 3254 (change-to-tab 3255 (argmax (λ (tab) (send tab get-last-touched)) 3256 tabs))] 3257 [else 3258 (update-tabs-labels)])))) 3259 3260 ;; a helper private method for close-current-tab -- doesn't close an arbitrary tab. 3261 (define/private (close-tab tab) 3262 (cond 3263 [(send tab can-close?) 3264 (send tab on-close) 3265 #t] 3266 [else #f])) 3267 3268 (define/public (open-in-new-tab filename) 3269 (create-new-tab filename)) 3270 3271 (define/public (get-tab-count) (length tabs)) 3272 (define/public (change-to-nth-tab n) 3273 (unless (< n (length tabs)) 3274 (error 'change-to-nth-tab "number too big ~s" n)) 3275 (change-to-tab (list-ref tabs n))) 3276 3277 (define/private (save-visible-tab-regions) 3278 (send current-tab set-visible-ints 3279 (get-tab-visible-regions interactions-text) 3280 interactions-shown?) 3281 (send current-tab set-visible-defs 3282 (get-tab-visible-regions definitions-text) 3283 definitions-shown?) 3284 (send current-tab set-focus-d/i 3285 (if (ormap (λ (x) (send x has-focus?)) interactions-canvases) 3286 'ints 3287 'defs))) 3288 3289 (define/private (get-tab-visible-regions txt) 3290 (map (λ (canvas) 3291 (let-values ([(x y w h _) (get-visible-region canvas)]) 3292 (list x y w h))) 3293 (send txt get-canvases))) 3294 3295 (inherit set-text-to-search reflow-container) 3296 (define/private (restore-visible-tab-regions) 3297 (define (fix-up-canvas-numbers txt regions ints?) 3298 (when regions 3299 (let* ([canvases (send txt get-canvases)] 3300 [canvases-count (length canvases)] 3301 [regions-count (length regions)]) 3302 (cond 3303 [(> canvases-count regions-count) 3304 (let loop ([i (- canvases-count regions-count)] 3305 [canvases canvases]) 3306 (unless (zero? i) 3307 (if ints? 3308 (collapse-interactions (car canvases)) 3309 (collapse-definitions (car canvases))) 3310 (loop (- i 1) 3311 (cdr canvases))))] 3312 [(= canvases-count regions-count) 3313 (void)] 3314 [(< canvases-count regions-count) 3315 (let loop ([i (- regions-count canvases-count)] 3316 [canvases canvases]) 3317 (unless (zero? i) 3318 (if ints? 3319 (split-interactions (car canvases)) 3320 (split-definitions (car canvases))) 3321 (loop (- i 1) 3322 (cdr canvases))))])))) 3323 3324 (define (set-visible-regions txt regions) 3325 (when regions 3326 (for-each (λ (canvas region) 3327 (set-visible-region canvas 3328 (first region) 3329 (second region) 3330 (third region) 3331 (fourth region) 3332 #f)) 3333 (send txt get-canvases) 3334 regions))) 3335 3336 (let-values ([(vi is?) (send current-tab get-visible-ints)] 3337 [(vd ds?) (send current-tab get-visible-defs)]) 3338 (set! interactions-shown? is?) 3339 (set! definitions-shown? ds?) 3340 (update-shown) 3341 (reflow-container) ;; without this one, the percentages in the 3342 ;; resizable-panel are not up to date with the children 3343 (when ds? (fix-up-canvas-numbers definitions-text vd #f)) 3344 (when is? (fix-up-canvas-numbers interactions-text vi #t)) 3345 (reflow-container) 3346 (when ds? (set-visible-regions definitions-text vd)) 3347 (when is? (set-visible-regions interactions-text vi)))) 3348 3349 (define/private (pathname-equal? p1 p2) 3350 (with-handlers ([exn:fail? (λ (x) #f)]) 3351 (string=? (path->string (normal-case-path (normalize-path p1))) 3352 (path->string (normal-case-path (normalize-path p2)))))) 3353 3354 (define/override (make-visible filename) 3355 (let ([tab (find-matching-tab filename)]) 3356 (when tab 3357 (change-to-tab tab)))) 3358 3359 (define/public (find-matching-tab filename) 3360 (define fn-path (if (string? filename) 3361 (string->path filename) 3362 filename)) 3363 (for/or ([tab (in-list tabs)]) 3364 (define tab-filename (send (send tab get-defs) get-filename)) 3365 (and tab-filename 3366 (pathname-equal? fn-path tab-filename) 3367 tab))) 3368 3369 (define/override (editing-this-file? filename) 3370 (ormap (λ (tab) 3371 (let ([fn (send (send tab get-defs) get-filename)]) 3372 (and fn 3373 (pathname-equal? fn filename)))) 3374 tabs)) 3375 3376 (define/override (get-menu-item%) 3377 (class (super get-menu-item%) 3378 (inherit get-label get-plain-label) 3379 (define/override (restore-keybinding) 3380 (cond 3381 [(equal? (get-plain-label) (string-constant close)) 3382 (update-close-menu-item-shortcut this)] 3383 [(equal? (get-plain-label) (string-constant close-tab)) 3384 (update-close-tab-menu-item-shortcut this)] 3385 [else (super restore-keybinding)])) 3386 (super-new))) 3387 3388 (define/override (on-activate active?) 3389 (when (preferences:get 'drracket:save-files-on-tab-switch?) 3390 (save-all-unsaved-files)) 3391 (when active? 3392 (send (get-current-tab) touched)) 3393 (super on-activate active?)) 3394 3395 (define/private (update-menu-bindings) 3396 (when close-tab-menu-item 3397 (update-close-tab-menu-item-shortcut close-tab-menu-item)) 3398 (update-close-menu-item-shortcut (file-menu:get-close-item))) 3399 3400 (define/private (update-close-tab-menu-item-shortcut item) 3401 (define just-one? (and (pair? tabs) (null? (cdr tabs)))) 3402 (send item set-label (if just-one? 3403 (string-constant close-tab) 3404 (string-constant close-tab-amp))) 3405 (when (preferences:get 'framework:menu-bindings) 3406 (send item set-shortcut (if just-one? #f #\w)))) 3407 3408 (define/private (update-close-menu-item-shortcut item) 3409 (cond 3410 [(equal? (system-type) 'unix) 3411 (send item set-label (string-constant close-menu-item))] 3412 [else 3413 (define just-one? (and (pair? tabs) (null? (cdr tabs)))) 3414 (send item set-label (if just-one? 3415 (string-constant close-window-menu-item) 3416 (string-constant close-window))) 3417 (when (preferences:get 'framework:menu-bindings) 3418 (send item set-shortcut-prefix (if just-one? 3419 (get-default-shortcut-prefix) 3420 (cons 'shift (get-default-shortcut-prefix)))))])) 3421 3422 (define/override (file-menu:close-callback item control) 3423 (define just-one? (and (pair? tabs) (null? (cdr tabs)))) 3424 (if (and (equal? (system-type) 'unix) 3425 (not just-one?)) 3426 (close-current-tab) 3427 (super file-menu:close-callback item control))) 3428 3429 ;; offer-to-save-file : path -> void 3430 ;; bring the tab that edits the file named by `path' to the front 3431 ;; and opens a dialog asking if it should be saved. 3432 (define/public (offer-to-save-file path) 3433 (let ([original-tab current-tab] 3434 [tab-to-save (find-matching-tab path)]) 3435 (when tab-to-save 3436 (let ([defs-to-save (send tab-to-save get-defs)]) 3437 (when (send defs-to-save is-modified?) 3438 (unless (eq? tab-to-save original-tab) 3439 (change-to-tab tab-to-save)) 3440 (send defs-to-save user-saves-or-not-modified? #f) 3441 (unless (eq? tab-to-save original-tab) 3442 (change-to-tab original-tab))))))) 3443 3444 3445 ;; 3446 ;; end tabs 3447 ;; 3448 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3449 3450 (define/public (get-definitions-text) definitions-text) 3451 (define/public (get-interactions-text) interactions-text) 3452 3453 (define/public (get-definitions/interactions-panel-parent) 3454 toolbar/rest-panel) 3455 3456 (inherit set-show-menu-sort-key) 3457 (define/override (add-show-menu-items show-menu) 3458 (super add-show-menu-items show-menu) 3459 (set! definitions-item 3460 (make-object menu:can-restore-menu-item% 3461 (string-constant hide-definitions-menu-item-label) 3462 (get-show-menu) 3463 (λ (_1 _2) 3464 (toggle-show/hide-definitions) 3465 (update-shown)) 3466 #\d 3467 (string-constant definitions-menu-item-help-string))) 3468 (set-show-menu-sort-key definitions-item 101) 3469 (set! interactions-item 3470 (make-object menu:can-restore-menu-item% 3471 (string-constant show-interactions-menu-item-label) 3472 (get-show-menu) 3473 (λ (_1 _2) 3474 (toggle-show/hide-interactions) 3475 (update-shown)) 3476 #\e 3477 (string-constant interactions-menu-item-help-string))) 3478 (set-show-menu-sort-key interactions-item 102) 3479 3480 (let ([layout-item 3481 (new menu:can-restore-menu-item% 3482 [label (string-constant use-horizontal-layout)] 3483 [parent (get-show-menu)] 3484 [callback (λ (x y) 3485 (define vertical? (send resizable-panel get-vertical?)) 3486 (preferences:set 'drracket:defs/ints-horizontal vertical?) 3487 (send resizable-panel set-orientation vertical?) 3488 (define update-shown? (or (not interactions-shown?) 3489 (not definitions-shown?))) 3490 (unless interactions-shown? 3491 (toggle-show/hide-interactions)) 3492 (unless definitions-shown? 3493 (toggle-show/hide-definitions)) 3494 (when update-shown? 3495 (update-shown)))] 3496 [demand-callback 3497 (λ (mi) (send mi set-label (if (send resizable-panel get-vertical?) 3498 (string-constant use-horizontal-layout) 3499 (string-constant use-vertical-layout))))] 3500 [shortcut (if (member 'shift (get-default-shortcut-prefix)) 3501 #f 3502 #\l)] 3503 [shortcut-prefix (if (member 'shift (get-default-shortcut-prefix)) 3504 (get-default-shortcut-prefix) 3505 (cons 'shift (get-default-shortcut-prefix)))])]) 3506 (set-show-menu-sort-key layout-item 103)) 3507 3508 (let () 3509 (define (overview-shown?) 3510 (send (send (get-current-tab) get-defs) get-inline-overview-enabled?)) 3511 (define overview-menu-item 3512 (new menu:can-restore-menu-item% 3513 (shortcut #\u) 3514 (label 3515 (if (overview-shown?) 3516 (string-constant hide-overview) 3517 (string-constant show-overview))) 3518 (parent (get-show-menu)) 3519 [demand-callback 3520 (λ (mi) 3521 (send mi set-label 3522 (if (overview-shown?) 3523 (string-constant hide-overview) 3524 (string-constant show-overview))))] 3525 (callback 3526 (λ (menu evt) 3527 (cond 3528 [(overview-shown?) 3529 (preferences:set 'drracket:inline-overview-shown? #f) 3530 (send (send (get-current-tab) get-defs) set-inline-overview-enabled? #f)] 3531 [else 3532 (preferences:set 'drracket:inline-overview-shown? #t) 3533 (send (send (get-current-tab) get-defs) set-inline-overview-enabled? #t)]))))) 3534 (set-show-menu-sort-key overview-menu-item 301)) 3535 3536 (set! module-browser-menu-item 3537 (new menu:can-restore-menu-item% 3538 (label (if module-browser-shown? 3539 (string-constant hide-module-browser) 3540 (string-constant show-module-browser))) 3541 (parent (get-show-menu)) 3542 (callback 3543 (λ (menu evt) 3544 (if module-browser-shown? 3545 (hide-module-browser) 3546 (show-module-browser)))))) 3547 (set-show-menu-sort-key module-browser-menu-item 401) 3548 3549 (set! toolbar-menu (new menu% 3550 [parent show-menu] 3551 [label (string-constant toolbar)])) 3552 (set-show-menu-sort-key toolbar-menu 1) 3553 (set! toolbar-left-menu-item 3554 (new checkable-menu-item% 3555 [label (string-constant toolbar-on-left)] 3556 [parent toolbar-menu] 3557 [callback (λ (x y) (set-toolbar-left))] 3558 [checked #f])) 3559 (set! toolbar-top-menu-item 3560 (new checkable-menu-item% 3561 [label (string-constant toolbar-on-top)] 3562 [parent toolbar-menu] 3563 [callback (λ (x y) (set-toolbar-top))] 3564 [checked #f])) 3565 (set! toolbar-top-no-label-menu-item 3566 (new checkable-menu-item% 3567 [label (string-constant toolbar-on-top-no-label)] 3568 [parent toolbar-menu] 3569 [callback (λ (x y) (set-toolbar-top-no-label))] 3570 [checked #f])) 3571 (set! toolbar-right-menu-item 3572 (new checkable-menu-item% 3573 [label (string-constant toolbar-on-right)] 3574 [parent toolbar-menu] 3575 [callback (λ (x y) (set-toolbar-right))] 3576 [checked #f])) 3577 (set! toolbar-hidden-menu-item 3578 (new checkable-menu-item% 3579 [label (string-constant toolbar-hidden)] 3580 [parent toolbar-menu] 3581 [callback (λ (x y) (set-toolbar-hidden))] 3582 [checked #f])) 3583 3584 (set! logger-menu-item 3585 (new menu-item% 3586 [label (string-constant show-log)] 3587 [parent show-menu] 3588 [callback 3589 (λ (x y) (send current-tab toggle-log))])) 3590 (set-show-menu-sort-key logger-menu-item 205) 3591 3592 3593 (set! show-line-numbers-menu-item 3594 (new menu:can-restore-menu-item% 3595 [label (if (show-line-numbers?) 3596 (string-constant hide-line-numbers/menu) 3597 (string-constant show-line-numbers/menu))] 3598 [parent (get-show-menu)] 3599 [callback (lambda (self event) 3600 (define value (preferences:get 'drracket:show-line-numbers?)) 3601 (preferences:set 'drracket:show-line-numbers? (not value)) 3602 (show-line-numbers! (not value)))])) 3603 (set-show-menu-sort-key show-line-numbers-menu-item 302) 3604 3605 (define show-column-guide-menu-item 3606 (new menu:can-restore-menu-item% 3607 [label ""] 3608 [parent (get-show-menu)] 3609 [demand-callback (λ (itm) 3610 (define pv (preferences:get 'framework:column-guide-width)) 3611 (send itm set-label 3612 (format (if (car pv) 3613 (string-constant hide-column-width-guide) 3614 (string-constant show-column-width-guide)) 3615 (cadr pv))))] 3616 [callback (λ (self evt) 3617 (define ov (preferences:get 'framework:column-guide-width)) 3618 (preferences:set 'framework:column-guide-width 3619 (list (not (car ov)) (cadr ov))))])) 3620 (set-show-menu-sort-key show-column-guide-menu-item 303) 3621 3622 (let () 3623 (define (font-adjust adj label key shortcut) 3624 (define (adj-font _1 _2) 3625 (editor:set-current-preferred-font-size 3626 (adj 3627 (editor:get-current-preferred-font-size)))) 3628 (define (on-demand item) 3629 (define lab 3630 (format 3631 label 3632 (adj 3633 (editor:get-current-preferred-font-size)))) 3634 (send item set-label lab) 3635 (send item enable (<= 1 (adj (editor:get-current-preferred-font-size)) 255))) 3636 (define item 3637 (new menu:can-restore-menu-item% 3638 (shortcut shortcut) 3639 (label "") 3640 (parent (get-show-menu)) 3641 (callback adj-font) 3642 (demand-callback on-demand))) 3643 (set-show-menu-sort-key item key)) 3644 (font-adjust add1 (string-constant increase-font-size) -2 #\=) 3645 (font-adjust sub1 (string-constant decrease-font-size) -3 #\-)) 3646 3647 (let ([split 3648 (new menu:can-restore-menu-item% 3649 (shortcut (if (equal? (system-type) 'macosx) #f #\m)) 3650 (label (string-constant split-menu-item-label)) 3651 (parent (get-show-menu)) 3652 (callback (λ (x y) (split))) 3653 (demand-callback (λ (item) (split-demand item))))] 3654 [collapse 3655 (new menu:can-restore-menu-item% 3656 (shortcut (if (or (equal? (system-type) 'macosx) 3657 (member 'shift (get-default-shortcut-prefix))) 3658 #f 3659 #\m)) 3660 (shortcut-prefix (cond 3661 [(or (equal? (system-type) 'macosx) 3662 (member 'shift (get-default-shortcut-prefix))) 3663 (get-default-shortcut-prefix)] 3664 [else 3665 (cons 'shift (get-default-shortcut-prefix))])) 3666 (label (string-constant collapse-menu-item-label)) 3667 (parent (get-show-menu)) 3668 (callback (λ (x y) (collapse))) 3669 (demand-callback (λ (item) (collapse-demand item))))]) 3670 (set-show-menu-sort-key split 2) 3671 (set-show-menu-sort-key collapse 3))) 3672 3673 3674; 3675; 3676; 3677; 3678; ;;; ;;; 3679; ;;; ;;; 3680; ;;; ;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;;; 3681; ;;;;;;;;;;; ;;;;; ;;;;;;; ;;; ;;; ;;; ;; ;;; 3682; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 3683; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; 3684; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 3685; ;;; ;;; ;;; ;;;;; ;;;;;;; ;;;;;;; ;;; ;;;;;; 3686; ;;; ;;; ;;; ;;; ;; ;;; ;; ;;; ;;; ;;;; 3687; 3688; 3689; 3690; 3691; 3692; 3693; 3694; 3695; ;;; 3696; ;;; 3697; ;;; ;; ;;; ;; ;;; ;;; ;;; ;;; ;;;; ;;;; ;;; ; 3698; ;;;;;;; ;;;;; ;;;;; ;;; ;;; ;;;;;; ;; ;; ;;; ;;;;; 3699; ;;; ;;; ;;; ;;; ;;; ;;;;;;;;; ;;; ;;; ;;; ;;; 3700; ;;; ;;; ;;; ;;; ;;; ;;;; ;;;; ;;;; ;;;;;;; ;;; 3701; ;;; ;;; ;;; ;;; ;;; ;;;; ;;;; ;;; ;;; ;;; 3702; ;;;;;;; ;;; ;;;;; ;; ;; ;; ;;; ;;;;;; ;;; 3703; ;;; ;; ;;; ;;; ;; ;; ;;;; ;;;; ;;; 3704; 3705; 3706; 3707; 3708 3709 (field [module-browser-shown? #f] 3710 [module-browser-parent-panel #f] 3711 [module-browser-panel #f] 3712 [module-browser-ec #f] 3713 [module-browser-button #f] 3714 [module-browser-lib-path-check-box #f] 3715 [module-browser-planet-path-check-box #f] 3716 [module-browser-name-length-choice #f] 3717 [module-browser-pb #f] 3718 [module-browser-menu-item 'module-browser-menu-item-unset]) 3719 3720 (inherit open-status-line close-status-line update-status-line) 3721 3722 (define/private (show-module-browser) 3723 (when module-browser-panel 3724 (when (can-browse-language?) 3725 (set! module-browser-shown? #t) 3726 (send module-browser-menu-item set-label (string-constant hide-module-browser)) 3727 (update-module-browser-pane)))) 3728 3729 (define/private (hide-module-browser) 3730 (when module-browser-panel 3731 (set! module-browser-shown? #f) 3732 (send module-browser-menu-item set-label (string-constant show-module-browser)) 3733 (set! module-browser-mouse-over-status-line-open? #f) 3734 (close-status-line 'plt:module-browser:mouse-over) 3735 (send module-browser-parent-panel change-children 3736 (λ (l) 3737 (remq module-browser-panel l))))) 3738 3739 (define/private (can-browse-language?) 3740 (let* ([lang/config (send (get-definitions-text) get-next-settings)] 3741 [lang (drracket:language-configuration:language-settings-language lang/config)] 3742 [strs (send lang get-language-position)] 3743 [can-browse? 3744 (or (is-a? lang drracket:module-language:module-language<%>) 3745 (ormap (λ (x) (regexp-match #rx"PLT" x)) 3746 strs))]) 3747 (unless can-browse? 3748 (message-box (string-constant drscheme) 3749 (string-constant module-browser-only-in-plt-and-module-langs) 3750 #:dialog-mixin frame:focus-table-mixin)) 3751 can-browse?)) 3752 3753 (define module-browser-mouse-over-status-line-open? #f) 3754 (define/private (update-module-browser-pane) 3755 (open-status-line 'plt:module-browser:mouse-over) 3756 (set! module-browser-mouse-over-status-line-open? #t) 3757 (send module-browser-panel begin-container-sequence) 3758 (unless module-browser-ec 3759 (set! module-browser-pb 3760 (drracket:module-overview:make-module-overview-pasteboard 3761 #t 3762 (λ (x) (mouse-currently-over x)))) 3763 (set! module-browser-ec (make-object editor-canvas% 3764 module-browser-panel 3765 module-browser-pb)) 3766 3767 (let* ([show-callback 3768 (λ (cb key) 3769 (if (send cb get-value) 3770 (send module-browser-pb show-visible-paths key) 3771 (send module-browser-pb remove-visible-paths key)) 3772 (preferences:set 'drracket:module-browser:hide-paths 3773 (send module-browser-pb get-hidden-paths)))] 3774 [mk-checkbox 3775 (λ (key label) 3776 (new check-box% 3777 (parent module-browser-panel) 3778 (label label) 3779 (value (not (memq key (preferences:get 3780 'drracket:module-browser:hide-paths)))) 3781 (callback 3782 (λ (cb _) 3783 (show-callback cb key)))))]) 3784 (set! module-browser-lib-path-check-box (mk-checkbox 'lib show-lib-paths)) 3785 (set! module-browser-planet-path-check-box (mk-checkbox 'planet show-planet-paths))) 3786 3787 (set! module-browser-name-length-choice 3788 (new choice% 3789 (parent module-browser-panel) 3790 (label (string-constant module-browser-name-length)) 3791 (choices (list (string-constant module-browser-name-short) 3792 (string-constant module-browser-name-medium) 3793 (string-constant module-browser-name-long) 3794 (string-constant module-browser-name-very-long))) 3795 (selection (preferences:get 'drracket:module-browser:name-length)) 3796 (callback 3797 (λ (x y) 3798 (let ([selection (send module-browser-name-length-choice get-selection)]) 3799 (preferences:set 'drracket:module-browser:name-length selection) 3800 (update-module-browser-name-length selection)))))) 3801 (update-module-browser-name-length 3802 (preferences:get 'drracket:module-browser:name-length)) 3803 3804 (set! module-browser-button 3805 (new button% 3806 (parent module-browser-panel) 3807 (label refresh) 3808 (callback (λ (x y) (update-module-browser-pane))) 3809 (stretchable-width #t)))) 3810 3811 (let ([p (preferences:get 'drracket:module-browser-size-percentage)]) 3812 (send module-browser-parent-panel change-children 3813 (λ (l) 3814 (cons module-browser-panel 3815 (remq module-browser-panel l)))) 3816 (with-handlers ([exn:fail? void]) 3817 (send module-browser-parent-panel set-percentages (list p (- 1 p)))) 3818 (send module-browser-parent-panel end-container-sequence) 3819 (calculate-module-browser))) 3820 3821 (define/private (update-module-browser-name-length i) 3822 (send module-browser-pb set-name-length 3823 (case i 3824 [(0) 'short] 3825 [(1) 'medium] 3826 [(2) 'long] 3827 [(3) 'very-long]))) 3828 3829 (define/private (mouse-currently-over snips) 3830 (when module-browser-mouse-over-status-line-open? 3831 (if (null? snips) 3832 (update-status-line 'plt:module-browser:mouse-over #f) 3833 (let* ([snip (car snips)] 3834 [lines (send snip get-lines)] 3835 [name (or (send snip get-filename) 3836 (send snip get-word))] 3837 [str (if lines 3838 (format (string-constant module-browser-filename-format) name lines) 3839 name)]) 3840 (update-status-line 'plt:module-browser:mouse-over str))))) 3841 3842 (define/private (calculate-module-browser) 3843 (let ([mod-tab current-tab]) 3844 (let-values ([(old-break-thread old-custodian) (send mod-tab get-breakables)]) 3845 (open-status-line 'plt:module-browser) 3846 (update-status-line 'plt:module-browser status-compiling-definitions) 3847 (send module-browser-button enable #f) 3848 (send module-browser-lib-path-check-box enable #f) 3849 (send module-browser-planet-path-check-box enable #f) 3850 (send module-browser-name-length-choice enable #f) 3851 (disable-evaluation-in-tab current-tab) 3852 (drracket:module-overview:fill-pasteboard 3853 module-browser-pb 3854 (drracket:language:make-text/pos 3855 definitions-text 3856 0 3857 (send definitions-text last-position)) 3858 (λ (str) (update-status-line 3859 'plt:module-browser 3860 (gui-utils:trim-string (format module-browser-progress-constant str) 200))) 3861 (λ (user-thread user-custodian) 3862 (send mod-tab set-breakables user-thread user-custodian))) 3863 (send mod-tab set-breakables old-break-thread old-custodian) 3864 (send mod-tab enable-evaluation) 3865 (send module-browser-button enable #t) 3866 (send module-browser-lib-path-check-box enable #t) 3867 (send module-browser-planet-path-check-box enable #t) 3868 (send module-browser-name-length-choice enable #t) 3869 (close-status-line 'plt:module-browser)))) 3870 3871 3872 ; 3873 ; 3874 ; 3875 ; 3876 ; 3877 ; 3878 ; ; ;; ;; ;;; ; ;; ; ; ;;; 3879 ; ;; ;; ; ; ; ;; ; ; ; ; 3880 ; ; ; ; ; ; ; ; ; ; ;; 3881 ; ; ; ; ;;;;;; ; ; ; ; ;; 3882 ; ; ; ; ; ; ; ; ; ; 3883 ; ; ; ; ; ; ; ; ;; ; 3884 ; ; ; ; ;;;; ; ; ;; ; ;;; 3885 ; 3886 ; 3887 ; 3888 3889 (define execute-menu-item #f) 3890 (define file-menu:print-interactions-item #f) 3891 (define file-menu:create-new-tab-item #f) 3892 3893 (define/override (file-menu:between-new-and-open file-menu) 3894 (set! file-menu:create-new-tab-item 3895 (new menu:can-restore-menu-item% 3896 (label (string-constant new-tab)) 3897 (shortcut #\t) 3898 (parent file-menu) 3899 (callback 3900 (λ (x y) 3901 (create-new-tab)))))) 3902 [define/override file-menu:between-open-and-revert 3903 (lambda (file-menu) 3904 (new menu:can-restore-menu-item% 3905 [label (string-constant open-require-path)] 3906 [shortcut (if (member 'shift (get-default-shortcut-prefix)) #f #\o)] 3907 [shortcut-prefix (if (member 'shift (get-default-shortcut-prefix)) 3908 (get-default-shortcut-prefix) 3909 (cons 'shift (get-default-shortcut-prefix)))] 3910 [parent file-menu] 3911 [callback 3912 (λ (x y) 3913 (define editing-path (send (get-definitions-text) get-filename)) 3914 (define editing-module-path 3915 (and editing-path 3916 (match (path->module-path editing-path) 3917 [`(lib ,(? string? s)) 3918 (define m (regexp-match #rx"^(.*/)[^/]*$" s)) 3919 (and m 3920 (list-ref m 1))] 3921 [else #f]))) 3922 ;; editing-module-path won't find anything interesting 3923 ;; if the get-module-path-from-user is using some other 3924 ;; racket binary 3925 (define pth 3926 (get-module-path-from-user 3927 #:init (or editing-module-path 3928 (preferences:get 'drracket:open-module-path-last-used)) 3929 #:pref 'drracket:open-module-path-last-used 3930 #:current-directory 3931 (and editing-path 3932 (let-values ([(base name dir?) (split-path editing-path)]) 3933 base)))) 3934 (when pth (handler:edit-file pth)))]) 3935 (super file-menu:between-open-and-revert file-menu) 3936 (make-object separator-menu-item% file-menu))] 3937 (define close-tab-menu-item #f) 3938 (define/override (file-menu:between-close-and-quit file-menu) 3939 (unless (equal? (system-type) 'unix) 3940 (set! close-tab-menu-item 3941 (new (get-menu-item%) 3942 (label (string-constant close-tab)) 3943 (demand-callback 3944 (λ (item) 3945 (send item enable (1 . < . (send tabs-panel get-number))))) 3946 (parent file-menu) 3947 (callback 3948 (λ (x y) 3949 (close-current-tab)))))) 3950 (super file-menu:between-close-and-quit file-menu)) 3951 3952 (define/override (file-menu:save-string) (string-constant save-definitions)) 3953 (define/override (file-menu:save-as-string) (string-constant save-definitions-as)) 3954 (define/override (file-menu:between-save-as-and-print file-menu) 3955 (let ([sub-menu (make-object menu% (string-constant save-other) file-menu)]) 3956 (make-object menu:can-restore-menu-item% 3957 (string-constant save-definitions-as-text) 3958 sub-menu 3959 (λ (_1 _2) 3960 (let ([filename (send definitions-text put-file #f #f)]) 3961 (when filename 3962 (send definitions-text save-file/gui-error filename 'text))))) 3963 (make-object menu:can-restore-menu-item% 3964 (string-constant save-interactions) 3965 sub-menu 3966 (λ (_1 _2) 3967 (send interactions-text save-file/gui-error))) 3968 (make-object menu:can-restore-menu-item% 3969 (string-constant save-interactions-as) 3970 sub-menu 3971 (λ (_1 _2) 3972 (let ([filename (send interactions-text put-file #f #f)]) 3973 (when filename 3974 (send interactions-text save-file/gui-error filename 'standard))))) 3975 (make-object menu:can-restore-menu-item% 3976 (string-constant save-interactions-as-text) 3977 sub-menu 3978 (λ (_1 _2) 3979 (let ([filename (send interactions-text put-file #f #f)]) 3980 (when filename 3981 (send interactions-text save-file/gui-error filename 'text))))) 3982 (make-object separator-menu-item% file-menu) 3983 (set! transcript-menu-item 3984 (make-object menu:can-restore-menu-item% 3985 (string-constant log-definitions-and-interactions) 3986 file-menu 3987 (λ (x y) 3988 (if transcript 3989 (stop-transcript) 3990 (start-transcript))))) 3991 (make-object separator-menu-item% file-menu) 3992 (super file-menu:between-save-as-and-print file-menu))) 3993 3994 [define/override file-menu:print-string (λ () (string-constant print-definitions))] 3995 (define/override (file-menu:between-print-and-close file-menu) 3996 (set! file-menu:print-interactions-item 3997 (make-object menu:can-restore-menu-item% 3998 (string-constant print-interactions) 3999 file-menu 4000 (λ (_1 _2) 4001 (send interactions-text print 4002 #t 4003 #t 4004 (preferences:get 'framework:print-output-mode))))) 4005 (super file-menu:between-print-and-close file-menu)) 4006 4007 (define/override (edit-menu:between-find-and-preferences edit-menu) 4008 (super edit-menu:between-find-and-preferences edit-menu) 4009 4010 (define (aspell-callback f) 4011 (define problem (aspell-problematic?)) 4012 (cond 4013 [problem 4014 (message-box (string-constant drscheme) problem) 4015 (f #t)] 4016 [else 4017 (f #f)])) 4018 4019 (define (mk-menu-item checking-turned-on? 4020 turn-checking-on 4021 pref-sym 4022 shortcut 4023 label) 4024 (new menu:can-restore-checkable-menu-item% 4025 [label label] 4026 [shortcut (if (member 'shift (get-default-shortcut-prefix)) 4027 #f 4028 shortcut)] 4029 [shortcut-prefix (if (member 'shift (get-default-shortcut-prefix)) 4030 (get-default-shortcut-prefix) 4031 (cons 'shift (get-default-shortcut-prefix)))] 4032 [parent edit-menu] 4033 [demand-callback 4034 (λ (item) 4035 (define ed (get-edit-target-object)) 4036 (define on? (and ed (is-a? ed color:text<%>))) 4037 (send item enable ed) 4038 (send item check (and on? (checking-turned-on? ed))))] 4039 [callback 4040 (λ (item evt) 4041 (aspell-callback 4042 (λ (problem?) 4043 (cond 4044 [problem? (preferences:set pref-sym #f)] 4045 [else 4046 (define ed (get-edit-target-object)) 4047 (define old-val (checking-turned-on? ed)) 4048 (preferences:set pref-sym (not old-val)) 4049 (turn-checking-on ed (not old-val))]))))])) 4050 (mk-menu-item (λ (ed) (send ed get-spell-check-strings)) 4051 (λ (ed new-val) (send ed set-spell-check-strings new-val)) 4052 'framework:spell-check-strings? 4053 #\c 4054 (string-constant spell-check-string-constants)) 4055 (mk-menu-item (λ (ed) (send ed get-spell-check-text)) 4056 (λ (ed new-val) (send ed set-spell-check-text new-val)) 4057 'framework:spell-check-text? 4058 #\t 4059 (string-constant spell-check-scribble-text)) 4060 4061 (new menu:can-restore-menu-item% 4062 [label (string-constant spell-skip-to-next-misspelled-word)] 4063 [shortcut (if (member 'shift (get-default-shortcut-prefix)) 4064 #f 4065 #\n)] 4066 [shortcut-prefix (if (member 'shift (get-default-shortcut-prefix)) 4067 (get-default-shortcut-prefix) 4068 (cons 'shift (get-default-shortcut-prefix)))] 4069 [parent edit-menu] 4070 [demand-callback 4071 (λ (item) 4072 (define ed (get-edit-target-object)) 4073 (define on? (and ed 4074 (is-a? ed color:text<%>) 4075 (= (send ed get-start-position) (send ed get-end-position)))) 4076 (send item enable on?))] 4077 [callback 4078 (λ (item evt) 4079 (aspell-callback 4080 (λ (problem?) 4081 (unless problem? 4082 (define ed (get-edit-target-object)) 4083 (define orig-pos (send ed get-start-position)) 4084 4085 (define (search start end mispelled?) 4086 (let loop ([p start]) 4087 (cond 4088 [(< p end) 4089 (define sp (send ed get-spell-suggestions p)) 4090 (define found-something? (if mispelled? 4091 (list? sp) 4092 (not (list? sp)))) 4093 (cond 4094 [found-something? p] 4095 [else (loop (+ p 1))])] 4096 [else #f]))) 4097 4098 (define first-well-spelled (or (search orig-pos (send ed last-position) #f) 4099 (search 0 orig-pos #f))) 4100 (cond 4101 [first-well-spelled 4102 (define mispelled (or (search first-well-spelled (send ed last-position) #t) 4103 (search 0 first-well-spelled #t))) 4104 (cond 4105 [mispelled (send ed set-position mispelled)] 4106 [else (bell)])] 4107 [else (bell)])))))]) 4108 4109 (new menu:can-restore-menu-item% 4110 [label (string-constant spell-suggest-corrections)] 4111 [shortcut (if (member 'shift (get-default-shortcut-prefix)) 4112 #f 4113 #\k)] 4114 [shortcut-prefix (if (member 'shift (get-default-shortcut-prefix)) 4115 (get-default-shortcut-prefix) 4116 (cons 'shift (get-default-shortcut-prefix)))] 4117 [parent edit-menu] 4118 [demand-callback 4119 (λ (item) 4120 (define ed (get-edit-target-object)) 4121 (define on? (and ed 4122 (is-a? ed color:text<%>) 4123 (= (send ed get-start-position) (send ed get-end-position)))) 4124 (send item enable on?))] 4125 [callback 4126 (λ (item evt) 4127 (aspell-callback 4128 (λ (problem?) 4129 (unless problem? 4130 (define ed (get-edit-target-object)) 4131 (define orig-pos (send ed get-start-position)) 4132 (match (send ed get-spell-suggestions orig-pos) 4133 [(list start end (cons first rest)) 4134 (define suggestions (cons first rest)) 4135 (define choice 4136 (get-choices-from-user (string-constant spell-correction-suggestions) 4137 (string-constant spell-choose-replacement-word) 4138 suggestions 4139 this 4140 '(0))) 4141 (when choice 4142 (send ed begin-edit-sequence) 4143 (send ed delete start end) 4144 (send ed insert (list-ref suggestions (car choice)) start start) 4145 (send ed end-edit-sequence))] 4146 [_ (bell)])))))]) 4147 4148 (define dicts (get-aspell-dicts)) 4149 (when dicts 4150 (define dicts-menu (new menu:can-restore-underscore-menu% 4151 [parent edit-menu] 4152 [label (string-constant spelling-dictionaries)])) 4153 (define (mk-item dict label) 4154 (new menu:can-restore-checkable-menu-item% 4155 [parent dicts-menu] 4156 [label label] 4157 [callback 4158 (λ (item evt) 4159 (define ed (get-edit-target-object)) 4160 (when (and ed (is-a? ed color:text<%>)) 4161 (preferences:set 'framework:aspell-dict dict) 4162 (send ed set-spell-current-dict dict)))] 4163 [demand-callback 4164 (λ (item) 4165 (define ed (get-edit-target-object)) 4166 (send item enable (and ed (is-a? ed color:text<%>))) 4167 (send item check 4168 (and ed 4169 (is-a? ed color:text<%>) 4170 (equal? dict (send ed get-spell-current-dict)))))])) 4171 (mk-item #f (string-constant default-spelling-dictionary)) 4172 (new separator-menu-item% [parent dicts-menu]) 4173 (for ([dict (in-list dicts)]) 4174 (mk-item dict dict))) 4175 (new menu:can-restore-menu-item% 4176 [label (string-constant complete-word)] 4177 [shortcut #\/] 4178 [parent edit-menu] 4179 [demand-callback 4180 (λ (mi) 4181 (send mi enable 4182 (let ([ed (get-edit-target-object)]) 4183 (and ed 4184 (is-a? ed text:autocomplete<%>)))))] 4185 [callback (λ (x y) 4186 (send (get-edit-target-object) auto-complete))]) 4187 (add-modes-submenu edit-menu)) 4188 4189 (define/override (edit-menu:between-select-all-and-find edit-menu) 4190 (new menu:can-restore-checkable-menu-item% 4191 [label (string-constant overwrite-mode)] 4192 [parent edit-menu] 4193 [demand-callback 4194 (λ (mi) 4195 (let ([target (get-edit-target-object)]) 4196 (send mi enable (is-a? target text%)) 4197 (when (is-a? target text%) 4198 (send mi check (and target (send target get-overwrite-mode))))))] 4199 [callback (λ (x y) 4200 (let ([target (get-edit-target-object)]) 4201 (send target set-overwrite-mode 4202 (not (send target get-overwrite-mode)))))]) 4203 (super edit-menu:between-select-all-and-find edit-menu)) 4204 4205 (define/override (edit-menu:between-paste-and-clear edit-menu) 4206 (new menu:can-restore-menu-item% 4207 [label (string-constant paste-and-indent-menu-item)] 4208 [parent edit-menu] 4209 [shortcut #\v] 4210 [shortcut-prefix (cons 'shift (get-default-shortcut-prefix))] 4211 [demand-callback 4212 (λ (item) 4213 (define editor (get-edit-target-object)) 4214 (send item enable 4215 (and editor 4216 (is-a? editor racket:text<%>) 4217 (send editor can-do-edit-operation? 'paste))))] 4218 [callback (λ (x y) 4219 (define target (get-edit-target-object)) 4220 (send target begin-edit-sequence) 4221 (define start-pos-before (send target get-start-position)) 4222 (define end-pos-before (send target get-start-position)) 4223 (define selection-size (- end-pos-before start-pos-before)) 4224 (define positions-before (- (send target last-position) selection-size)) 4225 (send target do-edit-operation 'paste) 4226 (define amount-to-tabify (- (send target last-position) positions-before)) 4227 (send target tabify-selection 4228 start-pos-before 4229 (+ start-pos-before amount-to-tabify)) 4230 (send target end-edit-sequence))]) 4231 (super edit-menu:between-paste-and-clear edit-menu)) 4232 4233 ;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key))) 4234 (define capability-menu-items (make-hasheq)) 4235 (define/public (register-capability-menu-item key menu) 4236 (let ([items (send menu get-items)]) 4237 (when (null? items) 4238 (error 'register-capability-menu-item "menu ~e has no items" menu)) 4239 (let* ([menu-item (last items)] 4240 [this-one (list menu-item (- (length items) 1) key)] 4241 [old-ones (hash-ref capability-menu-items menu (λ () '()))]) 4242 (hash-set! capability-menu-items menu (cons this-one old-ones))))) 4243 4244 (define/private (update-items/capability menu) 4245 (let* ([old-items (send menu get-items)] 4246 [new-items (begin '(get-items/capability menu) 4247 old-items)]) 4248 (unless (equal? old-items new-items) 4249 (for-each (λ (i) (send i delete)) old-items) 4250 (for-each (λ (i) (send i restore)) new-items)))) 4251 (define/private (get-items/capability menu) 4252 (let loop ([capability-items (reverse (hash-ref capability-menu-items menu '()))] 4253 [all-items (send menu get-items)] 4254 [i 0]) 4255 (cond 4256 [(null? capability-items) all-items] 4257 [(pair? capability-items) 4258 (let* ([cap-item-list (car capability-items)] 4259 [cap-item (list-ref cap-item-list 0)] 4260 [cap-num (list-ref cap-item-list 1)] 4261 [cap-key (list-ref cap-item-list 2)]) 4262 (cond 4263 [(= cap-num i) 4264 (let ([is-on? (get-current-capability-value cap-key)]) 4265 (cond 4266 [is-on? 4267 (cond 4268 [(null? all-items) 4269 (cons cap-item (loop (cdr capability-items) null (+ i 1)))] 4270 [(pair? all-items) 4271 (if (eq? (car all-items) cap-item) 4272 (cons cap-item (loop (cdr capability-items) (cdr all-items) (+ i 1))) 4273 (cons cap-item (loop (cdr capability-items) all-items (+ i 1))))])] 4274 [else 4275 (cond 4276 [(null? all-items) 4277 (loop (cdr capability-items) null (+ i 1))] 4278 [(pair? all-items) 4279 (if (eq? (car all-items) cap-item) 4280 (loop (cdr capability-items) (cdr all-items) (+ i 1)) 4281 (loop (cdr capability-items) all-items (+ i 1)))])]))] 4282 [else (cons (car all-items) 4283 (loop capability-items 4284 (cdr all-items) 4285 (+ i 1)))]))]))) 4286 4287 (define/private (get-current-capability-value key) 4288 (define language-settings (send (get-definitions-text) get-next-settings)) 4289 (define new-language 4290 (drracket:language-configuration:language-settings-language language-settings)) 4291 (send new-language capability-value key)) 4292 4293 (define language-menu 'uninited-language-menu) 4294 (define language-specific-menu 'language-specific-menu-not-yet-init) 4295 (define insert-menu 'insert-menu-not-yet-init) 4296 (define/public (get-insert-menu) insert-menu) 4297 (define/public (get-special-menu) insert-menu) 4298 4299 (define/public (choose-language-callback) 4300 (let ([new-settings (drracket:language-configuration:language-dialog 4301 #f 4302 (send definitions-text get-next-settings) 4303 this)]) 4304 (when new-settings 4305 (send definitions-text set-next-settings new-settings)))) 4306 4307 ;; must be called from on-demand (on each menu click), or the state won't be handled properly 4308 (define/private (update-teachpack-menu) 4309 (for-each (λ (item) (send item delete)) teachpack-items) 4310 (let ([tp-callbacks (get-current-capability-value 'drscheme:teachpack-menu-items)]) 4311 (cond 4312 [tp-callbacks 4313 (let* ([language (drracket:language-configuration:language-settings-language 4314 (send (get-definitions-text) get-next-settings))] 4315 [settings (drracket:language-configuration:language-settings-settings 4316 (send (get-definitions-text) get-next-settings))] 4317 [tp-names ((teachpack-callbacks-get-names tp-callbacks) settings)] 4318 [update-settings 4319 (λ (settings) 4320 (send (get-definitions-text) set-next-settings 4321 (drracket:language-configuration:language-settings language settings)) 4322 (send (get-definitions-text) teachpack-changed) 4323 (update-teachpack-menu))]) 4324 (set! teachpack-items 4325 (list* 4326 (make-object separator-menu-item% language-menu) 4327 (new menu:can-restore-menu-item% 4328 [label (string-constant add-teachpack-menu-item-label)] 4329 [parent language-menu] 4330 [callback 4331 (λ (_1 _2) 4332 (update-settings ((teachpack-callbacks-add tp-callbacks) 4333 settings 4334 this)))]) 4335 (let ([mi (new menu:can-restore-menu-item% 4336 [label (string-constant clear-all-teachpacks-menu-item-label)] 4337 [parent language-menu] 4338 [callback 4339 (λ (_1 _2) 4340 (update-settings 4341 ((teachpack-callbacks-remove-all tp-callbacks) 4342 settings)))])]) 4343 (send mi enable (not (null? tp-names))) 4344 mi) 4345 (map (λ (name) 4346 (new menu:can-restore-menu-item% 4347 [label (gui-utils:format-literal-label 4348 (string-constant clear-teachpack) 4349 name)] 4350 [parent language-menu] 4351 [callback 4352 (λ (item evt) 4353 (update-settings 4354 ((teachpack-callbacks-remove tp-callbacks) 4355 settings name)))])) 4356 tp-names))))] 4357 [else 4358 (set! teachpack-items 4359 (list 4360 (new menu:can-restore-menu-item% 4361 [label (string-constant add-teachpack-menu-item-label)] 4362 [parent language-menu] 4363 [callback 4364 (λ (_1 _2) 4365 (message-box 4366 (string-constant drscheme) 4367 (gui-utils:format-literal-label 4368 (string-constant teachpacks-only-in-languages) 4369 (apply 4370 string-append 4371 (reverse 4372 (filter 4373 values 4374 (map (λ (l) 4375 (and 4376 (send l capability-value 'drscheme:teachpack-menu-items) 4377 (format "\n ~a" (send l get-language-name)))) 4378 (drracket:language-configuration:get-languages)))))) 4379 this 4380 #:dialog-mixin frame:focus-table-mixin))])))]))) 4381 4382 (define/private (initialize-menus) 4383 (define mb (get-menu-bar)) 4384 (set! language-menu (new (get-menu%) 4385 [label (string-constant language-menu-name)] 4386 [parent mb])) 4387 (set! language-specific-menu (new (get-menu%) 4388 [label (drracket:language:get-capability-default 4389 'drscheme:language-menu-title)] 4390 [parent mb])) 4391 (define ((send-method method) _1 _2) 4392 (define text (get-edit-target-object)) 4393 (when (is-a? text racket:text<%>) 4394 (method text))) 4395 (define (show/hide-capability-menus) 4396 (for ([menu (in-list (send (get-menu-bar) get-items))]) 4397 (update-items/capability menu))) 4398 4399 (make-object menu:can-restore-menu-item% 4400 (string-constant choose-language-menu-item-label) 4401 language-menu 4402 (λ (_1 _2) (choose-language-callback)) 4403 #\l) 4404 4405 (set! execute-menu-item 4406 (make-object menu:can-restore-menu-item% 4407 (string-constant execute-menu-item-label) 4408 language-specific-menu 4409 (λ (_1 _2) (execute-callback)) 4410 #\r 4411 (string-constant execute-menu-item-help-string))) 4412 (make-object menu:can-restore-menu-item% 4413 (string-constant ask-quit-menu-item-label) 4414 language-specific-menu 4415 (λ (_1 _2) (send current-tab break-callback)) 4416 #\b 4417 (string-constant ask-quit-menu-item-help-string)) 4418 (make-object menu:can-restore-menu-item% 4419 (string-constant force-quit-menu-item-label) 4420 language-specific-menu 4421 (λ (_1 _2) (send interactions-text kill-evaluation)) 4422 #\k 4423 (string-constant force-quit-menu-item-help-string)) 4424 (new menu:can-restore-menu-item% 4425 [label (string-constant module-language-#lang-flush-cache-menu-item)] 4426 [parent language-specific-menu] 4427 [callback (λ (_1 _2) (send (send current-tab get-defs) move-to-new-language #t))] 4428 [shortcut #\d] 4429 [shortcut-prefix (cons 'shift (get-default-shortcut-prefix))]) 4430 (when (custodian-memory-accounting-available?) 4431 (new menu-item% 4432 [label (string-constant limit-memory-menu-item-label)] 4433 [parent language-specific-menu] 4434 [callback 4435 (λ (item b) 4436 (let ([num (get-mbytes this 4437 (let ([limit (send interactions-text get-custodian-limit)]) 4438 (and limit 4439 (floor (/ limit 1024 1024)))))]) 4440 (when num 4441 (cond 4442 [(equal? num #t) 4443 (preferences:set 'drracket:child-only-memory-limit #f) 4444 (send interactions-text set-custodian-limit #f)] 4445 [else 4446 (preferences:set 'drracket:child-only-memory-limit 4447 (* 1024 1024 num)) 4448 (send interactions-text set-custodian-limit 4449 (* 1024 1024 num))]))))])) 4450 4451 (new menu:can-restore-menu-item% 4452 (label (string-constant clear-error-highlight-menu-item-label)) 4453 (parent language-specific-menu) 4454 (callback 4455 (λ (_1 _2) 4456 (let* ([tab (get-current-tab)] 4457 [ints (send tab get-ints)] 4458 [defs (send tab get-defs)]) 4459 (send ints reset-error-ranges) 4460 (send defs clear-test-coverage)))) 4461 (help-string (string-constant clear-error-highlight-item-help-string)) 4462 (demand-callback 4463 (λ (item) 4464 (let* ([tab (get-current-tab)] 4465 [ints (send tab get-ints)]) 4466 (send item enable (or (send ints get-error-ranges) 4467 (send tab get-test-coverage-info-visible?))))))) 4468 4469 (new menu:can-restore-menu-item% 4470 (label (string-constant jump-to-next-error-highlight-menu-item-label)) 4471 (parent language-specific-menu) 4472 (shortcut #\.) 4473 (callback (λ (_1 _2) (jump-to-next-error-loc))) 4474 (demand-callback 4475 (λ (item) 4476 (let* ([tab (get-current-tab)] 4477 [ints (send tab get-ints)]) 4478 (send item enable (send ints get-error-ranges)))))) 4479 (new menu:can-restore-menu-item% 4480 (label (string-constant jump-to-prev-error-highlight-menu-item-label)) 4481 (parent language-specific-menu) 4482 (shortcut (if (equal? (system-type) 'macosx) #\. #\,)) 4483 (shortcut-prefix (if (equal? (system-type) 'macosx) 4484 (cons 'shift (get-default-shortcut-prefix)) 4485 (get-default-shortcut-prefix))) 4486 (callback (λ (_1 _2) (jump-to-previous-error-loc))) 4487 (demand-callback 4488 (λ (item) 4489 (let* ([tab (get-current-tab)] 4490 [ints (send tab get-ints)]) 4491 (send item enable (send ints get-error-ranges)))))) 4492 (make-object separator-menu-item% language-specific-menu) 4493 (make-object menu:can-restore-menu-item% 4494 (string-constant create-executable-menu-item-label) 4495 language-specific-menu 4496 (λ (x y) (create-executable this))) 4497 (make-object menu:can-restore-menu-item% 4498 (string-constant module-browser...) 4499 language-specific-menu 4500 (λ (x y) (drracket:module-overview:module-overview this))) 4501 (let () 4502 (define (update-menu-item i) 4503 (define fn (send definitions-text get-filename)) 4504 (define lab-str (compute-label-string fn)) 4505 (send i set-label lab-str) 4506 (send i enable fn)) 4507 (define i (new menu:can-restore-menu-item% 4508 [label ""] 4509 [parent language-specific-menu] 4510 [demand-callback update-menu-item] 4511 [callback (λ (x y) 4512 (define fn (send definitions-text get-filename)) 4513 (when fn 4514 (drracket:module-overview:module-overview/file fn this)))])) 4515 (update-menu-item i)) 4516 (make-object separator-menu-item% language-specific-menu) 4517 4518 (let ([cap-val 4519 (λ () 4520 (define tab (get-current-tab)) 4521 (define defs (send tab get-defs)) 4522 (define settings (send defs get-next-settings)) 4523 (define language 4524 (drracket:language-configuration:language-settings-language settings)) 4525 (send language capability-value 'drscheme:tabify-menu-callback))]) 4526 (new menu:can-restore-menu-item% 4527 [label (string-constant reindent-menu-item-label)] 4528 [parent language-specific-menu] 4529 [demand-callback (λ (m) (send m enable (cap-val)))] 4530 [callback (send-method 4531 (λ (x) 4532 (let ([f (cap-val)]) 4533 (when f 4534 (f x 4535 (send x get-start-position) 4536 (send x get-end-position))))))]) 4537 4538 (new menu:can-restore-menu-item% 4539 [label (string-constant reindent-all-menu-item-label)] 4540 [parent language-specific-menu] 4541 [callback 4542 (send-method 4543 (λ (x) 4544 (let ([f (cap-val)]) 4545 (when f 4546 (f x 0 (send x last-position))))))] 4547 [shortcut #\i] 4548 [demand-callback (λ (m) (send m enable (cap-val)))])) 4549 4550 (make-object menu:can-restore-menu-item% 4551 (string-constant box-comment-out-menu-item-label) 4552 language-specific-menu 4553 (send-method (λ (x) (send x box-comment-out-selection)))) 4554 (make-object menu:can-restore-menu-item% 4555 (string-constant semicolon-comment-out-menu-item-label) 4556 language-specific-menu 4557 (send-method (λ (x) (send x comment-out-selection)))) 4558 (make-object menu:can-restore-menu-item% 4559 (string-constant uncomment-menu-item-label) 4560 language-specific-menu 4561 (λ (x y) 4562 (let ([text (get-focus-object)]) 4563 (when (is-a? text text%) 4564 (let ([admin (send text get-admin)]) 4565 (cond 4566 [(is-a? admin editor-snip-editor-admin<%>) 4567 (let ([es (send admin get-snip)]) 4568 (cond 4569 [(is-a? es comment-box:snip%) 4570 (let ([es-admin (send es get-admin)]) 4571 (when es-admin 4572 (let ([ed (send es-admin get-editor)]) 4573 (when (is-a? ed racket:text<%>) 4574 (send ed uncomment-box/selection)))))] 4575 [else (send text uncomment-selection)]))] 4576 [else (send text uncomment-selection)])))))) 4577 4578 (set! insert-menu 4579 (new (get-menu%) 4580 [label (string-constant insert-menu)] 4581 [parent mb] 4582 [demand-callback 4583 (λ (insert-menu) 4584 ;; just here for convience -- it actually 4585 ;; works on all menus, not just the special menu 4586 (show/hide-capability-menus))])) 4587 4588 (let ([has-editor-on-demand 4589 (λ (menu-item) 4590 (let ([edit (get-edit-target-object)]) 4591 (send menu-item enable (and edit (is-a? edit editor<%>)))))] 4592 [callback 4593 (λ (menu evt) 4594 (let ([edit (get-edit-target-object)]) 4595 (when (and edit 4596 (is-a? edit editor<%>)) 4597 (let ([number (get-fraction-from-user this)]) 4598 (when number 4599 (send edit insert 4600 (number-snip:make-fraction-snip number #f))))) 4601 #t))] 4602 [insert-lambda 4603 (λ () 4604 (let ([edit (get-edit-target-object)]) 4605 (when (and edit 4606 (is-a? edit editor<%>)) 4607 (send edit insert "\u03BB"))) 4608 #t)] 4609 [insert-large-semicolon-letters 4610 (λ () 4611 (let ([edit (get-edit-target-object)]) 4612 (when edit 4613 (define language-settings (send definitions-text get-next-settings)) 4614 (define-values(comment-prefix comment-character) 4615 (if language-settings 4616 (send (drracket:language-configuration:language-settings-language 4617 language-settings) 4618 get-comment-character) 4619 (values ";" #\;))) 4620 (insert-large-letters comment-prefix comment-character edit this))))] 4621 [c% (get-menu-item%)]) 4622 4623 (frame:add-snip-menu-items 4624 insert-menu 4625 c% 4626 (λ (item) 4627 (let ([label (send item get-label)]) 4628 (cond 4629 [(equal? label (string-constant insert-comment-box-menu-item-label)) 4630 (register-capability-menu-item 'drscheme:special:insert-comment-box insert-menu)] 4631 [(equal? label (string-constant insert-image-item)) 4632 (register-capability-menu-item 'drscheme:special:insert-image insert-menu)])))) 4633 4634 (make-object c% (string-constant insert-fraction-menu-item-label) 4635 insert-menu callback 4636 #f #f 4637 has-editor-on-demand) 4638 (register-capability-menu-item 'drscheme:special:insert-fraction insert-menu) 4639 4640 (make-object c% (string-constant insert-large-letters...) 4641 insert-menu 4642 (λ (x y) (insert-large-semicolon-letters)) 4643 #f #f 4644 has-editor-on-demand) 4645 (register-capability-menu-item 'drscheme:special:insert-large-letters insert-menu) 4646 4647 (make-object c% (string-constant insert-lambda) 4648 insert-menu 4649 (λ (x y) (insert-lambda)) 4650 #\\ 4651 #f 4652 has-editor-on-demand) 4653 (register-capability-menu-item 'drscheme:special:insert-lambda insert-menu)) 4654 4655 (frame:reorder-menus this)) 4656 4657 (define/public (jump-to-previous-error-loc) 4658 (define-values (before after sorted) (find-before-and-after)) 4659 (unless (null? sorted) 4660 (jump-to-source-loc (or before (last sorted))))) 4661 4662 (define/public (jump-to-next-error-loc) 4663 (define-values (before after sorted) (find-before-and-after)) 4664 (unless (null? sorted) 4665 (jump-to-source-loc (or after (car sorted))))) 4666 4667 (define/private (find-before-and-after) 4668 (define tab (get-current-tab)) 4669 (define pos (send (send tab get-defs) get-start-position)) 4670 (define ranges (or (send (send tab get-ints) get-error-ranges) '())) 4671 (define sorted (sort ranges < #:key srcloc-position)) 4672 (let loop ([before #f] 4673 [lst sorted]) 4674 (cond 4675 [(null? lst) 4676 (values before #f sorted)] 4677 [else 4678 (define fst (car lst)) 4679 (cond 4680 [(= pos (- (srcloc-position fst) 1)) 4681 (values before 4682 (if (null? (cdr lst)) 4683 #f 4684 (cadr lst)) 4685 sorted)] 4686 [(< pos (- (srcloc-position fst) 1)) 4687 (values before fst sorted)] 4688 [else (loop (car lst) (cdr lst))])]))) 4689 4690 (define/private (jump-to-source-loc srcloc) 4691 (define ed (srcloc-source srcloc)) 4692 (send ed set-position (- (srcloc-position srcloc) 1)) 4693 (send ed set-caret-owner #f 'global) 4694 (send (get-interactions-text) highlight-a-single-error srcloc)) 4695 4696 (define/public (move-to-interactions) 4697 (ensure-rep-shown (get-interactions-text)) 4698 (send (get-interactions-canvas) focus)) 4699 4700 4701 ; 4702 ; 4703 ; 4704 ; 4705 ; ++-@@- -+@+- +++: :++ 4706 ; +@@-+@ -@-:-@--@- -@ 4707 ; :@: @: @+ ++ @::@::@ 4708 ; :@ @: @@@@@@@ +--@--* 4709 ; :@ @: @- -@+*+@: 4710 ; -@: :@- +@:::+@ :@@:@@ 4711 ; @@@ +@@: +@@@+: ++ ++ 4712 ; 4713 ; 4714 ; 4715 4716 (define definitions-text (new (drracket:get/extend:get-definitions-text))) 4717 4718 ;; tabs : (listof tab) 4719 (define tabs (list (new (drracket:get/extend:get-tab) 4720 (defs definitions-text) 4721 (frame this) 4722 (i 0) 4723 (defs-shown? #t) 4724 (ints-shown? #t)))) 4725 (define/public-final (get-tabs) tabs) 4726 4727 ;; current-tab : tab 4728 ;; corresponds to the tabs-panel's active button. 4729 (define current-tab (car tabs)) 4730 4731 (define interactions-text (new (drracket:get/extend:get-interactions-text) 4732 (context (car tabs)))) 4733 (send (car tabs) set-ints interactions-text) 4734 4735 (init-definitions-text (car tabs)) 4736 4737 (define/override (adjust-size-when-monitor-setup-changes?) 4738 (= 1 (for/sum ([f (in-list (get-top-level-windows))]) 4739 (if (is-a? f drracket:unit:frame<%>) 4740 1 4741 0)))) 4742 4743 (define/override (find-editor predicate) 4744 (or (findf predicate (map (lambda (tab) (send tab get-defs)) 4745 tabs)) 4746 (findf predicate (map (lambda (tab) (send tab get-ints)) 4747 tabs)))) 4748 4749 (super-new 4750 [filename filename] 4751 [style '(toolbar-button fullscreen-button)] 4752 [size-preferences-key 'drracket:window-size] 4753 [position-preferences-key 'drracket:window-position]) 4754 4755 (initialize-menus) 4756 4757 4758 ; 4759 ; 4760 ; 4761 ; ; ; 4762 ; ; ; 4763 ; ; ; ; 4764 ; ; ;; ;;; ; ;; ;;; ; ; ;;; ; ; ;;; ; ; ;;;; 4765 ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 4766 ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 4767 ; ; ; ;;;; ; ; ;;;;;; ; ; ;;;; ; ; ; ; ; ; ; 4768 ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 4769 ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; 4770 ; ; ;; ;;;;; ; ; ;;;; ; ; ;;;;; ; ;;; ;; ; ;; 4771 ; ; ; 4772 ; ; ; 4773 ; ; ; 4774 4775 4776 (define toolbar/rest-panel (new-vertical-panel% [parent (get-area-container)])) 4777 4778 ;; most contain only top-panel (or nothing) 4779 (define top-outer-panel (new horizontal-pane% 4780 [parent toolbar/rest-panel] 4781 [alignment '(right top)] 4782 [stretchable-height #f])) 4783 4784 [define top-panel (make-object horizontal-panel% top-outer-panel)] 4785 [define name-panel (new-horizontal-panel% 4786 (parent top-panel) 4787 (alignment '(left center)) 4788 (stretchable-width #f) 4789 (stretchable-height #f))] 4790 (define panel-with-tabs (new vertical-pane% 4791 (parent (get-definitions/interactions-panel-parent)))) 4792 (define tabs-panel (new 4793 (class tab-panel% 4794 (define/override (on-close-request i) 4795 (close-ith-tab i)) 4796 (define/augment (on-reorder former-indicies) 4797 (reorder-tabs former-indicies)) 4798 (super-new 4799 (font small-control-font) 4800 (parent panel-with-tabs) 4801 (stretchable-height #f) 4802 (style '(deleted no-border can-reorder can-close)) 4803 (choices '("first name")) 4804 (callback (λ (x y) 4805 (define sel (send tabs-panel get-selection)) 4806 (when sel 4807 (change-to-nth-tab sel)))))))) 4808 (set! resizable-panel (new (if (preferences:get 'drracket:defs/ints-horizontal) 4809 horizontal-dragable/def-int% 4810 vertical-dragable/def-int%) 4811 (unit-frame this) 4812 (parent panel-with-tabs))) 4813 4814 [set! definitions-canvas #f] 4815 (initialize-definitions-canvas) 4816 (set! definitions-canvases (list definitions-canvas)) 4817 4818 (set! interactions-canvas (new (drracket:get/extend:get-interactions-canvas) 4819 (parent resizable-panel) 4820 (editor interactions-text))) 4821 (set! interactions-canvases (list interactions-canvas)) 4822 4823 4824 (define/public (get-definitions-canvases) 4825 ;; before definition, just return null 4826 (if (pair? definitions-canvases) 4827 definitions-canvases 4828 null)) 4829 (define/public (get-interactions-canvases) 4830 ;; before definition, just return null 4831 (if (pair? interactions-canvases) 4832 interactions-canvases 4833 null)) 4834 4835 (define/public (get-definitions-canvas) definitions-canvas) 4836 (define/public (get-interactions-canvas) interactions-canvas) 4837 4838 (set! save-button 4839 (new switchable-button% 4840 [parent top-panel] 4841 [callback (λ (x) (when definitions-text 4842 (save) 4843 (send definitions-canvas focus)))] 4844 [bitmap save-bitmap] 4845 [alternate-bitmap small-save-bitmap] 4846 [label (string-constant save-button-label)])) 4847 (register-toolbar-button save-button) 4848 4849 (set! name-message (new drs-name-message% [parent name-panel])) 4850 (send name-message stretchable-width #t) 4851 (send name-message set-allow-shrinking 160) 4852 [define teachpack-items null] 4853 [define break-button (void)] 4854 [define execute-button (void)] 4855 (set! button-panel (new panel:horizontal-discrete-sizes% 4856 [parent top-panel] 4857 [stretchable-width #t] 4858 [alignment '(right center)])) 4859 (define/public (get-execute-button) execute-button) 4860 (define/public (get-break-button) break-button) 4861 (define/public (get-button-panel) button-panel) 4862 4863 ;; #t => "break"; #f => "kill" in button label 4864 (define showing-break? #t) 4865 (define/public (update-kill-button-label) 4866 (unless (equal? showing-break? (not (send (get-current-tab) does-break-kill?))) 4867 (set! showing-break? (not (send (get-current-tab) does-break-kill?))) 4868 (send break-button set-label (if showing-break? 4869 (string-constant break-button-label) 4870 (string-constant break-button-kill-label))))) 4871 4872 (inherit get-info-panel) 4873 4874 (define color-status-canvas 4875 (let () 4876 (define on-string "()") 4877 (define color-status-canvas 4878 (new canvas% 4879 [parent (get-info-panel)] 4880 [style '(transparent)] 4881 [stretchable-width #f] 4882 [paint-callback 4883 (λ (c dc) 4884 (when (number? th) 4885 (unless color-valid? 4886 (define-values (cw ch) (send c get-client-size)) 4887 (send dc set-text-foreground (get-label-foreground-color)) 4888 (send dc set-font small-control-font) 4889 (send dc draw-text on-string 0 (- (/ ch 2) (/ th 2))))))])) 4890 (define-values (tw th ta td) 4891 (send (send color-status-canvas get-dc) get-text-extent 4892 on-string small-control-font)) 4893 (send color-status-canvas min-width (inexact->exact (ceiling tw))) 4894 color-status-canvas)) 4895 (define color-valid? #t) 4896 (define/public (set-color-status! v?) 4897 (when color-status-canvas 4898 (set! color-valid? v?) 4899 (send color-status-canvas refresh-now))) 4900 4901 (define running-canvas 4902 (new running-canvas% [parent (get-info-panel)])) 4903 4904 (define bug-icon 4905 (let* ([info-panel (get-info-panel)] 4906 [btn 4907 (new switchable-button% 4908 [parent info-panel] 4909 [callback (λ (x) (show-saved-bug-reports-window))] 4910 [bitmap very-small-planet-bitmap] 4911 [vertical-tight? #t] 4912 [label (string-constant show-planet-contract-violations)])]) 4913 (send btn set-label-visible #f) 4914 (send info-panel change-children 4915 (λ (l) 4916 (cons btn (remq* (list btn) l)))) 4917 btn)) 4918 (define/private (set-bug-label v) 4919 (if (null? v) 4920 (send bug-icon show #f) 4921 (send bug-icon show #t))) 4922 (set-bug-label (preferences:get 'drracket:saved-bug-reports)) 4923 (define remove-bug-icon-callback 4924 (preferences:add-callback 4925 'drracket:saved-bug-reports 4926 (λ (p v) 4927 (set-bug-label v)))) 4928 4929 [define func-defs-canvas (new func-defs-canvas% 4930 (parent name-panel) 4931 (frame this))] 4932 4933 (set! execute-button 4934 (new switchable-button% 4935 [parent button-panel] 4936 [callback (λ (x) (execute-callback))] 4937 [bitmap execute-bitmap] 4938 [label (string-constant execute-button-label)])) 4939 (register-toolbar-button execute-button #:number 100) 4940 4941 (set! break-button 4942 (new switchable-button% 4943 [parent button-panel] 4944 [callback (λ (x) (send current-tab break-callback))] 4945 [bitmap break-bitmap] 4946 [label (string-constant break-button-label)])) 4947 (register-toolbar-button break-button #:number 101) 4948 4949 (send top-panel change-children 4950 (λ (l) 4951 (list name-panel save-button button-panel))) 4952 4953 (send top-panel stretchable-height #f) 4954 (inherit get-label) 4955 (let ([m (send definitions-canvas get-editor)]) 4956 (set-save-init-shown? 4957 (and m (send m is-modified?)))) 4958 4959 (define language-message 4960 (let* ([info-panel (get-info-panel)] 4961 [p (new-vertical-panel% 4962 [parent info-panel] 4963 [alignment '(left center)])] 4964 [language-message (new language-label-message% [parent p] [frame this])]) 4965 (send info-panel change-children 4966 (λ (l) 4967 (list* p 4968 (remq* (list p) 4969 l)))) 4970 language-message)) 4971 4972 (update-save-message) 4973 (update-save-button) 4974 (language-changed) 4975 4976 (cond 4977 [filename 4978 (set! definitions-shown? #t) 4979 (set! interactions-shown? #f)] 4980 [else 4981 (set! definitions-shown? #t) 4982 (set! interactions-shown? #t)]) 4983 4984 (update-shown) 4985 4986 (when (= 2 (length (send resizable-panel get-children))) 4987 (send resizable-panel set-percentages 4988 (let ([p (preferences:get 'drracket:unit-window-size-percentage)]) 4989 (list p (- 1 p))))) 4990 4991 (set-label-prefix (string-constant drscheme)) 4992 (set! newest-frame this) 4993 ;; a callback might have happened that initializes set-color-status! before the 4994 ;; definitions text is connected to the frame, so we do an extra initialization 4995 ;; now, once we know we have the right connection 4996 (set-color-status! (send definitions-text is-lexer-valid?)) 4997 (send definitions-canvas focus) 4998 (send definitions-text enable-top-level-window-connection))) 4999 5000 (define (get-define-popup-name infos vertical?) 5001 (cond 5002 [infos 5003 (define hidden-prefixes (preferences:get 'drracket:define-popup-hidden-prefixes)) 5004 (define visible-infos 5005 (for/list ([info (in-list infos)] 5006 #:unless (member (define-popup-info-long-name info) 5007 hidden-prefixes)) 5008 info)) 5009 (define the-info (if (null? visible-infos) (car infos) (car visible-infos))) 5010 (if vertical? 5011 (define-popup-info-short-name the-info) 5012 (define-popup-info-long-name the-info))] 5013 [else 5014 #f])) 5015 5016 5017 (define execute-warning-canvas% 5018 (class canvas% 5019 (inherit stretchable-height get-dc get-client-size min-height) 5020 (init-field message) 5021 (define/public (set-message _msg) (set! message _msg)) 5022 5023 (define/override (on-paint) 5024 (let ([dc (get-dc)]) 5025 (let-values ([(w h) (get-client-size)]) 5026 (send dc set-pen "yellow" 1 'solid) 5027 (send dc set-brush "yellow" 'solid) 5028 (send dc draw-rectangle 0 0 w h) 5029 (when message 5030 (let* ([base normal-control-font] 5031 [face (send base get-face)]) 5032 (if face 5033 (send dc set-font (send the-font-list find-or-create-font 5034 (send base get-point-size) 5035 face 5036 (send base get-family) 5037 (send base get-style) 5038 'bold)) 5039 (send dc set-font (send the-font-list find-or-create-font 5040 (send base get-point-size) 5041 (send base get-family) 5042 (send base get-style) 5043 'bold)))) 5044 (let-values ([(tw th _1 _2) (send dc get-text-extent message)]) 5045 (send dc draw-text message 5046 (floor (- (/ w 2) (/ tw 2))) 5047 (floor (- (/ h 2) (/ th 2))))))))) 5048 (super-new [style '(no-focus)]) 5049 (let-values ([(w h d a) (send (get-dc) get-text-extent "Xy")]) 5050 (min-height (+ 4 (floor (inexact->exact h))))))) 5051 5052 5053 ; 5054 ; 5055 ; 5056 ; 5057 ; ;;; 5058 ; 5059 ; ;;; ;;;; ;;; ;;; ;; ;;; ;; ;;; ;;; ;; ;; ;;; 5060 ; ;;;;;;;; ;;; ;;;;;;; ;;;;;;; ;;; ;;;;;;; ;;;;;;; 5061 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 5062 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 5063 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 5064 ; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; 5065 ; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; 5066 ; ;;; 5067 ; ;;;;;; 5068 ; 5069 ; 5070 5071 (define running-canvas% 5072 (class canvas% 5073 (inherit get-dc refresh get-client-size) 5074 5075 (define running-frame-delay 200) ; 5 FPS at the most (if user program is blocked or waiting) 5076 (define num-running-frames (vector-length running-frames)) 5077 (define is-running? #f) 5078 (define frame 0) 5079 (define timer (make-object logging-timer% (λ () (refresh) (yield)) #f)) 5080 5081 (define/public (set-running r?) 5082 (cond [r? (unless is-running? (set! frame 4)) 5083 (send timer start running-frame-delay #f)] 5084 [else (send timer stop) 5085 (refresh)]) 5086 (set! is-running? r?)) 5087 5088 (define/override (on-paint) 5089 (define dc (get-dc)) 5090 (define bm (cond [is-running? (define bm (vector-ref running-frames frame)) 5091 (set! frame (modulo (+ frame 1) num-running-frames)) 5092 bm] 5093 [else standing-frame])) 5094 (define-values (w h) (get-client-size)) 5095 (send dc draw-bitmap bm 5096 (- (/ w 2) (/ (send bm get-width) 2)) 5097 (- (/ h 2) (/ (send bm get-height) 2)))) 5098 5099 (super-new [stretchable-width #f] 5100 [stretchable-height #f] 5101 [style '(transparent no-focus)]) 5102 5103 (inherit min-width min-height) 5104 5105 (define all-running-frames (cons standing-frame running-frame-list)) 5106 (min-width (apply max (map (λ (x) (send x get-width)) all-running-frames))) 5107 (min-height (apply max (map (λ (x) (send x get-height)) all-running-frames))))) 5108 5109 ;; get-mbytes : top-level-window -> (union #f ;; cancel 5110 ;; integer[>=100] ;; a limit 5111 ;; #t) ;; no limit 5112 (define (get-mbytes parent current-limit) 5113 (define d (new dialog% 5114 [label (string-constant drscheme)] 5115 [parent parent])) 5116 (define msg1 (new message% 5117 [parent d] 5118 [label (string-constant limit-memory-msg-1)])) 5119 (define msg1.5 (new message% 5120 [parent d] 5121 [label (string-constant limit-memory-msg-2)])) 5122 5123 (define top-hp (new-horizontal-panel% 5124 [parent d] 5125 [stretchable-height #f] 5126 [alignment '(left center)])) 5127 (define bot-hp (new-horizontal-panel% 5128 [parent d] 5129 [stretchable-height #f] 5130 [alignment '(left bottom)])) 5131 (define limited-rb 5132 (new radio-box% 5133 [label #f] 5134 [choices (list (string-constant limit-memory-limited))] 5135 [callback (λ (a b) 5136 (send unlimited-rb set-selection #f) 5137 (cb-checked))] 5138 [parent top-hp])) 5139 (define unlimited-rb 5140 (new radio-box% 5141 [label #f] 5142 [choices (list (string-constant limit-memory-unlimited))] 5143 [callback (λ (a b) 5144 (send limited-rb set-selection #f) 5145 (cb-checked))] 5146 [parent bot-hp])) 5147 5148 (define unlimited-warning-panel (new-horizontal-panel% 5149 [parent d] 5150 [stretchable-width #t] 5151 [stretchable-height #f])) 5152 5153 (define (show-unlimited-warning) 5154 (when (null? (send unlimited-warning-panel get-children)) 5155 (send d begin-container-sequence) 5156 (define t (new text%)) 5157 (send t insert (string-constant limit-memory-warning-prefix)) 5158 (define between-pos (send t last-position)) 5159 (send t insert (string-constant limit-memory-warning)) 5160 5161 (define sdb (make-object style-delta% 'change-family 'system)) 5162 (send sdb set-delta-face (send normal-control-font get-face)) 5163 (send sdb set-size-mult 0) 5164 (send sdb set-size-add (send normal-control-font get-point-size)) 5165 (send sdb set-size-in-pixels-off #t) 5166 (send sdb set-weight-on 'bold) 5167 (when (white-on-black-panel-scheme?) 5168 (send sdb set-delta-foreground "white")) 5169 (define sd (make-object style-delta%)) 5170 (send sd copy sdb) 5171 (send sd set-weight-on 'normal) 5172 5173 (send t change-style sdb 0 between-pos) 5174 (send t change-style sd between-pos (send t last-position)) 5175 (define ec (new editor-canvas% 5176 [editor t] 5177 [parent unlimited-warning-panel] 5178 [style '(no-border no-focus hide-hscroll hide-vscroll transparent)] 5179 [horiz-margin 12])) 5180 (send t auto-wrap #t) 5181 (send d reflow-container) 5182 (send ec set-line-count (+ 1 (send t position-line (send t last-position)))) 5183 (send t hide-caret #t) 5184 (send t lock #t) 5185 (send d end-container-sequence) 5186 (send unlimited-rb focus))) 5187 5188 (define (cb-checked) 5189 (cond 5190 [(send limited-rb get-selection) 5191 (send tb enable #t) 5192 (send msg2 enable #t) 5193 (background black-foreground-sd) 5194 (let ([e (send tb get-editor)]) 5195 (send e set-position 0 (send e last-position))) 5196 (send tb focus)] 5197 [else 5198 (show-unlimited-warning) 5199 (send tb enable #f) 5200 (send msg2 enable #f) 5201 (background gray-foreground-sd)]) 5202 (update-ok-button-state)) 5203 5204 (define tb 5205 (keymap:call/text-keymap-initializer 5206 (λ () 5207 (new text-field% 5208 [label #f] 5209 [parent top-hp] 5210 [init-value (if current-limit 5211 (format "~a" current-limit) 5212 "128")] 5213 [stretchable-width #f] 5214 [min-width 100] 5215 [callback 5216 (λ (tf e) 5217 (let ([ed (send tf get-editor)]) 5218 (cond 5219 [(is-valid-number? ed) 5220 (background clear-sd)] 5221 [else 5222 (background yellow-sd)])) 5223 (update-ok-button-state))])))) 5224 5225 (define (update-ok-button-state) 5226 (cond 5227 [(send limited-rb get-selection) 5228 (send ok-button enable (is-valid-number? (send tb get-editor)))] 5229 [else 5230 (send ok-button enable #t)])) 5231 5232 (define msg2 (new message% [parent top-hp] [label (string-constant limit-memory-megabytes)])) 5233 (define bp (new-horizontal-panel% [parent d])) 5234 (define-values (ok-button cancel-button) 5235 (gui-utils:ok/cancel-buttons 5236 bp 5237 (λ (a b) 5238 (cond 5239 [(send limited-rb get-selection) 5240 (set! result (string->number (send (send tb get-editor) get-text)))] 5241 [else 5242 (set! result #t)]) 5243 (send d show #f)) 5244 (λ (a b) (send d show #f)))) 5245 5246 (define result #f) 5247 5248 (define clear-sd (make-object style-delta%)) 5249 (define yellow-sd (make-object style-delta%)) 5250 5251 (define black-foreground-sd (make-object style-delta%)) 5252 (define gray-foreground-sd (make-object style-delta%)) 5253 5254 (define (is-valid-number? txt) 5255 (let* ([n (string->number (send txt get-text))]) 5256 (and n 5257 (exact-positive-integer? n) 5258 (8 . <= . n)))) 5259 5260 (define (background sd) 5261 (let ([txt (send tb get-editor)]) 5262 (send txt change-style sd 0 (send txt last-position)))) 5263 5264 (send clear-sd set-delta-background 5265 (if (white-on-black-panel-scheme?) "black" "white")) 5266 (send yellow-sd set-delta-background "yellow") 5267 (send black-foreground-sd set-delta-foreground 5268 (if (white-on-black-panel-scheme?) "white" "black")) 5269 (send gray-foreground-sd set-delta-foreground "gray") 5270 (send d set-alignment 'left 'center) 5271 (send bp set-alignment 'right 'center) 5272 (cond 5273 [current-limit 5274 (send limited-rb set-selection 0) 5275 (send unlimited-rb set-selection #f)] 5276 [else 5277 (send unlimited-rb set-selection 0) 5278 (send limited-rb set-selection #f)]) 5279 (update-ok-button-state) 5280 (cb-checked) 5281 (let ([e (send tb get-editor)]) 5282 (send e set-position 0 (send e last-position))) 5283 (cond 5284 [current-limit (send tb focus)] 5285 [else (send unlimited-rb focus)]) 5286 (send d show #t) 5287 result) 5288 5289 (define (limit-length l n) 5290 (let loop ([l l] 5291 [n n]) 5292 (cond 5293 [(or (null? l) (zero? n)) null] 5294 [else (cons (car l) (loop (cdr l) (- n 1)))]))) 5295 (define (remove-duplicate-languages l) 5296 (reverse 5297 (let loop ([l (reverse l)]) 5298 (cond 5299 [(null? l) l] 5300 [else 5301 (if (member (car (car l)) (map car (cdr l))) 5302 (loop (cdr l)) 5303 (cons (car l) (loop (cdr l))))])))) 5304 5305 (define language-label-message% 5306 (class name-message% 5307 (init-field frame) 5308 (inherit refresh) 5309 5310 (inherit set-message) 5311 (define yellow? #f) 5312 (define/override (get-background-color) 5313 (and yellow? 5314 (color-prefs:lookup-in-color-scheme 5315 'framework:warning-background-color))) 5316 (define/public (set-yellow y?) 5317 (set! yellow? y?) 5318 (refresh)) 5319 (define/public (set-yellow/lang y? lang) 5320 (set-message #f lang) 5321 (set-yellow y?)) 5322 5323 (define/override (fill-popup menu reset) 5324 (let ([added-one? #f]) 5325 (send (new menu-item% 5326 [label (string-constant recent-languages)] 5327 [callback void] 5328 [parent menu]) 5329 enable #f) 5330 (for-each 5331 (λ (name/settings) 5332 (let* ([name (car name/settings)] 5333 [marshalled-settings (cdr name/settings)] 5334 [lang (ormap 5335 (λ (l) (and (equal? (send l get-language-name) name) l)) 5336 (drracket:language-configuration:get-languages))]) 5337 (when lang 5338 ;; this test can fail when a language has been added wrongly via the tools interface 5339 ;; just ignore that menu item, in that case. 5340 (let ([settings (or (send lang unmarshall-settings marshalled-settings) 5341 (send lang default-settings))]) 5342 (when lang 5343 (set! added-one? #t) 5344 (new menu-item% 5345 [parent menu] 5346 [label (send lang get-language-name)] 5347 [callback 5348 (λ (x y) 5349 (send (send frame get-definitions-text) 5350 set-next-settings 5351 (drracket:language-configuration:language-settings 5352 lang 5353 settings)))])))))) 5354 (preferences:get 'drracket:recent-language-names)) 5355 (unless added-one? 5356 (send (new menu-item% 5357 [label (string-append 5358 " << " 5359 (string-constant no-recently-chosen-languages) 5360 " >>")] 5361 [parent menu] 5362 [callback void]) 5363 enable #f)) 5364 (new separator-menu-item% [parent menu])) 5365 (new menu-item% 5366 [label (string-constant choose-language-menu-item-label)] 5367 [parent menu] 5368 [callback 5369 (λ (x y) 5370 (send frame choose-language-callback))])) 5371 5372 (super-new [label ""] 5373 [font small-control-font] 5374 [string-constant-untitled (string-constant untitled)] 5375 [string-constant-no-full-name-since-not-saved 5376 (string-constant no-full-name-since-not-saved)]) 5377 5378 (inherit set-allow-shrinking) 5379 (set-allow-shrinking 50))) 5380 5381 5382 5383 ; 5384 ; 5385 ; 5386 ; 5387 ; ;;; ; 5388 ; ;;; ;;; 5389 ; ;;; ;; ;;; ;;; ;; ;;; ;;; ;; ;;;; ;;; ;; ;;; ;;; ;;;;; ;;;; 5390 ; ;;;;;;; ;;; ;;; ;;;;;;; ;;;;; ;; ;;; ;;;;;;; ;;;;; ;;;;;;;;; ;;; ;; 5391 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 5392 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; 5393 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 5394 ; ;;;;;;; ;;;;;;; ;;;;;;; ;;; ;;;;;; ;;;;;;; ;;;;; ;;; ;;;; ;; ;;; 5395 ; ;;; ;; ;; ;;; ;; ;;; ;;; ;;;; ;;; ;; ;;; ;;; ;;; ;;;; 5396 ; ;;; ;;; 5397 ; ;;;;;; ;;; 5398 ; 5399 ; 5400 5401 5402 ;; record-saved-bug-report : (listof (cons symbol string)) -> void 5403 ;; =Kernel= =Handler= 5404 (define (record-saved-bug-report table) 5405 (let ([recorded (preferences:get 'drracket:saved-bug-reports)]) 5406 (unless (member table recorded) 5407 (preferences:set 'drracket:saved-bug-reports (shorten-to (cons table recorded) 15))))) 5408 5409 ;; shorten-to : (listof X) number -> (listof X) 5410 ;; drops items from the end of the list to bring it back down to `n' items 5411 (define (shorten-to l n) 5412 (let loop ([l l] 5413 [n n]) 5414 (cond 5415 [(zero? n) '()] 5416 [(null? l) '()] 5417 [else (cons (car l) (loop (cdr l) (- n 1)))]))) 5418 5419 (define saved-bug-reports-window #f) 5420 (define saved-bug-reports-panel #f) 5421 (define (init-saved-bug-reports-window) 5422 (unless saved-bug-reports-window 5423 (let () 5424 (set! saved-bug-reports-window (new frame:basic% 5425 [label (string-constant drscheme)] 5426 [width 600])) 5427 (set! saved-bug-reports-panel 5428 (new-vertical-panel% [parent (send saved-bug-reports-window get-area-container)])) 5429 (define hp (new-horizontal-panel% 5430 [parent (send saved-bug-reports-window get-area-container)] 5431 [stretchable-width #f] 5432 [alignment '(right center)])) 5433 (define forget-all (new button% 5434 [label (string-constant bug-track-forget-all)] 5435 [callback 5436 (λ (_1 _2) 5437 (send saved-bug-reports-window show #f) 5438 (preferences:set 'drracket:saved-bug-reports '()))] 5439 [parent hp])) 5440 (void)))) 5441 5442 (preferences:add-callback 5443 'drracket:saved-bug-reports 5444 (λ (p v) 5445 (when saved-bug-reports-window 5446 (when (send saved-bug-reports-window is-shown?) 5447 (cond 5448 [(null? v) 5449 (send saved-bug-reports-window show #f)] 5450 [else 5451 (refresh-saved-bug-reports-window v)]))))) 5452 5453 (define (refresh-saved-bug-reports-window pref) 5454 (send saved-bug-reports-window begin-container-sequence) 5455 (send saved-bug-reports-panel change-children (λ (l) '())) 5456 (for-each 5457 (λ (item) 5458 (let () 5459 (define (lookup k [default ""]) 5460 (let loop ([item item]) 5461 (cond 5462 [(null? item) default] 5463 [else (let ([rib (car item)]) 5464 (if (eq? (car rib) k) 5465 (cdr rib) 5466 (loop (cdr item))))]))) 5467 (define vp 5468 (new-vertical-panel% 5469 [style '(border)] 5470 [parent saved-bug-reports-panel] 5471 [stretchable-height #f])) 5472 (define hp 5473 (new-horizontal-panel% 5474 [parent vp] 5475 [stretchable-height #f])) 5476 (define first-line-msg 5477 (let ([desc (lookup 'description #f)]) 5478 (and desc 5479 (new message% 5480 [label (read-line (open-input-string desc))] 5481 [parent vp] 5482 [stretchable-width #t] 5483 [font (send (send (editor:get-standard-style-list) find-named-style 5484 "Standard") 5485 get-font)])))) 5486 (define msg (new message% 5487 [stretchable-width #t] 5488 [label (string-append (lookup 'component "<<unknown component>>") 5489 (let ([v (lookup 'version #f)]) 5490 (if v 5491 (string-append " " v) 5492 "")))] 5493 [parent hp])) 5494 (define forget (new button% 5495 [parent hp] 5496 [callback (λ (x y) (forget-saved-bug-report item))] 5497 [label (string-constant bug-track-forget)])) 5498 (define report (new button% 5499 [parent hp] 5500 [callback (λ (x y) 5501 (forget-saved-bug-report item) 5502 (send-url 5503 (url->string 5504 (drracket:debug:bug-info->ticket-url item))))] 5505 [label (string-constant bug-track-report)])) 5506 (void))) 5507 pref) ;; reverse list so first elements end up on top of list 5508 (send saved-bug-reports-window reflow-container) 5509 (send saved-bug-reports-window end-container-sequence)) 5510 5511 (define (forget-saved-bug-report item) 5512 (preferences:set 'drracket:saved-bug-reports 5513 (remove item (preferences:get 'drracket:saved-bug-reports)))) 5514 5515 (define (show-saved-bug-reports-window) 5516 (init-saved-bug-reports-window) 5517 (unless (send saved-bug-reports-window is-shown?) 5518 (refresh-saved-bug-reports-window (preferences:get 'drracket:saved-bug-reports))) 5519 (send saved-bug-reports-window show #t)) 5520 5521 5522 5523 ; 5524 ; 5525 ; 5526 ; 5527 ; ;;;; ;; ; 5528 ; ;;; ; ; ; 5529 ; ;;;; ;;; ;;;;;;; ;;; ;; ;;; ;;;; ; ; ; 5530 ; ;;;; ;;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; ; ; ; 5531 ; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ;; 5532 ; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;; ; ; ; 5533 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ; ; ; 5534 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ; ; ; 5535 ; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;; ; ;; 5536 ; 5537 ; 5538 ; 5539 ; 5540 5541 5542 (define -frame% 5543 (drracket:module-language:module-language-online-expand-frame-mixin 5544 (frame-mixin 5545 (drracket:frame:mixin 5546 (drracket:frame:basics-mixin 5547 (frame:size-pref-mixin 5548 (frame:searchable-text-mixin 5549 (frame:searchable-mixin 5550 (frame:text-info-mixin 5551 (frame:status-line-mixin 5552 (frame:info-mixin 5553 (frame:text-mixin 5554 (frame:editor-mixin 5555 (frame:standard-menus-mixin 5556 (frame:register-group-mixin 5557 (frame:focus-table-mixin 5558 (frame:basic-mixin 5559 frame%))))))))))))))))) 5560 5561 (define-local-member-name enable-two-way-prefs) 5562 (define (make-two-way-prefs-dragable-panel% % pref-key) 5563 (class % 5564 (inherit get-percentages) 5565 5566 (define save-prefs? #f) 5567 (define/public (enable-two-way-prefs) (set! save-prefs? #t)) 5568 5569 (define/augment (after-percentage-change) 5570 (when save-prefs? 5571 (let ([percentages (get-percentages)]) 5572 (when (and (pair? percentages) 5573 (pair? (cdr percentages)) 5574 (null? (cddr percentages))) 5575 (preferences:set pref-key (car percentages))))) 5576 (inner (void) after-percentage-change)) 5577 (super-new))) 5578 5579 (define drs-name-message% 5580 (class name-message% 5581 (define/override (on-choose-directory dir) 5582 (let ([file (finder:get-file dir 5583 (string-constant select-file) 5584 #f 5585 "" 5586 (send this get-top-level-window))]) 5587 (when file 5588 (handler:edit-file file)))) 5589 (super-new 5590 [string-constant-untitled (string-constant untitled)] 5591 [string-constant-no-full-name-since-not-saved 5592 (string-constant no-full-name-since-not-saved)]))) 5593 5594 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5595 ;; 5596 ;; lambda-snipclass is for backwards compatibility 5597 ;; 5598 (define lambda-snipclass 5599 (make-object (class snip-class% 5600 (define/override (read p) (make-object string-snip% "λ")) 5601 (super-new)))) 5602 (send lambda-snipclass set-version 1) 5603 (send lambda-snipclass set-classname "drscheme:lambda-snip%") 5604 (send (get-the-snip-class-list) add lambda-snipclass) 5605 5606 (define newest-frame 'nothing-yet) 5607 5608 (define (open-drscheme-window [name #f] #:show? [show? #t]) 5609 (cond 5610 [(and newest-frame 5611 name 5612 (not (equal? newest-frame 'nothing-yet)) 5613 (send newest-frame still-untouched?)) 5614 (send newest-frame change-to-file name) 5615 (when show? (send newest-frame show #t)) 5616 (begin0 newest-frame 5617 (set! newest-frame #f))] 5618 [(and name ;; only open a tab if we have a filename 5619 (preferences:get 'drracket:open-in-tabs)) 5620 (define frs (send (group:get-the-frame-group) get-frames)) 5621 (let ([ac (send (group:get-the-frame-group) get-active-frame)]) 5622 (when (and ac (send ac is-shown?)) 5623 (set! frs (cons ac (remove ac frs))))) 5624 (define fr (let loop ([frs frs]) 5625 (cond 5626 [(null? frs) #f] 5627 [else (let ([fr (car frs)]) 5628 (or (and (is-a? fr drracket:unit:frame<%>) 5629 fr) 5630 (loop (cdr frs))))]))) 5631 (cond 5632 [fr 5633 (send fr open-in-new-tab name) 5634 (when show? (send fr show #t)) 5635 fr] 5636 [else 5637 (create-new-drscheme-frame name #:show? show?)])] 5638 [else 5639 (create-new-drscheme-frame name #:show? show?)])) 5640 5641 (define (create-new-drscheme-frame filename #:show? [show? #t]) 5642 (let* ([drs-frame% (drracket:get/extend:get-unit-frame)] 5643 [frame (new drs-frame% (filename filename))]) 5644 (send frame update-toolbar-visibility) 5645 (send frame initialize-module-language) 5646 (when show? (send frame show #t)) 5647 (send (send frame get-interactions-text) initialize-console) 5648 frame))) 5649 5650(define/contract (compute-label-string fn) 5651 (-> (or/c path? #f) label-string?) 5652 (cond 5653 [fn 5654 (define base-title (format (string-constant module-browser-in-file) "")) 5655 (define str (path->string fn)) 5656 (define limit (- 200 (string-length base-title))) 5657 (define str-to-use 5658 (if (<= (string-length str) limit) 5659 str 5660 (string-append "..." 5661 (substring str 5662 (+ (- (string-length str) limit) 3) 5663 (string-length str))))) 5664 (format (string-constant module-browser-in-file) str-to-use)] 5665 [else (string-constant module-browser-no-file)])) 5666 5667 5668;; is-lang-line? : string -> boolean 5669;; given the first line in the editor, this returns #t if it is a #lang line. 5670(define (is-lang-line? l) 5671 (let ([m (regexp-match #rx"^#(!|(lang ))([-+_/a-zA-Z0-9]+)(.|$)" l)]) 5672 (and m 5673 (let ([lang-name (list-ref m 3)] 5674 [last-char (list-ref m 4)]) 5675 (and (not (char=? #\/ (string-ref lang-name 0))) 5676 (not (char=? #\/ (string-ref lang-name (- (string-length lang-name) 1)))) 5677 (or (string=? "" last-char) 5678 (char-whitespace? (string-ref last-char 0)))))))) 5679 5680(module+ test 5681 (require rackunit) 5682 (check-equal? (compute-label-string (string->path "x")) 5683 (format (string-constant module-browser-in-file) "x")) 5684 (check-equal? (compute-label-string #f) 5685 (string-constant module-browser-no-file)) 5686 (check-equal? (string-length (compute-label-string (string->path (make-string 200 #\x)))) 5687 200) 5688 (for ([i (in-range 100 300)]) 5689 (let/ec k 5690 (parameterize ([error-escape-handler k]) 5691 (check-true (string? 5692 (compute-label-string 5693 (string->path (make-string i #\x)))))))) 5694 5695 5696 (check-true (is-lang-line? "#lang x")) 5697 (check-true (is-lang-line? "#lang racket")) 5698 (check-true (is-lang-line? "#lang racket ")) 5699 (check-false (is-lang-line? "#lang racketα")) 5700 (check-false (is-lang-line? "#lang racket/ ")) 5701 (check-false (is-lang-line? "#lang /racket ")) 5702 (check-true (is-lang-line? "#lang rac/ket ")) 5703 (check-true (is-lang-line? "#lang r6rs")) 5704 (check-true (is-lang-line? "#!r6rs")) 5705 (check-true (is-lang-line? "#!r6rs ")) 5706 (check-false (is-lang-line? "#!/bin/sh"))) 5707
