#| closing: warning messages don't have frame as parent..... tab panels new behavior: - save all tabs (pr 6689?) module browser threading seems wrong. |# (module unit scheme/base (require scheme/contract scheme/unit scheme/class scheme/path scheme/port scheme/list (only-in mzlib/etc compose) string-constants framework (lib "name-message.ss" "mrlib") (lib "bitmap-label.ss" "mrlib") (lib "include-bitmap.ss" "mrlib") "drsig.ss" "auto-language.ss" "insert-large-letters.ss" mrlib/switchable-button (prefix-in drscheme:arrow: "../arrow.ss") mred (prefix-in mred: mred) mzlib/date) (provide unit@) (define module-browser-progress-constant (string-constant module-browser-progress)) (define status-compiling-definitions (string-constant module-browser-compiling-defns)) (define show-lib-paths (string-constant module-browser-show-lib-paths/short)) (define show-planet-paths (string-constant module-browser-show-planet-paths/short)) (define refresh (string-constant module-browser-refresh)) (define-unit unit@ (import [prefix help-desk: drscheme:help-desk^] [prefix drscheme:app: drscheme:app^] [prefix drscheme:frame: drscheme:frame^] [prefix drscheme:text: drscheme:text^] [prefix drscheme:rep: drscheme:rep^] [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] [prefix drscheme:language: drscheme:language^] [prefix drscheme:get/extend: drscheme:get/extend^] [prefix drscheme:module-overview: drscheme:module-overview^] [prefix drscheme:tools: drscheme:tools^] [prefix drscheme:eval: drscheme:eval^] [prefix drscheme:init: drscheme:init^] [prefix drscheme:module-language: drscheme:module-language^] [prefix drscheme:modes: drscheme:modes^]) (export (rename drscheme:unit^ [-frame% frame%] [-frame<%> frame<%>])) (define-local-member-name get-visible-defs set-visible-defs set-focus-d/i get-i set-i) (define tab<%> (interface (drscheme:rep:context<%>) get-frame get-defs get-ints get-visible-defs set-visible-defs set-visible-ints set-focus-d/i get-i set-i break-callback is-current-tab? get-enabled on-close can-close?)) (define definitions-text<%> (interface () begin-metadata-changes end-metadata-changes get-tab get-next-settings after-set-next-settings set-needs-execution-message)) (define-struct teachpack-callbacks (get-names ;; settings -> (listof string) add ;; settings path -> settings remove ;; string[returned from teachpack-names] settings -> settings remove-all ;; settings -> settings )) ;; get rid of set-user-teachpack-cache method (keymap:add-to-right-button-menu (let ([old (keymap:add-to-right-button-menu)]) (λ (menu text event) (old menu text event) (when (and (is-a? text text%) (or (is-a? text (get-definitions-text%)) (is-a? text drscheme:rep:text%)) (is-a? event mouse-event%)) (let* ([end (send text get-end-position)] [start (send text get-start-position)]) (unless (= 0 (send text last-position)) (let ([str (if (= end start) (find-symbol text (call-with-values (λ () (send text dc-location-to-editor-location (send event get-x) (send event get-y))) (λ (x y) (send text find-position x y)))) (send text get-text start end))] [language (let ([canvas (send text get-canvas)]) (and canvas (let ([tlw (send canvas get-top-level-window)]) (and (is-a? tlw -frame<%>) (send (send tlw get-definitions-text) get-next-settings)))))]) (unless (string=? str "") (make-object separator-menu-item% menu) (make-object menu-item% (gui-utils:format-literal-label (string-constant search-help-desk-for) (shorten-str str (- 200 (string-length (string-constant search-help-desk-for))))) menu (λ x (help-desk:help-desk str))) (void))))))))) ;; find-symbol : number -> string ;; finds the symbol around the position `pos' (approx) (define (find-symbol text pos) (let* ([before (let loop ([i (- pos 1)] [chars null]) (if (< i 0) chars (let ([char (send text get-character i)]) (if (non-letter? char) chars (loop (- i 1) (cons char chars))))))] [after (let loop ([i pos]) (if (< i (send text last-position)) (let ([char (send text get-character i)]) (if (non-letter? char) null (cons char (loop (+ i 1))))) null))]) (apply string (append before after)))) ;; non-letter? : char -> boolean ;; returns #t if the character belongs in a symbol (approx) and #f it is ;; a divider between symbols (approx) (define (non-letter? x) (or (char-whitespace? x) (memq x '(#\` #\' #\, #\; #\" #\{ #\( #\[ #\] #\) #\})))) (define (shorten-str str len) (if ((string-length str) . <= . len) str (substring str 0 len))) ; ; ; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ;;; ;;; ;;;; ; ;;; ; ;; ;; ; ; ;;; ; ;;; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ;;;;; ;;; ;; ; ;;; ; ; ;; ; ; ;;;;; ; ;;; ;; ; ; ; ; ; ; ; ;;;; (define (get-fraction-from-user parent) (let* ([dlg (make-object dialog% (string-constant enter-fraction))] [hp (make-object horizontal-panel% dlg)] [_1 (make-object message% (string-constant whole-part) hp)] [whole (make-object text-field% #f hp void)] [vp (make-object vertical-panel% hp)] [hp2 (make-object horizontal-panel% vp)] [num (make-object text-field% #f hp2 void)] [num-m (make-object message% (string-constant numerator) hp2)] [hp3 (make-object horizontal-panel% vp)] [den (make-object text-field% #f hp3 void)] [den-m (make-object message% (string-constant denominator) hp3)] [bp (make-object horizontal-panel% dlg)] [ok? #f] [validate-number (λ () (let ([num-s (string->number (send num get-value))] [den-s (string->number (send den get-value))] [whole-s (if (string=? (send whole get-value) "") 0 (string->number (send whole get-value)))]) (if (and num-s den-s whole-s) (let ([ans (+ whole-s (/ num-s den-s))]) (if (and (exact? ans) (real? ans) (not (integer? ans))) ans #f)) #f)))] [ok-callback (λ () (cond [(validate-number) (set! ok? #t) (send dlg show #f)] [else (message-box (string-constant drscheme) (string-constant invalid-number) dlg)]))] [cancel-callback (λ () (send dlg show #f))]) (let-values ([(ok cancel) (gui-utils:ok/cancel-buttons bp (λ (x y) (ok-callback)) (λ (x y) (cancel-callback)))]) (let ([mw (max (send den-m get-width) (send num-m get-width))]) (send den-m min-width mw) (send num-m min-width mw)) (send bp set-alignment 'right 'center) (send dlg show #t) (and ok? (validate-number))))) ;; create-executable : (instanceof drscheme:unit:frame<%>) -> void (define (create-executable frame) (let* ([definitions-text (send frame get-definitions-text)] [program-filename (send definitions-text get-filename)]) (cond [(not program-filename) (message-box (string-constant create-executable-title) (string-constant must-save-before-executable) frame)] [else (when (or (not (send definitions-text is-modified?)) (gui-utils:get-choice (string-constant definitions-not-saved) (string-constant yes) (string-constant no) (string-constant drscheme) #f frame)) (let ([settings (send definitions-text get-next-settings)]) (send (drscheme:language-configuration:language-settings-language settings) create-executable (drscheme:language-configuration:language-settings-settings settings) frame program-filename)))]))) (define execute-bitmap (make-object bitmap% (build-path (collection-path "icons") "run.png") 'png/mask)) (define break-bitmap (make-object bitmap% (build-path (collection-path "icons") "break.png") 'png/mask)) (define save-bitmap (make-object bitmap% (build-path (collection-path "icons") "save.png") 'png/mask)) (define-values (get-program-editor-mixin add-to-program-editor-mixin) (let* ([program-editor-mixin (mixin (editor:basic<%> (class->interface text%)) () (init-rest args) (inherit get-top-level-window) (define/private (reset-highlighting) (let ([f (get-top-level-window)]) (when (and f (is-a? f -frame<%>)) (let ([interactions-text (send f get-interactions-text)]) (when (object? interactions-text) (send interactions-text reset-highlighting)))))) (define/augment (after-insert x y) (reset-highlighting) (inner (void) after-insert x y)) (define/augment (after-delete x y) (reset-highlighting) (inner (void) after-delete x y)) (apply super-make-object args))] [get-program-editor-mixin (λ () (drscheme:tools:only-in-phase 'drscheme:unit:get-program-editor-mixin 'phase2 'init-complete) program-editor-mixin)] [add-to-program-editor-mixin (λ (mixin) (drscheme:tools:only-in-phase 'drscheme:unit:add-to-program-editor-mixin 'phase1) (set! program-editor-mixin (compose mixin program-editor-mixin)))]) (values get-program-editor-mixin add-to-program-editor-mixin))) ;; this sends a message to it's frame when it gets the focus (define make-searchable-canvas% (λ (%) (class % (inherit get-top-level-window) (define/override (on-focus on?) (when on? (send (get-top-level-window) make-searchable this)) (super on-focus on?)) (super-new)))) (define interactions-canvas% (class (make-searchable-canvas% (canvas:info-mixin (canvas:wide-snip-mixin (canvas:info-mixin canvas:color%)))) (init [style '()]) (super-new (style (cons 'auto-hscroll style))))) (define definitions-canvas% (class (make-searchable-canvas% (canvas:delegate-mixin (canvas:info-mixin canvas:color%))) (init [style '()]) (super-new (style (cons 'auto-hscroll style))))) ; ; ; ; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;; ;;;;;;; ; ;; ; ;;;; ; ;;; ; ;; ;;; ;;;; ;;; ; ; ;;;; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;;; ; ; ; ; ; ;; ; ;;; ; ; ;;; ;; ;;;; ; ; ;; ; ; ; (define get-definitions-text% (let ([definitions-text% #f]) (λ () (drscheme:tools:only-in-phase 'phase2 'init-complete) (unless definitions-text% (set! definitions-text% (make-definitions-text%))) definitions-text%))) (define (make-definitions-text%) (let ([definitions-super% ((get-program-editor-mixin) (drscheme:module-language:module-language-put-file-mixin (scheme:text-mixin (color:text-mixin (drscheme:rep:drs-bindings-keymap-mixin (mode:host-text-mixin (text:delegate-mixin (text:foreground-color-mixin (drscheme:rep:drs-autocomplete-mixin (λ (x) x) text:info%)))))))))]) (class* definitions-super% (definitions-text<%>) (inherit get-top-level-window is-locked? lock) (define interactions-text #f) (define/public (set-interactions-text it) (set! interactions-text it)) (define tab #f) (define/public (get-tab) tab) (define/public (set-tab t) (set! tab t)) (inherit get-surrogate set-surrogate) (define/public (set-current-mode mode) (let ([surrogate (drscheme:modes:mode-surrogate mode)]) (set-surrogate surrogate) (when interactions-text (send interactions-text set-surrogate surrogate) (send interactions-text set-submit-predicate (drscheme:modes:mode-repl-submit mode))))) (define/public (is-current-mode? mode) (let ([surrogate (drscheme:modes:mode-surrogate mode)]) (eq? surrogate (get-surrogate)))) (define/public (change-mode-to-match) (let* ([language-settings (get-next-settings)] [language-name (and language-settings (send (drscheme:language-configuration:language-settings-language language-settings) get-language-position))]) (let loop ([modes (drscheme:modes:get-modes)]) (cond [(null? modes) (error 'change-mode-to-match "didn't find a matching mode")] [else (let ([mode (car modes)]) (if ((drscheme:modes:mode-matches-language mode) language-name) (unless (is-current-mode? mode) (set-current-mode mode)) (loop (cdr modes))))])))) (inherit begin-edit-sequence end-edit-sequence delete insert last-position paragraph-start-position get-character) (define save-file-metadata #f) (define/pubment (begin-metadata-changes) (set! ignore-edits? #t) (inner (void) begin-metadata-changes)) (define/pubment (end-metadata-changes) (set! ignore-edits? #f) (inner (void) end-metadata-changes)) (define/augment (on-save-file filename fmt) (inner (void) on-save-file filename fmt) (let* ([lang (drscheme:language-configuration:language-settings-language next-settings)] [settings (drscheme:language-configuration:language-settings-settings next-settings)] [name-mod (send lang get-reader-module)]) (when name-mod ;; the reader-module method's result is used a test of whether or not the get-metadata method is used for this language (let ([metadata (send lang get-metadata (filename->modname filename) settings)]) (begin-edit-sequence) (begin-metadata-changes) (let ([locked? (is-locked?)]) (when locked? (lock #f)) (set! save-file-metadata metadata) (insert metadata 0 0) (when locked? (lock #t))))))) (define/private (filename->modname filename) (let-values ([(base name dir) (split-path filename)]) (string->symbol (regexp-replace #rx"\\.[^.]*$" (path->string name) "")))) (define/augment (after-save-file success?) (when success? (let ([filename (get-filename)]) (when filename ;; if a filesystem error happens, just give up ;; on setting the file creator and type. (with-handlers ([exn:fail:filesystem? void]) (let-values ([(creator type) (file-creator-and-type filename)]) (file-creator-and-type filename #"DrSc" type)))))) (when save-file-metadata (let ([modified? (is-modified?)] [locked? (is-locked?)]) (when locked? (lock #f)) (delete 0 (string-length save-file-metadata)) (when locked? (lock #t)) (set! save-file-metadata #f) ;; restore modification status to where it was before the metadata is removed (set-modified modified?) (end-metadata-changes) (end-edit-sequence))) (inner (void) after-save-file success?)) (define/augment (on-load-file filename format) (inner (void) on-load-file filename format) (begin-edit-sequence)) (define/augment (after-load-file success?) (when success? (let-values ([(module-language module-language-settings) (get-module-language/settings)]) (let-values ([(matching-language settings) (pick-new-language this (drscheme:language-configuration:get-languages) module-language module-language-settings)]) (when matching-language (set-next-settings (drscheme:language-configuration:make-language-settings matching-language settings) #f)))) (set-modified #f)) (end-edit-sequence) (inner (void) after-load-file success?)) (inherit is-modified? run-after-edit-sequence) (define/override (set-modified mod?) (super set-modified mod?) (run-after-edit-sequence (λ () (let ([f (get-top-level-window)]) (when (and f (is-a? f -frame<%>)) (send f update-save-button)))))) (define/override set-filename (case-lambda [(fn) (set-filename fn #f)] [(fn tmp?) (super set-filename fn tmp?) (let ([f (get-top-level-window)]) (when (and f (is-a? f -frame<%>)) (send f update-save-message)))])) (field [needs-execution-state #f] [already-warned-state #f] [execute-settings (preferences:get drscheme:language-configuration:settings-preferences-symbol)] [next-settings execute-settings]) (define/pubment (get-next-settings) next-settings) (define/pubment set-next-settings (lambda (_next-settings [update-prefs? #t]) (when (or (send (drscheme:language-configuration:language-settings-language _next-settings) get-reader-module) (send (drscheme:language-configuration:language-settings-language next-settings) get-reader-module)) (set-modified #t)) (set! next-settings _next-settings) (change-mode-to-match) (let ([f (get-top-level-window)]) (when (and f (is-a? f -frame<%>)) (send f language-changed))) (let ([lang (drscheme:language-configuration:language-settings-language next-settings)] [sets (drscheme:language-configuration:language-settings-settings next-settings)]) (preferences:set 'drscheme:recent-language-names (limit-length (remove-duplicate-languages (cons (cons (send lang get-language-name) (send lang marshall-settings sets)) (preferences:get 'drscheme:recent-language-names))) 10))) (when update-prefs? (preferences:set drscheme:language-configuration:settings-preferences-symbol next-settings)) (after-set-next-settings _next-settings))) (define/pubment (after-set-next-settings s) (inner (void) after-set-next-settings s)) (define/public (needs-execution) (or needs-execution-state (and (not (this-and-next-language-the-same?)) (string-constant needs-execute-language-changed)))) (define/public (this-and-next-language-the-same?) (let ([execute-lang (drscheme:language-configuration:language-settings-language execute-settings)] [next-lang (drscheme:language-configuration:language-settings-language next-settings)]) (and (eq? execute-lang next-lang) (equal? (send execute-lang marshall-settings (drscheme:language-configuration:language-settings-settings execute-settings)) (send execute-lang marshall-settings (drscheme:language-configuration:language-settings-settings next-settings)))))) (define/pubment (set-needs-execution-message msg) (set! needs-execution-state msg)) (define/pubment (teachpack-changed) (set! needs-execution-state (string-constant needs-execute-teachpack-changed))) (define/pubment (just-executed) (set! execute-settings next-settings) (set! needs-execution-state #f) (set! already-warned-state #f)) (define/pubment (already-warned?) already-warned-state) (define/pubment (already-warned) (set! already-warned-state #t)) (define ignore-edits? #f) (define/augment (after-insert x y) (unless ignore-edits? (set! needs-execution-state (string-constant needs-execute-defns-edited))) (inner (void) after-insert x y)) (define/augment (after-delete x y) (unless ignore-edits? (set! needs-execution-state (string-constant needs-execute-defns-edited))) (inner (void) after-delete x y)) (inherit get-filename) (field [tmp-date-string #f]) (inherit get-filename/untitled-name) (define/private (get-date-string) (string-append (date->string (seconds->date (current-seconds))) " " (get-filename/untitled-name))) (define/override (on-paint before dc left top right bottom dx dy draw-caret) (when (and before (or (is-a? dc post-script-dc%) (is-a? dc printer-dc%))) (set! tmp-date-string (get-date-string)) (let-values ([(w h d s) (send dc get-text-extent tmp-date-string)]) (send (current-ps-setup) set-editor-margin 0 (inexact->exact (ceiling h))))) (super on-paint before dc left top right bottom dx dy draw-caret) (when (and (not before) (or (is-a? dc post-script-dc%) (is-a? dc printer-dc%))) (send dc draw-text (get-date-string) 0 0) (void)) ;; draw the arrows (when before (when error-arrows (let ([old-pen (send dc get-pen)]) (send dc set-pen (send the-pen-list find-or-create-pen "red" 1 'solid)) (let loop ([pts error-arrows]) (cond [(null? pts) (void)] [(null? (cdr pts)) (void)] [else (let ([pt1 (car pts)] [pt2 (cadr pts)]) (draw-arrow dc dx dy pt1 pt2) (loop (cdr pts)))])) (send dc set-pen old-pen))))) (define/private (draw-arrow dc dx dy pt1 pt2) (let-values ([(x1 y1) (find-poss (srcloc-source pt1) (- (srcloc-position pt1) 1) (srcloc-position pt1))] [(x2 y2) (find-poss (srcloc-source pt2) (- (srcloc-position pt2) 1) (srcloc-position pt2))]) (drscheme:arrow:draw-arrow dc x1 y1 x2 y2 dx dy))) (inherit dc-location-to-editor-location) (define/private (find-poss text left-pos right-pos) (let ([xlb (box 0)] [ylb (box 0)] [xrb (box 0)] [yrb (box 0)]) (send text position-location left-pos xlb ylb #t) (send text position-location right-pos xrb yrb #f) (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] [(xl yl) (dc-location-to-editor-location xl-off yl-off)] [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) (values (/ (+ xl xr) 2) (/ (+ yl yr) 2))))) (inherit invalidate-bitmap-cache) (define/public (set-error-arrows arrows) (set! error-arrows arrows) (invalidate-bitmap-cache)) (define error-arrows #f) (super-new) (inherit set-max-undo-history) (set-max-undo-history 'forever)))) (define (get-module-language/settings) (let* ([module-language (and (preferences:get 'drscheme:switch-to-module-language-automatically?) (ormap (λ (lang) (and (is-a? lang drscheme:module-language:module-language<%>) lang)) (drscheme:language-configuration:get-languages)))] [module-language-settings (let ([prefs-setting (preferences:get drscheme:language-configuration:settings-preferences-symbol)]) (cond [(eq? (drscheme:language-configuration:language-settings-language prefs-setting) module-language) (drscheme:language-configuration:language-settings-settings prefs-setting)] [else (and module-language (send module-language default-settings))]))]) (values module-language module-language-settings))) ; ; ;; ; ; ; ; ; ; ; ; ;;; ; ;;; ;;; ; ; ;;; ;;; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;;; ; ;;;; ; ; ; ; ;;;; ; ; ; ; ; ;; get-pos : text mouse-event% -> (union #f number) (define (get-pos text event) (let*-values ([(event-x event-y) (values (send event get-x) (send event get-y))] [(x y) (send text dc-location-to-editor-location event-x event-y)]) (let* ([on-it? (box #f)] [pos (send text find-position x y #f on-it?)]) (and (unbox on-it?) pos)))) (let ([old (keymap:add-to-right-button-menu)]) (keymap:add-to-right-button-menu (λ (menu editor event) (when (is-a? editor text%) (let* ([canvas (send editor get-canvas)] [frame (and canvas (send canvas get-top-level-window))]) (when (is-a? frame -frame<%>) (let* ([language-settings (send (send frame get-definitions-text) get-next-settings)] [new-language (drscheme:language-configuration:language-settings-language language-settings)] [capability-info (send new-language capability-value 'drscheme:define-popup)]) (when capability-info (let* ([current-pos (get-pos editor event)] [current-word (and current-pos (get-current-word editor current-pos))] [defn (and current-word (ormap (λ (defn) (and (string=? current-word (defn-name defn)) defn)) (get-definitions (car capability-info) #f editor)))]) (when defn (new separator-menu-item% (parent menu)) (new menu-item% (parent menu) (label (gui-utils:format-literal-label (string-constant jump-to-defn) (defn-name defn))) (callback (λ (x y) (send editor set-position (defn-start-pos defn)))))))))))) (old menu editor event)))) ;; get-current-word : editor number -> string ;; returns the string that is being clicked on (define (get-current-word editor pos) (let* ([search (λ (dir offset) (let loop ([pos pos]) (cond [(or (= pos 0) (= pos (send editor last-position))) pos] [(memq (send editor get-character pos) '(#\space #\return #\newline #\( #\) #\[ #\] #\tab)) (offset pos)] [else (loop (dir pos))])))] [before (search sub1 add1)] [after (search add1 (λ (x) x))]) (send editor get-text before after))) (define func-defs-canvas% (class name-message% (init-field frame) (unless (is-a? frame -frame<%>) (error 'func-defs-canvas "frame is not a drscheme:unit:frame<%>")) (define sort-by-name? #f) (define sorting-name (string-constant sort-by-name)) (define/private (change-sorting-order) (set! sort-by-name? (not sort-by-name?)) (set! sorting-name (if sort-by-name? (string-constant sort-by-position) (string-constant sort-by-name)))) (define capability-info (drscheme:language:get-capability-default 'drscheme:define-popup)) (inherit set-message set-hidden?) (define/public (language-changed new-language) (set! capability-info (send new-language capability-value 'drscheme:define-popup)) (cond [capability-info (set-message #f (cdr capability-info)) (set-hidden? #f)] [else (set-hidden? #t)])) (define/override (fill-popup menu reset) (when capability-info (let* ([text (send frame get-definitions-text)] [unsorted-defns (get-definitions (car capability-info) (not sort-by-name?) text)] [defns (if sort-by-name? (sort unsorted-defns (λ (x y) (string-ci<=? (defn-name x) (defn-name y)))) unsorted-defns)]) (make-object menu:can-restore-menu-item% sorting-name menu (λ (x y) (change-sorting-order))) (make-object separator-menu-item% menu) (if (null? defns) (send (make-object menu:can-restore-menu-item% (string-constant no-definitions-found) menu void) enable #f) (let loop ([defns defns]) (unless (null? defns) (let* ([defn (car defns)] [checked? (let ([t-start (send text get-start-position)] [t-end (send text get-end-position)] [d-start (defn-start-pos defn)] [d-end (defn-end-pos defn)]) (or (<= t-start d-start t-end) (<= t-start d-end t-end) (<= d-start t-start t-end d-end)))] [item (make-object (if checked? menu:can-restore-checkable-menu-item% menu:can-restore-menu-item%) (gui-utils:quote-literal-label (defn-name defn)) menu (λ (x y) (reset) (send text set-position (defn-start-pos defn) (defn-start-pos defn)) (let ([canvas (send text get-canvas)]) (when canvas (send canvas focus)))))]) (when checked? (send item check #t)) (loop (cdr defns))))))))) (super-new (label "(define ...)") [string-constant-untitled (string-constant untitled)] [string-constant-no-full-name-since-not-saved (string-constant no-full-name-since-not-saved)]))) ;; defn = (make-defn number string number number) (define-struct defn (indent name start-pos end-pos) #:mutable) ;; get-definitions : boolean text -> (listof defn) (define (get-definitions tag-string indent? text) (let* ([min-indent 0] [defs (let loop ([pos 0]) (let ([defn-pos (send text find-string tag-string 'forward pos 'eof #t #f)]) (cond [(not defn-pos) null] [(in-semicolon-comment? text defn-pos) (loop (+ defn-pos (string-length tag-string)))] [else (let ([indent (get-defn-indent text defn-pos)] [name (get-defn-name text (+ defn-pos (string-length tag-string)))]) (set! min-indent (min indent min-indent)) (cons (make-defn indent name defn-pos defn-pos) (loop (+ defn-pos (string-length tag-string)))))])))]) ;; update end-pos's based on the start pos of the next defn (unless (null? defs) (let loop ([first (car defs)] [defs (cdr defs)]) (cond [(null? defs) (set-defn-end-pos! first (send text last-position))] [else (set-defn-end-pos! first (max (- (defn-start-pos (car defs)) 1) (defn-start-pos first))) (loop (car defs) (cdr defs))]))) (when indent? (for-each (λ (defn) (set-defn-name! defn (string-append (apply string (vector->list (make-vector (- (defn-indent defn) min-indent) #\space))) (defn-name defn)))) defs)) defs)) ;; in-semicolon-comment: text number -> boolean ;; returns #t if `define-start-pos' is in a semicolon comment and #f otherwise (define (in-semicolon-comment? text define-start-pos) (let* ([para (send text position-paragraph define-start-pos)] [start (send text paragraph-start-position para)]) (let loop ([pos start]) (cond [(pos . >= . define-start-pos) #f] [(char=? #\; (send text get-character pos)) #t] [else (loop (+ pos 1))])))) ;; get-defn-indent : text number -> number ;; returns the amount to indent a particular definition (define (get-defn-indent text pos) (let* ([para (send text position-paragraph pos)] [para-start (send text paragraph-start-position para #t)]) (let loop ([c-pos para-start] [offset 0]) (if (< c-pos pos) (let ([char (send text get-character c-pos)]) (cond [(char=? char #\tab) (loop (+ c-pos 1) (+ offset (- 8 (modulo offset 8))))] [else (loop (+ c-pos 1) (+ offset 1))])) offset)))) ;; skip-to-whitespace/paren : text number -> number ;; skips to the next parenthesis or whitespace after `pos', returns that position. (define (skip-to-whitespace/paren text pos) (let loop ([pos pos]) (if (>= pos (send text last-position)) (send text last-position) (let ([char (send text get-character pos)]) (cond [(or (char=? #\) char) (char=? #\( char) (char=? #\] char) (char=? #\[ char) (char-whitespace? char)) pos] [else (loop (+ pos 1))]))))) ;; skip-whitespace/paren : text number -> number ;; skips past any parenthesis or whitespace (define (skip-whitespace/paren text pos) (let loop ([pos pos]) (if (>= pos (send text last-position)) (send text last-position) (let ([char (send text get-character pos)]) (cond [(or (char=? #\) char) (char=? #\( char) (char=? #\] char) (char=? #\[ char) (char-whitespace? char)) (loop (+ pos 1))] [else pos]))))) ;; get-defn-name : text number -> string ;; returns the name of the definition starting at `define-pos' (define (get-defn-name text define-pos) (if (>= define-pos (send text last-position)) (string-constant end-of-buffer-define) (let* ([start-pos (skip-whitespace/paren text (skip-to-whitespace/paren text define-pos))] [end-pos (skip-to-whitespace/paren text start-pos)]) (send text get-text start-pos end-pos)))) (define (set-box/f! b v) (when (box? b) (set-box! b v))) ;; ; ; ;;; ; ;; ;;; ; ;;; ;; ;;; ; ;; ; ; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;;;; (define dragable/def-int-mixin (mixin (panel:dragable<%>) () (init-field unit-frame) (inherit get-percentages) (define/augment (after-percentage-change) (let ([percentages (get-percentages)]) (when (and (= 1 (length (send unit-frame get-definitions-canvases)) (length (send unit-frame get-interactions-canvases))) (= 2 (length percentages))) (preferences:set 'drscheme:unit-window-size-percentage (car percentages)))) (inner (void) after-percentage-change)) (super-new))) (define vertical-dragable/def-int% (dragable/def-int-mixin panel:vertical-dragable%)) (define horizontal-dragable/def-int% (dragable/def-int-mixin panel:horizontal-dragable%)) (define super-frame% (drscheme:frame:mixin (drscheme:frame:basics-mixin (frame:searchable-text-mixin (frame:searchable-mixin (frame:text-info-mixin (frame:delegate-mixin (frame:status-line-mixin (frame:info-mixin (frame:text-mixin (frame:open-here-mixin (frame:editor-mixin (frame:standard-menus-mixin (frame:register-group-mixin (frame:basic-mixin frame%))))))))))))))) (define tab% (class* object% (drscheme:rep:context<%> tab<%>) (init-field frame defs i defs-shown? ints-shown?) (define enabled? #t) (field [ints #f] [visible-defs #f] [visible-ints #f] [focus-d/i 'defs]) ;; only called to initialize this tab. ;; the interactions editor should be invariant. (define/public (set-ints i) (set! ints i)) (define/public-final (get-frame) frame) (define/public-final (get-defs) defs) (define/public-final (get-ints) ints) (define/public-final (get-visible-defs) (values visible-defs defs-shown?)) (define/public-final (set-visible-defs vd ds?) (set! visible-defs vd) (set! defs-shown? ds?)) (define/public-final (get-visible-ints) (values visible-ints ints-shown?)) (define/public-final (set-visible-ints vi is?) (set! visible-ints vi) (set! ints-shown? is?)) (define/public-final (set-focus-d/i di) (set! focus-d/i di)) (define/public-final (get-focus-d/i) focus-d/i) (define/public-final (get-i) i) (define/public-final (set-i _i) (set! i _i)) (define/public (disable-evaluation) (set! enabled? #f) (send defs lock #t) (send ints lock #t) (send frame disable-evaluation-in-tab this)) (define/public (enable-evaluation) (set! enabled? #t) (send defs lock #f) (send ints lock #f) (send frame enable-evaluation-in-tab this)) (define/public (get-enabled) enabled?) (define/public (get-directory) (let ([filename (send defs get-filename)]) (if (and (path? filename) (file-exists? filename)) (let-values ([(base _1 _2) (split-path (normalize-path filename))]) base) #f))) (define/public (needs-execution) (send defs needs-execution)) (define/pubment (can-close?) (and (send defs can-close?) (send ints can-close?) (inner #t can-close?))) (define/pubment (on-close) (send defs on-close) (send ints on-close) (inner (void) on-close)) ;; this should really do something local to the tab, but ;; for now it doesn't. (define/public (ensure-rep-shown rep) (send frame ensure-rep-shown rep)) (field [thread-to-break-box (make-weak-box #f)] [custodian-to-kill-box (make-weak-box #f)] [offer-kill? #f]) ;; break-callback : -> void (define/public (break-callback) (let ([thread-to-break (weak-box-value thread-to-break-box)] [custodian-to-kill (weak-box-value custodian-to-kill-box)]) (cond [(or (not thread-to-break) (not custodian-to-kill)) (bell)] [offer-kill? (if (user-wants-kill?) (when thread-to-break (break-thread thread-to-break)) (when custodian-to-kill (custodian-shutdown-all custodian-to-kill)))] [else (when thread-to-break (break-thread thread-to-break)) ;; only offer a kill the next time if ;; something got broken. (set! offer-kill? #t)]))) ;; user-wants-kill? : -> boolean ;; handles events, so be sure to check state ;; after calling to avoid race conditions. (define/private (user-wants-kill?) (gui-utils:get-choice (string-constant kill-evaluation?) (string-constant just-break) (string-constant kill) (string-constant kill?) 'diallow-close frame)) ;; reset-offer-kill (define/public (reset-offer-kill) (set! offer-kill? #f)) ;; get-breakables : -> (union #f thread) (union #f cust) -> void (define/public (get-breakables) (values (weak-box-value thread-to-break-box) (weak-box-value custodian-to-kill-box))) ;; set-breakables : (union #f thread) (union #f cust) -> void (define/public (set-breakables thd cust) (set! thread-to-break-box (make-weak-box thd)) (set! custodian-to-kill-box (make-weak-box cust))) (define/pubment (clear-annotations) (inner (void) clear-annotations) (send ints reset-highlighting)) (define running? #f) (define/public-final (is-running?) running?) (define/public (update-running b?) (set! running? b?) (send frame update-running b?)) (define/public-final (is-current-tab?) (eq? this (send frame get-current-tab))) (super-new))) ;; should only be called by the tab% object (define-local-member-name disable-evaluation-in-tab enable-evaluation-in-tab update-toolbar-visibility) (define -frame<%> (interface (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>) get-insert-menu get-special-menu get-interactions-text get-definitions-text get-interactions-canvas get-definitions-canvas get-button-panel execute-callback get-current-tab open-in-new-tab on-tab-change enable-evaluation disable-evaluation get-definitions/interactions-panel-parent register-capability-menu-item ensure-rep-shown ensure-rep-hidden ensure-defs-shown get-language-menu register-toolbar-button)) (define frame-mixin (mixin (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>) (-frame<%>) (init filename) (inherit set-label-prefix get-show-menu get-menu% get-area-container update-info get-file-menu file-menu:get-close-item file-menu:get-save-item file-menu:get-save-as-item file-menu:get-revert-item file-menu:get-print-item) ;; logging : (union #f string[directory-name]) (field [logging #f] [definitions-log-counter 0] ;; number [interactions-log-counter 0] ;; number [logging-parent-panel #f] ;; panel (unitialized short time only) [logging-panel #f] ;; panel (unitialized short time only) [logging-menu-item #f]) ;; menu-item (unitialized short time only) ;; log-definitions : -> void (define/private (log-definitions) (when logging (set! definitions-log-counter (+ definitions-log-counter 1)) (send definitions-text save-file (build-path logging (format "~a-definitions" (pad-two definitions-log-counter))) 'copy))) ;; log-ineractions : -> void (define/private (log-interactions) (when logging (set! interactions-log-counter (+ interactions-log-counter 1)) (send interactions-text save-file (build-path logging (format "~a-interactions" (pad-two interactions-log-counter))) 'copy))) ;; pad-two : number -> string ;; pads a number to two digits? (define/private (pad-two n) (cond [(<= 0 n 9) (format "0~a" n)] [else (format "~a" n)])) ;; start-logging : -> void ;; turns on the logging and shows the logging gui (define/private (start-logging) (let ([log-directory (mred:get-directory (string-constant please-choose-a-log-directory) this)]) (when (and log-directory (ensure-empty log-directory)) (send logging-menu-item set-label (string-constant stop-logging)) (set! logging log-directory) (set! definitions-log-counter 0) (set! interactions-log-counter 0) (build-logging-panel) (log-definitions)))) ;; stop-logging : -> void ;; turns off the logging procedure (define/private (stop-logging) (log-interactions) (send logging-menu-item set-label (string-constant log-definitions-and-interactions)) (set! logging #f) (send logging-panel change-children (λ (l) null))) ;; build-logging-panel : -> void ;; builds the contents of the logging panel (define/private (build-logging-panel) (define hp (make-object horizontal-panel% logging-panel '(border))) (make-object message% (string-constant logging-to) hp) (send (make-object message% (path->string logging) hp) stretchable-width #t) (make-object button% (string-constant stop-logging) hp (λ (x y) (stop-logging)))) ;; ensure-empty : string[directory] -> boolean ;; if the log-directory is empty, just return #t ;; if not, ask the user about emptying it. ;; if they say yes, try to empty it. ;; if that fails, report the error and return #f. ;; if it succeeds, return #t. ;; if they say no, return #f. (define/private (ensure-empty log-directory) (let ([dir-list (directory-list log-directory)]) (or (null? dir-list) (let ([query (message-box (string-constant drscheme) (gui-utils:format-literal-label (string-constant erase-log-directory-contents) log-directory) this '(yes-no))]) (cond [(eq? query 'no) #f] [(eq? query 'yes) (with-handlers ([exn:fail:filesystem? (λ (exn) (message-box (string-constant drscheme) (gui-utils:format-literal-label (string-constant error-erasing-log-directory) (if (exn? exn) (format "~a" (exn-message exn)) (format "~s" exn))) this) #f)]) (for-each (λ (file) (delete-file (build-path log-directory file))) dir-list) #t)]))))) (define/override (make-root-area-container cls parent) (let* ([outer-panel (super make-root-area-container module-browser-dragable-panel% parent)] [saved-p (preferences:get 'drscheme:module-browser-size-percentage)] [_module-browser-panel (new vertical-panel% (parent outer-panel) (alignment '(left center)) (stretchable-width #f))] [louter-panel (make-object vertical-panel% outer-panel)] [root (make-object cls louter-panel)]) (set! module-browser-panel _module-browser-panel) (set! module-browser-parent-panel outer-panel) (send outer-panel change-children (λ (l) (remq module-browser-panel l))) (preferences:set 'drscheme:module-browser-size-percentage saved-p) (set! logging-parent-panel (new horizontal-panel% (parent louter-panel) (stretchable-height #f))) (set! logging-panel (make-object horizontal-panel% logging-parent-panel)) (unless (toolbar-shown?) (send logging-parent-panel change-children (λ (l) '()))) root)) (inherit show-info hide-info is-info-hidden?) (field [toolbar-state (preferences:get 'drscheme:toolbar-state)] [toolbar-top-menu-item #f] [toolbar-left-menu-item #f] [toolbar-right-menu-item #f] [toolbar-hidden-menu-item #f] [toolbar-menu #f]) ;; returns #t if the toolbar is visible, #f otherwise (define/private (toolbar-shown?) (car toolbar-state)) (define/private (change-toolbar-state new-state) (set! toolbar-state new-state) (preferences:set 'drscheme:toolbar-state new-state) (update-toolbar-visibility)) (define/override (on-toolbar-button-click) (change-toolbar-state (cons (not (car toolbar-state)) (cdr toolbar-state)))) (define/private (set-toolbar-left) (change-toolbar-state (cons #f 'left))) (define/private (set-toolbar-right) (change-toolbar-state (cons #f 'right))) (define/private (set-toolbar-top) (change-toolbar-state (cons #f 'top))) (define/private (set-toolbar-hidden) (change-toolbar-state (cons #t (cdr toolbar-state)))) (define/public (update-toolbar-visibility) (let* ([hidden? (toolbar-is-hidden?)] [left? (toolbar-is-left?)] [right? (toolbar-is-right?)] [top? (toolbar-is-top?)]) (send toolbar-left-menu-item check left?) (send toolbar-right-menu-item check right?) (send toolbar-top-menu-item check top?) (send toolbar-hidden-menu-item check hidden?) (cond [hidden? (hide-info) (send top-outer-panel change-children (λ (l) '())) (send logging-parent-panel change-children (λ (l) '()))] [top? (orient/show #t)] [left? (orient/show #t)] [right? (orient/show #f)])) (update-defs/ints-resize-corner)) (define/private (toolbar-is-hidden?) (car (preferences:get 'drscheme:toolbar-state))) (define/private (toolbar-is-top?) (and (not (toolbar-is-hidden?)) (eq? (cdr (preferences:get 'drscheme:toolbar-state)) 'top))) (define/private (toolbar-is-right?) (and (not (toolbar-is-hidden?)) (eq? (cdr (preferences:get 'drscheme:toolbar-state)) 'right))) (define/private (toolbar-is-left?) (and (not (toolbar-is-hidden?)) (eq? (cdr (preferences:get 'drscheme:toolbar-state)) 'left))) (define/private (orient/show bar-at-beginning?) (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) (begin-container-sequence) (show-info) (let ([bpo (send button-panel get-orientation)]) (unless (equal? bpo (not vertical?)) (send button-panel set-orientation (not vertical?)) ;; have to be careful to avoid reversing the list when the orientation is already proper (send button-panel change-children reverse))) (orient) (send top-outer-panel stretchable-height vertical?) (send top-outer-panel stretchable-width (not vertical?)) (send top-panel set-orientation (not vertical?)) (send toolbar/rest-panel set-orientation vertical?) (send toolbar/rest-panel change-children (λ (l) (if bar-at-beginning? (cons top-outer-panel (remq top-outer-panel l)) (append (remq top-outer-panel l) (list top-outer-panel))))) (send top-outer-panel change-children (λ (l) (list top-panel))) (send logging-parent-panel change-children (λ (l) (list logging-panel))) (if vertical? (send top-panel change-children (λ (x) (remq name-panel x))) (send top-panel change-children (λ (x) (cons name-panel (remq name-panel x))))) (end-container-sequence))) (define toolbar-buttons '()) (define/public (register-toolbar-button b) (set! toolbar-buttons (cons b toolbar-buttons)) (orient)) (define/private (orient) (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) (for-each (λ (obj) (send obj set-label-visible (not vertical?))) toolbar-buttons)) (let loop ([obj button-panel]) (cond [(is-a? obj area-container<%>) (for-each loop (send obj get-children))] [(is-a? obj switchable-button%) (unless (memq obj toolbar-buttons) (error 'register-toolbar-button "found a switchable-button% that is not registered, label ~s" (send obj get-label)))] [else (void)]))) (field [remove-show-status-line-callback (preferences:add-callback 'framework:show-status-line (λ (p v) (update-defs/ints-resize-corner/pref v)))]) (define/private (update-defs/ints-resize-corner) (update-defs/ints-resize-corner/pref (preferences:get 'framework:show-status-line))) (define/private (update-defs/ints-resize-corner/pref si-pref) (let ([bottom-material? (and (not (car toolbar-state)) si-pref)]) (let loop ([cs definitions-canvases]) (cond [(null? cs) (void)] [(null? (cdr cs)) (send (car cs) set-resize-corner (and (not bottom-material?) (not interactions-shown?)))] [else (send (car cs) set-resize-corner #f) (loop (cdr cs))])) (let loop ([cs interactions-canvases]) (cond [(null? cs) (void)] [(null? (cdr cs)) (send (car cs) set-resize-corner (and (not bottom-material?) interactions-shown?))] [else (send (car cs) set-resize-corner #f) (loop (cdr cs))])))) [define definitions-item #f] [define interactions-item #f] [define name-message #f] [define save-button #f] [define save-init-shown? #f] [define/private set-save-init-shown? (λ (x) (set! save-init-shown? x))] [define canvas-show-mode #f] [define allow-split? #f] [define forced-quit? #f] [define search-canvas #f] (define/public (make-searchable canvas) (update-info) (set! search-canvas canvas)) (define/override (get-text-to-search) (if search-canvas (send search-canvas get-editor) (get-editor))) (define was-locked? #f) (define/public-final (disable-evaluation-in-tab tab) (when (eq? tab current-tab) (disable-evaluation))) (define/pubment (disable-evaluation) (when execute-menu-item (send execute-menu-item enable #f)) (send execute-button enable #f) (inner (void) disable-evaluation)) (define/public-final (enable-evaluation-in-tab tab) (when (eq? tab current-tab) (enable-evaluation))) (define/pubment (enable-evaluation) (when execute-menu-item (send execute-menu-item enable #t)) (send execute-button enable #t) (inner (void) enable-evaluation)) (inherit set-label) (inherit modified) (define/public (update-save-button) (let ([mod? (send definitions-text is-modified?)]) (modified mod?) (if save-button (unless (eq? mod? (send save-button is-shown?)) (send save-button show mod?)) (set! save-init-shown? mod?)) (update-tab-label current-tab))) (define/public (language-changed) (let* ([settings (send definitions-text get-next-settings)] [language (drscheme:language-configuration:language-settings-language settings)]) (send func-defs-canvas language-changed language) (send language-message set-yellow/lang (not (send definitions-text this-and-next-language-the-same?)) (string-append (send language get-language-name) (if (send language default-settings? (drscheme:language-configuration:language-settings-settings settings)) "" (string-append " " (string-constant custom))))) (let ([label (send scheme-menu get-label)] [new-label (send language capability-value 'drscheme:language-menu-title)]) (unless (equal? label new-label) (send scheme-menu set-label new-label))))) (define/public (get-language-menu) scheme-menu) ;; update-save-message : -> void ;; sets the save message. If input is #f, uses the frame's ;; title. (define/public (update-save-message) (when name-message (let ([filename (send definitions-text get-filename)]) (send name-message set-message (if filename #t #f) (send definitions-text get-filename/untitled-name)))) (update-tabs-labels)) (define/private (update-tabs-labels) (for-each (λ (tab) (update-tab-label tab)) tabs) (send tabs-panel set-selection (send current-tab get-i)) (send (send tabs-panel get-parent) change-children (λ (l) (cond [(= (send tabs-panel get-number) 1) (remq tabs-panel l)] [else (if (memq tabs-panel l) l (cons tabs-panel l))])))) (define/private (update-tab-label tab) (let ([label (gui-utils:trim-string (get-defs-tab-label (send tab get-defs) tab) 200)]) (unless (equal? label (send tabs-panel get-item-label (send tab get-i))) (send tabs-panel set-item-label (send tab get-i) label)))) (define/private (get-defs-tab-label defs tab) (let ([fn (send defs get-filename)]) (add-modified-flag defs (if fn (get-tab-label-from-filename fn) (send defs get-filename/untitled-name))))) (define/private (get-tab-label-from-filename fn) (let* ([take-n (λ (n lst) (let loop ([n n] [lst lst]) (cond [(zero? n) null] [(null? lst) null] [else (cons (car lst) (loop (- n 1) (cdr lst)))])))] [find-exp-diff (λ (p1 p2) (let loop ([p1 p1] [p2 p2] [i 1]) (cond [(or (null? p1) (null? p2)) i] [else (let ([f1 (car p1)] [f2 (car p2)]) (if (equal? f1 f2) (loop (cdr p1) (cdr p2) (+ i 1)) i))])))] [exp (reverse (explode-path (normalize-path/exists fn)))] [other-exps (filter (λ (x) (and x (not (equal? exp x)))) (map (λ (other-tab) (let ([fn (send (send other-tab get-defs) get-filename)]) (and fn (reverse (explode-path (normalize-path/exists fn)))))) tabs))] [size (let loop ([other-exps other-exps] [size 1]) (cond [(null? other-exps) size] [else (let ([new-size (find-exp-diff (car other-exps) exp)]) (loop (cdr other-exps) (max new-size size)))]))]) (path->string (apply build-path (reverse (take-n size exp)))))) (define/private (normalize-path/exists fn) (if (file-exists? fn) (normalize-path fn) fn)) (define/private (add-modified-flag text string) (if (send text is-modified?) (let ([prefix (get-save-diamond-prefix)]) (if prefix (string-append prefix string) string)) string)) (define/private (get-save-diamond-prefix) (let ([candidate-prefixes (list (case (system-type) [(windows) "• "] [else "◆ "]) "* ")]) (ormap (lambda (candidate) (and (andmap (λ (x) (send normal-control-font screen-glyph-exists? x #t)) (string->list candidate)) candidate)) candidate-prefixes))) [define/override get-canvas% (λ () (drscheme:get/extend:get-definitions-canvas))] (define/public (update-running running?) (send running-canvas set-running running?)) (define/public (ensure-defs-shown) (unless definitions-shown? (toggle-show/hide-definitions) (update-shown))) (define/public (ensure-rep-shown rep) (unless (eq? rep interactions-text) (let loop ([tabs tabs]) (unless (null? tabs) (let ([tab (car tabs)]) (if (eq? (send tab get-ints) rep) (change-to-tab tab) (loop (cdr tabs))))))) (unless interactions-shown? (toggle-show/hide-interactions) (update-shown))) (define/public (ensure-rep-hidden) (when interactions-shown? (toggle-show/hide-interactions) (update-shown))) (define/override (get-editor%) (drscheme:get/extend:get-definitions-text)) (define/public (still-untouched?) (and (= (send definitions-text last-position) 0) (not (send definitions-text is-modified?)) (not (send definitions-text get-filename)) (let* ([prompt (send interactions-text get-prompt)] [first-prompt-para (let loop ([n 0]) (cond [(n . <= . (send interactions-text last-paragraph)) (if (string=? (send interactions-text get-text (send interactions-text paragraph-start-position n) (+ (send interactions-text paragraph-start-position n) (string-length prompt))) prompt) n (loop (+ n 1)))] [else #f]))]) (and first-prompt-para (= first-prompt-para (send interactions-text last-paragraph)) (equal? (send interactions-text get-text (send interactions-text paragraph-start-position first-prompt-para) (send interactions-text paragraph-end-position first-prompt-para)) (send interactions-text get-prompt)))))) (define/public (change-to-file name) (cond [(and name (file-exists? name)) (ensure-rep-hidden) (send definitions-text begin-edit-sequence) (send definitions-text load-file/gui-error name) (send definitions-text end-edit-sequence) (send language-message set-yellow #f)] [name (send definitions-text set-filename name)] [else (send definitions-text clear)]) (send definitions-canvas focus)) ; ; ; ; ; ; ; ; ; ; ; ;; ;; ;;; ;; ; ;;; ;;; ; ;; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;;;;;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;;; ;; ; ;;;; ;;; ; ; ; (define/private (add-modes-submenu edit-menu) (new menu% (parent edit-menu) (label (string-constant mode-submenu-label)) (demand-callback (λ (menu) (for-each (λ (item) (send item delete)) (send menu get-items)) (for-each (λ (mode) (let* ([item (new checkable-menu-item% (label (drscheme:modes:mode-name mode)) (parent menu) (callback (λ (_1 _2) (send definitions-text set-current-mode mode))))]) (when (send definitions-text is-current-mode? mode) (send item check #t)))) (drscheme:modes:get-modes)))))) ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ;; ; ; ;;;; ; ;;; ;;; ; ; ;;; ; ;; ;;; ;;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ;; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;; ; ;; ; ; ;; ; ;;; ;;; ; ; ;;;;; ; ;; ;;; ;;;; ; ; ; ; ; ; ; ; ; ; ; (inherit get-edit-target-window) (define/private (split) (let ([canvas-to-be-split (get-edit-target-window)]) (cond [(memq canvas-to-be-split definitions-canvases) (split-definitions canvas-to-be-split)] [(memq canvas-to-be-split interactions-canvases) (split-interactions canvas-to-be-split)] [else (bell)]))) (define/private (split-definitions canvas-to-be-split) (handle-split canvas-to-be-split (λ (x) (set! definitions-canvases x)) definitions-canvases (drscheme:get/extend:get-definitions-canvas) definitions-text)) (define/private (split-interactions canvas-to-be-split) (handle-split canvas-to-be-split (λ (x) (set! interactions-canvases x)) interactions-canvases (drscheme:get/extend:get-interactions-canvas) interactions-text)) (define/private (handle-split canvas-to-be-split set-canvases! canvases canvas% text) (let-values ([(ox oy ow oh cursor-y) (get-visible-region canvas-to-be-split)]) (let ([orig-percentages (send resizable-panel get-percentages)] [orig-canvases (send resizable-panel get-children)] [new-canvas (new canvas% (parent resizable-panel) (editor text) (style '()))]) (set-canvases! (let loop ([canvases canvases]) (cond [(null? canvases) (error 'split "couldn't split; didn't find canvas")] [else (let ([canvas (car canvases)]) (if (eq? canvas canvas-to-be-split) (list* new-canvas canvas (cdr canvases)) (cons canvas (loop (cdr canvases)))))]))) (update-shown) ;; with-handlers prevents bad calls to set-percentages ;; might still leave GUI in bad state, however. (with-handlers ([exn:fail? (λ (x) (void))]) (send resizable-panel set-percentages (let loop ([canvases orig-canvases] [percentages orig-percentages]) (cond [(null? canvases) (error 'split "couldn't split; didn't find canvas")] [(null? percentages) (error 'split "wrong number of percentages: ~s ~s" orig-percentages (send resizable-panel get-children))] [else (let ([canvas (car canvases)]) (if (eq? canvas-to-be-split canvas) (list* (/ (car percentages) 2) (/ (car percentages) 2) (cdr percentages)) (cons (car percentages) (loop (cdr canvases) (cdr percentages)))))])))) (set-visible-region new-canvas ox oy ow oh cursor-y) (set-visible-region canvas-to-be-split ox oy ow oh cursor-y) (send new-canvas focus)))) ;; split-demand : menu-item -> void ;; enables the menu-item if splitting is allowed, disables otherwise (define/private (split-demand item) (let ([canvas-to-be-split (get-edit-target-window)]) (send item enable (or (memq canvas-to-be-split definitions-canvases) (memq canvas-to-be-split interactions-canvases))))) ;; collapse-demand : menu-item -> void ;; enables the menu-item if collapsing is allowed, disables otherwise (define/private (collapse-demand item) (let ([canvas-to-be-split (get-edit-target-window)]) (cond [(memq canvas-to-be-split definitions-canvases) (send item enable (2 . <= . (length definitions-canvases)))] [(memq canvas-to-be-split interactions-canvases) (send item enable (2 . <= . (length interactions-canvases)))] [else (send item enable #f)]))) ;; get-visible-region : editor-canvas -> number number number number (union #f number) ;; calculates the visible region of the editor in this editor-canvas, returning ;; four numbers for the x, y, width and height of the visible region ;; also, the last two booleans indiciate if the beginning and the end ;; of the selection was visible before the split, respectively. (define/private (get-visible-region canvas) (send canvas call-as-primary-owner (λ () (let* ([text (send canvas get-editor)] [admin (send text get-admin)] [start (send text get-start-position)] [end (send text get-end-position)]) (let-values ([(x y w h) (get-visible-area admin)]) (let ([ysb (box 0)]) (send text position-location (send text get-start-position) #f ysb) (values x y w h (and (= start end) (<= y (unbox ysb) (+ y h)) (unbox ysb))))))))) ;; set-visible-region : editor-canvas number number number number (union #f number) -> void ;; sets the visible region of the text displayed by the editor canvas ;; to be the middle of the region (vertically) specified by x, y, w, and h. ;; if start-visible? and/or end-visible? are true, some special handling ;; is done to try to keep the start and end visible, with precendence ;; given to start if both are #t. (define/private (set-visible-region canvas x y w h cursor-y) (send canvas call-as-primary-owner (λ () (let* ([text (send canvas get-editor)] [admin (send text get-admin)] [nwb (box 0)] [nhb (box 0)]) (send admin get-view #f #f nwb nhb) (let* ([nw (unbox nwb)] [nh (unbox nhb)] [nx x] [raw-y (- (+ y (/ h 2)) (/ nh 2))] [ny (if (and cursor-y (not (<= raw-y cursor-y (+ raw-y nh)))) (- cursor-y (/ nh 2)) raw-y)]) (send canvas scroll-to nx ny nw nh #t) (void)))))) ;; get-visible-area : admin -> number number number number ;; returns the visible area for this admin (define/private (get-visible-area admin) (let ([bx (box 0)] [by (box 0)] [bw (box 0)] [bh (box 0)]) (send admin get-view bx by bw bh) (values (unbox bx) (unbox by) (unbox bw) (unbox bh)))) (define/private (collapse) (let* ([target (get-edit-target-window)]) (cond [(memq target definitions-canvases) (collapse-definitions target)] [(memq target interactions-canvases) (collapse-interactions target)] [else (bell)]))) (define/private (collapse-definitions target) (handle-collapse target (λ () definitions-canvases) (λ (c) (set! definitions-canvases c)))) (define/private (collapse-interactions target) (handle-collapse target (λ () interactions-canvases) (λ (c) (set! interactions-canvases c)))) (define/private (handle-collapse target get-canvases set-canvases!) (if (= 1 (length (get-canvases))) (bell) (let* ([old-percentages (send resizable-panel get-percentages)] [soon-to-be-bigger-canvas #f] [percentages (if (eq? (car (get-canvases)) target) (begin (set! soon-to-be-bigger-canvas (cadr (get-canvases))) (cons (+ (car old-percentages) (cadr old-percentages)) (cddr old-percentages))) (let loop ([canvases (cdr (get-canvases))] [prev-canvas (car (get-canvases))] [percentages (cdr old-percentages)] [prev-percentage (car old-percentages)]) (cond [(null? canvases) (error 'collapse "internal error.1")] [(null? percentages) (error 'collapse "internal error.2")] [else (if (eq? (car canvases) target) (begin (set! soon-to-be-bigger-canvas prev-canvas) (cons (+ (car percentages) prev-percentage) (cdr percentages))) (cons prev-percentage (loop (cdr canvases) (car canvases) (cdr percentages) (car percentages))))])))]) (unless soon-to-be-bigger-canvas (error 'collapse "internal error.3")) (set-canvases! (remq target (get-canvases))) (update-shown) (let ([target-admin (send target call-as-primary-owner (λ () (send (send target get-editor) get-admin)))] [to-be-bigger-admin (send soon-to-be-bigger-canvas call-as-primary-owner (λ () (send (send soon-to-be-bigger-canvas get-editor) get-admin)))]) (let-values ([(bx by bw bh) (get-visible-area target-admin)]) ;; this line makes the soon-to-be-bigger-canvas bigger ;; if it fails, we're out of luck, but at least we don't crash. (with-handlers ([exn:fail? (λ (x) (void))]) (send resizable-panel set-percentages percentages)) (let-values ([(ax ay aw ah) (get-visible-area to-be-bigger-admin)]) (send soon-to-be-bigger-canvas scroll-to bx (- by (/ (- ah bh) 2)) aw ah #t)))) (send target set-editor #f) (send soon-to-be-bigger-canvas focus)))) ; ; ; ; ; ; ; ; ; ; ;;; ; ;; ;;; ; ; ; ; ;; ;; ;;; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;; ; ; ;;; ; ; ; ; ; ;;;; ; ; ;; ; ; ; ; (define interactions-shown? #t) (define definitions-shown? #t) (define/private (toggle-show/hide-definitions) (set! definitions-shown? (not definitions-shown?)) (unless definitions-shown? (set! interactions-shown? #t))) (define/private (toggle-show/hide-interactions) (set! interactions-shown? (not interactions-shown?)) (unless interactions-shown? (set! definitions-shown? #t))) (define/override (update-shown) (super update-shown) (let ([new-children (foldl (λ (shown? children sofar) (if shown? (append children sofar) sofar)) null (list interactions-shown? definitions-shown?) (list interactions-canvases definitions-canvases))] [p (preferences:get 'drscheme:unit-window-size-percentage)]) (update-defs/ints-resize-corner) (send definitions-item set-label (if definitions-shown? (string-constant hide-definitions-menu-item-label) (string-constant show-definitions-menu-item-label))) (send interactions-item set-label (if interactions-shown? (string-constant hide-interactions-menu-item-label) (string-constant show-interactions-menu-item-label))) (send resizable-panel begin-container-sequence) ;; this might change the unit-window-size-percentage, so save/restore it (send resizable-panel change-children (λ (l) new-children)) (preferences:set 'drscheme:unit-window-size-percentage p) ;; restore preferred interactions/definitions sizes (when (and (= 1 (length definitions-canvases)) (= 1 (length interactions-canvases)) (= 2 (length new-children))) (with-handlers ([exn:fail? (λ (x) (void))]) (send resizable-panel set-percentages (list p (- 1 p)))))) (send resizable-panel end-container-sequence) (when (ormap (λ (child) (and (is-a? child editor-canvas%) (not (send child has-focus?)))) (send resizable-panel get-children)) (let loop ([children (send resizable-panel get-children)]) (cond [(null? children) (void)] [else (let ([child (car children)]) (if (is-a? child editor-canvas%) (send child focus) (loop (cdr children))))]))) (for-each (λ (get-item) (let ([item (get-item)]) (when item (send item enable definitions-shown?)))) (list (λ () (file-menu:get-revert-item)) (λ () (file-menu:get-save-item)) (λ () (file-menu:get-save-as-item)) ;(λ () (file-menu:save-as-text-item)) ; Save As Text... (λ () (file-menu:get-print-item)))) (send file-menu:print-transcript-item enable interactions-shown?)) (define/augment (can-close?) (and (andmap (lambda (tab) (or (eq? tab current-tab) (and (send (send tab get-defs) can-close?) (send (send tab get-ints) can-close?)))) tabs) (send interactions-text can-close?) (inner #t can-close?))) (define/augment (on-close) (inner (void) on-close) (for-each (lambda (tab) (unless (eq? tab current-tab) (send (send tab get-defs) on-close) (send (send tab get-ints) on-close))) tabs) (when (eq? this newest-frame) (set! newest-frame #f)) (when logging (stop-logging)) (remove-show-status-line-callback) (send interactions-text on-close)) ;; execute-callback : -> void ;; uses the state of the button to determine if an execution is ;; already running. This function is called from many places, not ;; just the execute button. (define/public (execute-callback) (when (send execute-button is-enabled?) ;; if the language is not-a-language, and the buffer looks like a module, ;; automatically make the switch to the module language (let ([next-settings (send definitions-text get-next-settings)]) (when (is-a? (drscheme:language-configuration:language-settings-language next-settings) drscheme:language-configuration:not-a-language-language<%>) (when (looks-like-module? definitions-text) (let-values ([(module-language module-language-settings) (get-module-language/settings)]) (when (and module-language module-language-settings) (send definitions-text set-next-settings (drscheme:language-configuration:make-language-settings module-language module-language-settings))))))) (check-if-save-file-up-to-date) (when (preferences:get 'drscheme:show-interactions-on-execute) (ensure-rep-shown interactions-text)) (when logging (log-definitions) (log-interactions)) (send definitions-text just-executed) (send language-message set-yellow #f) (send interactions-canvas focus) (send interactions-text reset-console) (send interactions-text clear-undos) (let ([start 0]) (send definitions-text split-snip start) (let* ([name (send definitions-text get-port-name)] [text-port (open-input-text-editor definitions-text start 'end values name)]) (port-count-lines! text-port) (let* ([line (send definitions-text position-paragraph start)] [column (- start (send definitions-text paragraph-start-position line))] [relocated-port (relocate-input-port text-port (+ line 1) column (+ start 1))]) (port-count-lines! relocated-port) (send interactions-text evaluate-from-port relocated-port #t (λ () (send interactions-text clear-undos)))))))) (inherit revert save) (define/private (check-if-save-file-up-to-date) (when (send definitions-text save-file-out-of-date?) (let ([user-choice (message-box/custom (string-constant drscheme) (string-constant definitions-modified) (string-constant ignore) (string-constant revert) #f this '(caution default=2 number-order) 1)]) (case user-choice [(1) (void)] [(2) (revert)])))) (inherit get-menu-bar get-focus-object get-edit-target-object) (inherit is-maximized?) (define/override (on-size w h) (preferences:set 'drscheme:unit-window-width w) (preferences:set 'drscheme:unit-window-height h) (preferences:set 'drscheme:unit-window-max? (is-maximized?)) (super on-size w h)) (define on-move-timer-args #f) (define on-move-timer #f) (define/override (on-move x y) (cond [on-move-timer (set! on-move-timer-args (cons x y))] [else (set! on-move-timer-args (cons x y)) (set! on-move-timer (new timer% [notify-callback (λ () (set! on-move-timer #f) (set! on-move-timer-args #f) (preferences:set 'drscheme:frame:initial-position on-move-timer-args))] [interval 1000] [just-once? #t]))])) (define/override (get-editor) definitions-text) (define/override (get-canvas) (initialize-definitions-canvas) definitions-canvas) (define/private (initialize-definitions-canvas) (unless definitions-canvas (set! definitions-canvas (new (drscheme:get/extend:get-definitions-canvas) (parent resizable-panel) (editor definitions-text))))) (define/override (get-delegated-text) definitions-text) (define/override (get-open-here-editor) definitions-text) ;; wire the definitions text to the interactions text and initialize it. (define/private (init-definitions-text tab) (let ([defs (send tab get-defs)] [ints (send tab get-ints)]) (send defs set-interactions-text ints) (send defs set-tab tab) (send ints set-definitions-text defs) (send defs change-mode-to-match))) ; ; ; @@ ; @ @ ; @@@@@ $@$: @-@$ :@@+@ ; @ -@ @+ *$ @$ -@ ; @ -$@$@ @ @ :@@$- ; @ $* @ @ @ *@ ; @: :$ @- *@ @ +$ @ :@ ; :@@$- -$$-@@@@+@$ $+@@: ; ; ; ; (define/public (get-current-tab) current-tab) ;; create-new-tab : -> void ;; creates a new tab and updates the GUI for that new tab (define/private create-new-tab (lambda ([filename #f]) (let* ([defs (new (drscheme:get/extend:get-definitions-text))] [tab-count (length tabs)] [new-tab (new (drscheme:get/extend:get-tab) (defs defs) (i tab-count) (frame this) (defs-shown? #t) (ints-shown? (not filename)))] [ints (make-object (drscheme:get/extend:get-interactions-text) new-tab)]) (send new-tab set-ints ints) (set! tabs (append tabs (list new-tab))) (send tabs-panel append (gui-utils:trim-string (if filename (get-tab-label-from-filename filename) (get-defs-tab-label defs #f)) 200)) (init-definitions-text new-tab) (when filename (send defs load-file filename)) (change-to-nth-tab (- (send tabs-panel get-number) 1)) (send ints initialize-console) (send tabs-panel set-selection (- (send tabs-panel get-number) 1)) (set! newest-frame this) (update-menu-bindings)))) ;; change-to-tab : tab -> void ;; updates current-tab, definitions-text, and interactactions-text ;; to be the nth tab. Also updates the GUI to show the new tab (inherit begin-container-sequence end-container-sequence) (define/private (change-to-tab tab) (let ([old-delegate (send definitions-text get-delegate)] [old-tab current-tab]) (save-visible-tab-regions) (set! current-tab tab) (set! definitions-text (send current-tab get-defs)) (set! interactions-text (send current-tab get-ints)) (begin-container-sequence) (for-each (λ (defs-canvas) (send defs-canvas set-editor definitions-text)) definitions-canvases) (for-each (λ (ints-canvas) (send ints-canvas set-editor interactions-text)) interactions-canvases) (update-save-message) (update-save-button) (language-changed) (send definitions-text update-frame-filename) (send definitions-text set-delegate old-delegate) (update-running (send current-tab is-running?)) (on-tab-change old-tab current-tab) (end-container-sequence) ;; restore-visible-tab-regions has to be outside the container sequence ;; or else things get moved again during the container sequence end (restore-visible-tab-regions))) (define/pubment (on-tab-change from-tab to-tab) (let ([old-enabled (send from-tab get-enabled)] [new-enabled (send to-tab get-enabled)]) (unless (eq? old-enabled new-enabled) (if new-enabled (enable-evaluation) (disable-evaluation)))) (let ([from-defs (send from-tab get-defs)] [to-defs (send to-tab get-defs)]) (let ([delegate (send from-defs get-delegate)]) (send from-defs set-delegate #f) (send to-defs set-delegate delegate))) (inner (void) on-tab-change from-tab to-tab)) (define/public (next-tab) (change-to-delta-tab +1)) (define/public (prev-tab) (change-to-delta-tab -1)) (define/private (change-to-delta-tab dt) (change-to-nth-tab (modulo (+ (send current-tab get-i) dt) (length tabs)))) (define/private (close-current-tab) (cond [(null? tabs) (void)] [(null? (cdr tabs)) (void)] [else (let loop ([l-tabs tabs]) (cond [(null? l-tabs) (error 'close-current-tab "uh oh.3")] [else (let ([tab (car l-tabs)]) (if (eq? tab current-tab) (when (close-tab tab) (for-each (lambda (t) (send t set-i (- (send t get-i) 1))) (cdr l-tabs)) (set! tabs (remq tab tabs)) (send tabs-panel delete (send tab get-i)) (update-menu-bindings) (change-to-tab (cond [(< (send tab get-i) (length tabs)) (list-ref tabs (send tab get-i))] [else (last tabs)]))) (loop (cdr l-tabs))))]))])) (define/private (close-tab tab) (cond [(send tab can-close?) (send tab on-close) #t] [else #f])) (define/public (open-in-new-tab filename) (create-new-tab filename)) (define/private (change-to-nth-tab n) (unless (< n (length tabs)) (error 'change-to-nth-tab "number too big ~s" n)) (change-to-tab (list-ref tabs n))) (define/private (save-visible-tab-regions) (send current-tab set-visible-ints (get-tab-visible-regions interactions-text) interactions-shown?) (send current-tab set-visible-defs (get-tab-visible-regions definitions-text) definitions-shown?) (send current-tab set-focus-d/i (if (ormap (λ (x) (send x has-focus?)) interactions-canvases) 'ints 'defs))) (define/private (get-tab-visible-regions txt) (map (λ (canvas) (let-values ([(x y w h _) (get-visible-region canvas)]) (list x y w h))) (send txt get-canvases))) (define/private (restore-visible-tab-regions) (define (set-visible-regions txt regions ints?) (when regions (let* ([canvases (send txt get-canvases)] [canvases-count (length canvases)] [regions-count (length regions)]) (cond [(> canvases-count regions-count) (let loop ([i (- canvases-count regions-count)] [canvases canvases]) (unless (zero? i) (if ints? (collapse-interactions (car canvases)) (collapse-definitions (car canvases))) (loop (- i 1) (cdr canvases))))] [(= canvases-count regions-count) (void)] [(< canvases-count regions-count) (let loop ([i (- regions-count canvases-count)] [canvases canvases]) (unless (zero? i) (if ints? (split-interactions (car canvases)) (split-definitions (car canvases))) (loop (- i 1) (cdr canvases))))])) (for-each (λ (c r) (set-visible-tab-region txt c r)) (send txt get-canvases) regions))) (define (set-visible-tab-region txt canvas region) (let ([admin (send txt get-admin)]) (send admin scroll-to (first region) (second region) (third region) (fourth region)))) (let-values ([(vi is?) (send current-tab get-visible-ints)] [(vd ds?) (send current-tab get-visible-defs)]) (set! interactions-shown? is?) (set! definitions-shown? ds?) (update-shown) (set-visible-regions definitions-text vd #f) (set-visible-regions interactions-text vi #t)) (case (send current-tab get-focus-d/i) [(defs) (send (car definitions-canvases) focus)] [(ints) (send (car interactions-canvases) focus)])) (define/private (pathname-equal? p1 p2) (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (string=? (path->string (normal-case-path (normalize-path p1))) (path->string (normal-case-path (normalize-path p2)))))) (define/override (make-visible filename) (let loop ([tabs tabs]) (unless (null? tabs) (let* ([tab (car tabs)] [tab-filename (send (send tab get-defs) get-filename)]) (if (and tab-filename (pathname-equal? filename tab-filename)) (change-to-tab tab) (loop (cdr tabs))))))) (define/override (editing-this-file? filename) (ormap (λ (tab) (let ([fn (send (send tab get-defs) get-filename)]) (and fn (pathname-equal? fn filename)))) tabs)) (define/override (get-menu-item%) (class (super get-menu-item%) (inherit get-label get-plain-label) (define/override (restore-keybinding) (cond [(equal? (get-plain-label) (string-constant close)) (update-close-menu-item-shortcut this)] [(equal? (get-plain-label) (string-constant close-tab)) (update-close-tab-menu-item-shortcut this)] [else (super restore-keybinding)])) (super-new))) (define/private (update-menu-bindings) (when (preferences:get 'framework:menu-bindings) (when close-tab-menu-item (update-close-tab-menu-item-shortcut close-tab-menu-item)) (update-close-menu-item-shortcut (file-menu:get-close-item)))) (define/private (update-close-tab-menu-item-shortcut item) (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) (send item set-label (if just-one? (string-constant close-tab) (string-constant close-tab-amp))) (send item set-shortcut (if just-one? #f #\w)))) (define/private (update-close-menu-item-shortcut item) (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) (send item set-label (if just-one? (string-constant close-menu-item) (string-constant close))) (send item set-shortcut (if just-one? #\w #f)))) ;; ;; end tabs ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define/public (get-definitions-text) definitions-text) (define/public (get-interactions-text) interactions-text) (define/public (get-definitions/interactions-panel-parent) toolbar/rest-panel) (inherit delegated-text-shown? hide-delegated-text show-delegated-text) (define/override (add-show-menu-items show-menu) (super add-show-menu-items show-menu) (set! definitions-item (make-object menu:can-restore-menu-item% (string-constant hide-definitions-menu-item-label) (get-show-menu) (λ (_1 _2) (toggle-show/hide-definitions) (update-shown)) #\d (string-constant definitions-menu-item-help-string))) (set! interactions-item (make-object menu:can-restore-menu-item% (string-constant show-interactions-menu-item-label) (get-show-menu) (λ (_1 _2) (toggle-show/hide-interactions) (update-shown)) #\e (string-constant interactions-menu-item-help-string))) (new menu:can-restore-menu-item% (shortcut #\u) (label (if (delegated-text-shown?) (string-constant hide-overview) (string-constant show-overview))) (parent (get-show-menu)) (callback (λ (menu evt) (if (delegated-text-shown?) (begin (send menu set-label (string-constant show-overview)) (preferences:set 'framework:show-delegate? #f) (hide-delegated-text)) (begin (send menu set-label (string-constant hide-overview)) (preferences:set 'framework:show-delegate? #t) (show-delegated-text)))))) (set! module-browser-menu-item (new menu:can-restore-menu-item% (label (if module-browser-shown? (string-constant hide-module-browser) (string-constant show-module-browser))) (parent (get-show-menu)) (callback (λ (menu evt) (if module-browser-shown? (hide-module-browser) (show-module-browser)))))) (set! toolbar-menu (new menu% [parent show-menu] [label (string-constant toolbar)])) (set! toolbar-left-menu-item (new checkable-menu-item% [label (string-constant toolbar-on-left)] [parent toolbar-menu] [callback (λ (x y) (set-toolbar-left))] [checked #f])) (set! toolbar-top-menu-item (new checkable-menu-item% [label (string-constant toolbar-on-top)] [parent toolbar-menu] [callback (λ (x y) (set-toolbar-top))] [checked #f])) (set! toolbar-right-menu-item (new checkable-menu-item% [label (string-constant toolbar-on-right)] [parent toolbar-menu] [callback (λ (x y) (set-toolbar-right))] [checked #f])) (set! toolbar-hidden-menu-item (new checkable-menu-item% [label (string-constant toolbar-hidden)] [parent toolbar-menu] [callback (λ (x y) (set-toolbar-hidden))] [checked #f]))) ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;; ;;; ;; ; ; ; ; ;;; ; ;; ; ; ;;; ; ; ; ;;; ;;; ; ; ; ;; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ;; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;; ; ;; ; ; ;;;; ; ;; ; ;;; ; ; ;;; ;;;; ; ; ; ; (field [module-browser-shown? #f] [module-browser-parent-panel #f] [module-browser-panel #f] [module-browser-ec #f] [module-browser-button #f] [module-browser-lib-path-check-box #f] [module-browser-planet-path-check-box #f] [module-browser-name-length-choice #f] [module-browser-pb #f] [module-browser-menu-item 'module-browser-menu-item-unset]) (inherit open-status-line close-status-line update-status-line) (define/private (show-module-browser) (when module-browser-panel (when (can-browse-language?) (set! module-browser-shown? #t) (send module-browser-menu-item set-label (string-constant hide-module-browser)) (update-module-browser-pane)))) (define/private (hide-module-browser) (when module-browser-panel (set! module-browser-shown? #f) (send module-browser-menu-item set-label (string-constant show-module-browser)) (close-status-line 'plt:module-browser:mouse-over) (send module-browser-parent-panel change-children (λ (l) (remq module-browser-panel l))))) (define/private (can-browse-language?) (let* ([lang/config (preferences:get (drscheme:language-configuration:get-settings-preferences-symbol))] [lang (drscheme:language-configuration:language-settings-language lang/config)] [strs (send lang get-language-position)] [can-browse? (or (regexp-match #rx"Module" (last strs)) (ormap (λ (x) (regexp-match #rx"PLT" x)) strs))]) (unless can-browse? (message-box (string-constant drscheme) (string-constant module-browser-only-in-plt-and-module-langs))) can-browse?)) (define/private (update-module-browser-pane) (open-status-line 'plt:module-browser:mouse-over) (send module-browser-panel begin-container-sequence) (unless module-browser-ec (set! module-browser-pb (drscheme:module-overview:make-module-overview-pasteboard #t (λ (x) (mouse-currently-over x)))) (set! module-browser-ec (make-object editor-canvas% module-browser-panel module-browser-pb)) (let* ([show-callback (λ (cb key) (if (send cb get-value) (send module-browser-pb show-visible-paths key) (send module-browser-pb remove-visible-paths key)) (preferences:set 'drscheme:module-browser:hide-paths (send module-browser-pb get-hidden-paths)))] [mk-checkbox (λ (key label) (new check-box% (parent module-browser-panel) (label label) (value (not (memq key (preferences:get 'drscheme:module-browser:hide-paths)))) (callback (λ (cb _) (show-callback cb key)))))]) (set! module-browser-lib-path-check-box (mk-checkbox 'lib show-lib-paths)) (set! module-browser-planet-path-check-box (mk-checkbox 'planet show-planet-paths))) (set! module-browser-name-length-choice (new choice% (parent module-browser-panel) (label (string-constant module-browser-name-length)) (choices (list (string-constant module-browser-name-short) (string-constant module-browser-name-medium) (string-constant module-browser-name-long))) (selection (preferences:get 'drscheme:module-browser:name-length)) (callback (λ (x y) (let ([selection (send module-browser-name-length-choice get-selection)]) (preferences:set 'drscheme:module-browser:name-length selection) (update-module-browser-name-length selection)))))) (update-module-browser-name-length (preferences:get 'drscheme:module-browser:name-length)) (set! module-browser-button (new button% (parent module-browser-panel) (label refresh) (callback (λ (x y) (update-module-browser-pane))) (stretchable-width #t)))) (let ([p (preferences:get 'drscheme:module-browser-size-percentage)]) (send module-browser-parent-panel change-children (λ (l) (cons module-browser-panel (remq module-browser-panel l)))) (with-handlers ([exn:fail? void]) (send module-browser-parent-panel set-percentages (list p (- 1 p)))) (send module-browser-parent-panel end-container-sequence) (calculate-module-browser))) (define/private (update-module-browser-name-length i) (send module-browser-pb set-name-length (case i [(0) 'short] [(1) 'medium] [(2) 'long]))) (define/private (mouse-currently-over snips) (if (null? snips) (update-status-line 'plt:module-browser:mouse-over #f) (let* ([snip (car snips)] [lines (send snip get-lines)] [name (or (send snip get-filename) (send snip get-word))] [str (if lines (format (string-constant module-browser-filename-format) name lines) name)]) (update-status-line 'plt:module-browser:mouse-over str)))) (define/private (calculate-module-browser) (let ([mod-tab current-tab]) (let-values ([(old-break-thread old-custodian) (send mod-tab get-breakables)]) (open-status-line 'plt:module-browser) (update-status-line 'plt:module-browser status-compiling-definitions) (send module-browser-button enable #f) (send module-browser-lib-path-check-box enable #f) (send module-browser-planet-path-check-box enable #f) (send module-browser-name-length-choice enable #f) (disable-evaluation-in-tab current-tab) (drscheme:module-overview:fill-pasteboard module-browser-pb (drscheme:language:make-text/pos definitions-text 0 (send definitions-text last-position)) (λ (str) (update-status-line 'plt:module-browser (format module-browser-progress-constant str))) (λ (user-thread user-custodian) (send mod-tab set-breakables user-thread user-custodian))) (send mod-tab set-breakables old-break-thread old-custodian) (send mod-tab enable-evaluation) (send module-browser-button enable #t) (send module-browser-lib-path-check-box enable #t) (send module-browser-planet-path-check-box enable #t) (send module-browser-name-length-choice enable #t) (close-status-line 'plt:module-browser)))) ;; set-directory : text -> void ;; sets the current-directory and current-load-relative-directory ;; based on the file saved in the definitions-text (define/private (set-directory definitions-text) (let* ([tmp-b (box #f)] [fn (send definitions-text get-filename tmp-b)]) (unless (unbox tmp-b) (when fn (let-values ([(base name dir?) (split-path fn)]) (current-directory base) (current-load-relative-directory base)))))) ; ; ; ; ; ; ; ; ;; ;; ;;; ; ;; ; ; ;;; ; ;; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;;;;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;;;; ; ; ;; ; ;;; ; ; ; (define execute-menu-item #f) (define file-menu:print-transcript-item #f) (define file-menu:create-new-tab-item #f) (define/override (file-menu:between-new-and-open file-menu) (set! file-menu:create-new-tab-item (new menu:can-restore-menu-item% (label (string-constant new-tab)) (shortcut #\=) (parent file-menu) (callback (λ (x y) (create-new-tab)))))) [define/override file-menu:between-open-and-revert (lambda (file-menu) (super file-menu:between-open-and-revert file-menu) (make-object separator-menu-item% file-menu))] (define close-tab-menu-item #f) (define/override (file-menu:between-close-and-quit file-menu) (set! close-tab-menu-item (new (get-menu-item%) (label (string-constant close-tab)) (demand-callback (λ (item) (send item enable (1 . < . (send tabs-panel get-number))))) (parent file-menu) (callback (λ (x y) (close-current-tab))))) (super file-menu:between-close-and-quit file-menu)) (define/override (file-menu:save-string) (string-constant save-definitions)) (define/override (file-menu:save-as-string) (string-constant save-definitions-as)) (define/override (file-menu:between-save-as-and-print file-menu) (let ([sub-menu (make-object menu% (string-constant save-other) file-menu)]) (make-object menu:can-restore-menu-item% (string-constant save-definitions-as-text) sub-menu (λ (_1 _2) (let ([filename (send definitions-text put-file #f #f)]) (when filename (send definitions-text save-file/gui-error filename 'text))))) (make-object menu:can-restore-menu-item% (string-constant save-interactions) sub-menu (λ (_1 _2) (send interactions-text save-file/gui-error))) (make-object menu:can-restore-menu-item% (string-constant save-interactions-as) sub-menu (λ (_1 _2) (let ([filename (send interactions-text put-file #f #f)]) (when filename (send interactions-text save-file/gui-error filename 'standard))))) (make-object menu:can-restore-menu-item% (string-constant save-interactions-as-text) sub-menu (λ (_1 _2) (let ([filename (send interactions-text put-file #f #f)]) (when filename (send interactions-text save-file/gui-error filename 'text))))) (make-object separator-menu-item% file-menu) (set! logging-menu-item (make-object menu:can-restore-menu-item% (string-constant log-definitions-and-interactions) file-menu (λ (x y) (if logging (stop-logging) (start-logging))))) (make-object separator-menu-item% file-menu) (super file-menu:between-save-as-and-print file-menu))) [define/override file-menu:print-string (λ () (string-constant print-definitions))] (define/override (file-menu:between-print-and-close file-menu) (set! file-menu:print-transcript-item (make-object menu:can-restore-menu-item% (string-constant print-interactions) file-menu (λ (_1 _2) (send interactions-text print #t #t (preferences:get 'framework:print-output-mode))))) (super file-menu:between-print-and-close file-menu)) (define/override (edit-menu:between-find-and-preferences edit-menu) (new menu-item% [label (string-constant complete-word)] [shortcut #\/] [parent edit-menu] [demand-callback (λ (mi) (send mi enable (let ([ed (get-edit-target-object)]) (and ed (is-a? ed text:autocomplete<%>)))))] [callback (λ (x y) (send (get-edit-target-object) auto-complete))]) (super edit-menu:between-find-and-preferences edit-menu) (add-modes-submenu edit-menu)) ;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key))) (define capability-menu-items (make-hasheq)) (define/public (register-capability-menu-item key menu) (let ([items (send menu get-items)]) (when (null? items) (error 'register-capability-menu-item "menu ~e has no items" menu)) (let* ([menu-item (last items)] [this-one (list menu-item (- (length items) 1) key)] [old-ones (hash-ref capability-menu-items menu (λ () '()))]) (hash-set! capability-menu-items menu (cons this-one old-ones))))) (define/private (update-items/capability menu) (let ([new-items (get-items/capability menu)]) (for-each (λ (i) (send i delete)) (send menu get-items)) (for-each (λ (i) (send i restore)) new-items))) (define/private (get-items/capability menu) (let loop ([capability-items (reverse (hash-ref capability-menu-items menu (λ () '())))] [all-items (send menu get-items)] [i 0]) (cond [(null? capability-items) all-items] [else (let* ([cap-item-list (car capability-items)] [cap-item (list-ref cap-item-list 0)] [cap-num (list-ref cap-item-list 1)] [cap-key (list-ref cap-item-list 2)]) (cond [(= cap-num i) (let ([is-on? (get-current-capability-value cap-key)]) (cond [is-on? (cond [(null? all-items) (cons cap-item (loop (cdr capability-items) null (+ i 1)))] [(eq? (car all-items) cap-item) (cons cap-item (loop (cdr capability-items) (cdr all-items) (+ i 1)))] [else (cons cap-item (loop (cdr capability-items) all-items (+ i 1)))])] [else (cond [(null? all-items) (loop (cdr capability-items) null (+ i 1))] [(eq? (car all-items) cap-item) (loop (cdr capability-items) (cdr all-items) (+ i 1))] [else (loop (cdr capability-items) all-items (+ i 1))])]))] [else (cons (car all-items) (loop capability-items (cdr all-items) (+ i 1)))]))]))) (define/private (get-current-capability-value key) (let* ([language-settings (send (get-definitions-text) get-next-settings)] [new-language (drscheme:language-configuration:language-settings-language language-settings)]) (send new-language capability-value key))) (define language-menu 'uninited-language-menu) (define scheme-menu 'scheme-menu-not-yet-init) (define insert-menu 'insert-menu-not-yet-init) (define/public (get-insert-menu) insert-menu) (define/public (get-special-menu) (define context (continuation-mark-set->context (current-continuation-marks))) (fprintf (current-error-port) "called get-special-menu: ~a\n" (if (and (pair? context) (pair? (cdr context))) (format "~s ~s" (car (cadr context)) (cdr (cadr context))) "<>")) insert-menu) (define/public (choose-language-callback) (let ([new-settings (drscheme:language-configuration:language-dialog #f (send definitions-text get-next-settings) this)]) (when new-settings (send definitions-text set-next-settings new-settings)))) ;; must be called from on-demand (on each menu click), or the state won't be handled properly (define/private (update-teachpack-menu) (for-each (λ (item) (send item delete)) teachpack-items) (let ([tp-callbacks (get-current-capability-value 'drscheme:teachpack-menu-items)]) (cond [tp-callbacks (let* ([language (drscheme:language-configuration:language-settings-language (send (get-definitions-text) get-next-settings))] [settings (drscheme:language-configuration:language-settings-settings (send (get-definitions-text) get-next-settings))] [tp-names ((teachpack-callbacks-get-names tp-callbacks) settings)] [update-settings (λ (settings) (send (get-definitions-text) set-next-settings (drscheme:language-configuration:make-language-settings language settings)) (send (get-definitions-text) teachpack-changed))]) (set! teachpack-items (list* (make-object separator-menu-item% language-menu) (new menu:can-restore-menu-item% [label (string-constant add-teachpack-menu-item-label)] [parent language-menu] [callback (λ (_1 _2) (update-settings ((teachpack-callbacks-add tp-callbacks) settings this)))]) (let ([mi (new menu:can-restore-menu-item% [label (string-constant clear-all-teachpacks-menu-item-label)] [parent language-menu] [callback (λ (_1 _2) (update-settings ((teachpack-callbacks-remove-all tp-callbacks) settings)))])]) (send mi enable (not (null? tp-names))) mi) (map (λ (name) (new menu:can-restore-menu-item% [label (gui-utils:format-literal-label (string-constant clear-teachpack) name)] [parent language-menu] [callback (λ (item evt) (update-settings ((teachpack-callbacks-remove tp-callbacks) settings name)))])) tp-names))))] [else (set! teachpack-items (list (new menu:can-restore-menu-item% [label (string-constant add-teachpack-menu-item-label)] [parent language-menu] [callback (λ (_1 _2) (message-box (string-constant drscheme) (gui-utils:format-literal-label (string-constant teachpacks-only-in-languages) (apply string-append (reverse (filter values (map (λ (l) (and (send l capability-value 'drscheme:teachpack-menu-items) (format "\n ~a" (send l get-language-name)))) (drscheme:language-configuration:get-languages)))))) this))])))]))) (define/private (initialize-menus) (let* ([mb (get-menu-bar)] [language-menu-on-demand (λ (menu-item) (update-teachpack-menu))] [_ (set! language-menu (make-object (get-menu%) (string-constant language-menu-name) mb #f language-menu-on-demand))] [_ (set! scheme-menu (new (get-menu%) [label (drscheme:language:get-capability-default 'drscheme:language-menu-title)] [parent mb]))] [send-method (λ (method) (λ (_1 _2) (let ([text (get-focus-object)]) (when (is-a? text scheme:text<%>) (method text)))))] [show/hide-capability-menus (λ () (for-each (λ (menu) (update-items/capability menu)) (send (get-menu-bar) get-items)))]) (make-object menu:can-restore-menu-item% (string-constant choose-language-menu-item-label) language-menu (λ (_1 _2) (choose-language-callback)) #\l) (set! execute-menu-item (make-object menu:can-restore-menu-item% (string-constant execute-menu-item-label) scheme-menu (λ (_1 _2) (execute-callback)) #\t (string-constant execute-menu-item-help-string))) (make-object menu:can-restore-menu-item% (string-constant break-menu-item-label) scheme-menu (λ (_1 _2) (send current-tab break-callback)) #\b (string-constant break-menu-item-help-string)) (make-object menu:can-restore-menu-item% (string-constant kill-menu-item-label) scheme-menu (λ (_1 _2) (send interactions-text kill-evaluation)) #\k (string-constant kill-menu-item-help-string)) (when (custodian-memory-accounting-available?) (new menu-item% [label (string-constant limit-memory-menu-item-label)] [parent scheme-menu] [callback (λ (item b) (let ([num (get-mbytes this (let ([limit (send interactions-text get-custodian-limit)]) (and limit (floor (/ limit 1024 1024)))))]) (when num (cond [(eq? num #t) (preferences:set 'drscheme:limit-memory #f) (send interactions-text set-custodian-limit #f)] [else (preferences:set 'drscheme:limit-memory (* 1024 1024 num)) (send interactions-text set-custodian-limit (* 1024 1024 num))]))))])) (new menu:can-restore-menu-item% (label (string-constant clear-error-highlight-menu-item-label)) (parent scheme-menu) (callback (λ (_1 _2) (let ([ints (send (get-current-tab) get-ints)]) (send ints reset-error-ranges)))) (help-string (string-constant clear-error-highlight-item-help-string)) (demand-callback (λ (item) (let ([ints (send (get-current-tab) get-ints)]) (send item enable (send ints get-error-ranges)))))) (make-object separator-menu-item% scheme-menu) (make-object menu:can-restore-menu-item% (string-constant create-executable-menu-item-label) scheme-menu (λ (x y) (create-executable this))) (make-object menu:can-restore-menu-item% (string-constant module-browser...) scheme-menu (λ (x y) (drscheme:module-overview:module-overview this))) (make-object separator-menu-item% scheme-menu) (make-object menu:can-restore-menu-item% (string-constant reindent-menu-item-label) scheme-menu (send-method (λ (x) (send x tabify-selection)))) (make-object menu:can-restore-menu-item% (string-constant reindent-all-menu-item-label) scheme-menu (send-method (λ (x) (send x tabify-all))) #\i) (make-object menu:can-restore-menu-item% (string-constant box-comment-out-menu-item-label) scheme-menu (send-method (λ (x) (send x box-comment-out-selection)))) (make-object menu:can-restore-menu-item% (string-constant semicolon-comment-out-menu-item-label) scheme-menu (send-method (λ (x) (send x comment-out-selection)))) (make-object menu:can-restore-menu-item% (string-constant uncomment-menu-item-label) scheme-menu (λ (x y) (let ([text (get-focus-object)]) (when (is-a? text text%) (let ([admin (send text get-admin)]) (cond [(is-a? admin editor-snip-editor-admin<%>) (let ([es (send admin get-snip)]) (cond [(is-a? es comment-box:snip%) (let ([es-admin (send es get-admin)]) (when es-admin (let ([ed (send es-admin get-editor)]) (when (is-a? ed scheme:text<%>) (send ed uncomment-box/selection)))))] [else (send text uncomment-selection)]))] [else (send text uncomment-selection)])))))) (set! insert-menu (new (get-menu%) [label (string-constant insert-menu)] [parent mb] [demand-callback (λ (insert-menu) ;; just here for convience -- it actually works on all menus, not just the special menu (show/hide-capability-menus))])) (let ([has-editor-on-demand (λ (menu-item) (let ([edit (get-edit-target-object)]) (send menu-item enable (and edit (is-a? edit editor<%>)))))] [callback (λ (menu evt) (let ([edit (get-edit-target-object)]) (when (and edit (is-a? edit editor<%>)) (let ([number (get-fraction-from-user this)]) (when number (send edit insert (number-snip:make-fraction-snip number #f))))) #t))] [insert-lambda (λ () (let ([edit (get-edit-target-object)]) (when (and edit (is-a? edit editor<%>)) (send edit insert "\u03BB"))) #t)] [insert-large-semicolon-letters (λ () (let ([edit (get-edit-target-object)]) (when edit (let ([language-settings (send definitions-text get-next-settings)]) (let-values ([(comment-prefix comment-character) (if language-settings (send (drscheme:language-configuration:language-settings-language language-settings) get-comment-character) (values ";" #\;))]) (insert-large-letters comment-prefix comment-character edit this))))))] [c% (get-menu-item%)]) (frame:add-snip-menu-items insert-menu c% (λ (item) (let ([label (send item get-label)]) (cond [(equal? label (string-constant insert-comment-box-menu-item-label)) (register-capability-menu-item 'drscheme:special:insert-comment-box insert-menu)] [(equal? label (string-constant insert-image-item)) (register-capability-menu-item 'drscheme:special:insert-image insert-menu)])))) (make-object c% (string-constant insert-fraction-menu-item-label) insert-menu callback #f #f has-editor-on-demand) (register-capability-menu-item 'drscheme:special:insert-fraction insert-menu) (make-object c% (string-constant insert-large-letters...) insert-menu (λ (x y) (insert-large-semicolon-letters)) #f #f has-editor-on-demand) (register-capability-menu-item 'drscheme:special:insert-large-letters insert-menu) (make-object c% (string-constant insert-lambda) insert-menu (λ (x y) (insert-lambda)) #\\ #f has-editor-on-demand) (register-capability-menu-item 'drscheme:special:insert-lambda insert-menu)) (make-object separator-menu-item% (get-show-menu)) (new menu:can-restore-menu-item% (shortcut (if (eq? (system-type) 'macosx) #\r #\m)) (label (string-constant split-menu-item-label)) (parent (get-show-menu)) (shortcut-prefix (if (eq? (system-type) 'macosx) (cons 'shift (get-default-shortcut-prefix)) (get-default-shortcut-prefix))) (callback (λ (x y) (split))) (demand-callback (λ (item) (split-demand item)))) (new menu:can-restore-menu-item% (shortcut #\r) (label (string-constant collapse-menu-item-label)) (parent (get-show-menu)) (callback (λ (x y) (collapse))) (demand-callback (λ (item) (collapse-demand item)))) (frame:reorder-menus this))) ; ; ; ; ; ++-@@- -+@+- +++: :++ ; +@@-+@ -@-:-@--@- -@ ; :@: @: @+ ++ @::@::@ ; :@ @: @@@@@@@ +--@--* ; :@ @: @- -@+*+@: ; -@: :@- +@:::+@ :@@:@@ ; @@@ +@@: +@@@+: ++ ++ ; ; ; (define definitions-text (new (drscheme:get/extend:get-definitions-text))) ;; tabs : (listof tab) (define tabs (list (new (drscheme:get/extend:get-tab) (defs definitions-text) (frame this) (i 0) (defs-shown? #t) (ints-shown? #t)))) (define/public-final (get-tabs) tabs) ;; current-tab : tab ;; corresponds to the tabs-panel's active button. (define current-tab (car tabs)) (define interactions-text (new (drscheme:get/extend:get-interactions-text) (context (car tabs)))) (send (car tabs) set-ints interactions-text) (init-definitions-text (car tabs)) (super-new (filename filename) (style '(toolbar-button)) (width (preferences:get 'drscheme:unit-window-width)) (height (preferences:get 'drscheme:unit-window-height))) (initialize-menus) ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;;; ; ;; ;;; ; ; ;;; ; ; ;;; ; ; ;;;; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ;;;;;; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ;;;;; ; ; ;;;; ; ; ;;;;; ; ;;; ;; ; ;; ; ; ; ; ; ; ; ; ; (define toolbar/rest-panel (new vertical-panel% [parent (get-area-container)])) ;; most contain only top-panel (or nothing) (define top-outer-panel (new horizontal-panel% [parent toolbar/rest-panel] [alignment '(right top)] [stretchable-height #f])) [define top-panel (make-object horizontal-panel% top-outer-panel)] [define name-panel (new horizontal-panel% (parent top-panel) (alignment '(left center)) (stretchable-width #f) (stretchable-height #f))] (define panel-with-tabs (new vertical-panel% (parent (get-definitions/interactions-panel-parent)))) (define tabs-panel (new tab-panel% (font small-control-font) (parent panel-with-tabs) (stretchable-height #f) (style '(deleted no-border)) (choices '("first name")) (callback (λ (x y) (let ([sel (send tabs-panel get-selection)]) (when sel (change-to-nth-tab sel))))))) [define resizable-panel (new (if (preferences:get 'drscheme:defs/ints-horizontal) horizontal-dragable/def-int% vertical-dragable/def-int%) (unit-frame this) (parent panel-with-tabs))] [define definitions-canvas #f] (initialize-definitions-canvas) [define definitions-canvases (list definitions-canvas)] [define interactions-canvas (new (drscheme:get/extend:get-interactions-canvas) (parent resizable-panel) (editor interactions-text))] [define interactions-canvases (list interactions-canvas)] (define/public (get-definitions-canvases) ;; before definition, just return null (if (pair? definitions-canvases) definitions-canvases null)) (define/public (get-interactions-canvases) ;; before definition, just return null (if (pair? interactions-canvases) interactions-canvases null)) (public get-definitions-canvas get-interactions-canvas) [define get-definitions-canvas (λ () definitions-canvas)] [define get-interactions-canvas (λ () interactions-canvas)] (set! save-button (new switchable-button% [parent top-panel] [callback (λ (x) (when definitions-text (save) (send definitions-canvas focus)))] [bitmap save-bitmap] [label (string-constant save-button-label)])) (register-toolbar-button save-button) (set! name-message (new drs-name-message% [parent name-panel])) (send name-message stretchable-width #t) (send name-message set-allow-shrinking 200) [define teachpack-items null] [define break-button (void)] [define execute-button (void)] [define button-panel (new horizontal-panel% [parent top-panel] [spacing 2])] (define/public (get-execute-button) execute-button) (define/public (get-break-button) break-button) (define/public (get-button-panel) button-panel) (inherit get-info-panel) (define running-canvas (new running-canvas% [parent (get-info-panel)])) [define func-defs-canvas (new func-defs-canvas% (parent name-panel) (frame this))] (set! execute-button (new switchable-button% [parent button-panel] [callback (λ (x) (execute-callback))] [bitmap execute-bitmap] [label (string-constant execute-button-label)])) (register-toolbar-button execute-button) (set! break-button (new switchable-button% [parent button-panel] [callback (λ (x) (send current-tab break-callback))] [bitmap break-bitmap] [label (string-constant break-button-label)])) (register-toolbar-button break-button) (send button-panel stretchable-height #f) (send button-panel stretchable-width #f) (send top-panel change-children (λ (l) (list name-panel save-button (make-object vertical-panel% top-panel) ;; spacer button-panel))) (send top-panel stretchable-height #f) (inherit get-label) (let ([m (send definitions-canvas get-editor)]) (set-save-init-shown? (and m (send m is-modified?)))) (define language-message (let* ([info-panel (get-info-panel)] [p (new vertical-panel% [parent info-panel] [alignment '(left center)])] [language-message (new language-label-message% [parent p] [frame this])]) (send info-panel change-children (λ (l) (list* p (remq* (list p) l)))) language-message)) (update-save-message) (update-save-button) (language-changed) (cond [filename (set! definitions-shown? #t) (set! interactions-shown? #f)] [else (set! definitions-shown? #t) (set! interactions-shown? #t)]) (update-shown) (when (= 2 (length (send resizable-panel get-children))) (send resizable-panel set-percentages (let ([p (preferences:get 'drscheme:unit-window-size-percentage)]) (list p (- 1 p))))) (set-label-prefix (string-constant drscheme)) (set! newest-frame this) (send definitions-canvas focus))) (define running-bitmap (include-bitmap (lib "b-run.png" "icons"))) (define waiting-bitmap (include-bitmap (lib "b-wait.png" "icons"))) (define waiting2-bitmap (include-bitmap (lib "b-wait2.png" "icons"))) (define running/waiting-bitmaps (list running-bitmap waiting-bitmap waiting2-bitmap)) (define running-canvas% (class canvas% (inherit get-dc refresh get-client-size) (define/public (set-running r?) (unless (eq? r? is-running?) (set! is-running? r?) (refresh))) (define is-running? #f) (define toggle? #t) (define timer #f) (define inside? #f) (define/override (on-event evt) (let-values ([(w h) (get-client-size)]) (let ([new-inside? (and (<= 0 (send evt get-x) w) (<= 0 (send evt get-y) h))] [old-inside? inside?]) (set! inside? new-inside?) (cond [(and new-inside? (not old-inside?)) (unless is-running? (set! timer (new timer% [notify-callback (λ () (set! toggle? (not toggle?)) (refresh))] [interval 200])))] [(and (not new-inside?) old-inside? timer) (send timer stop) (set! timer #f)])))) (define/override (on-paint) (let ([dc (get-dc)] [bm (if is-running? running-bitmap (if toggle? waiting-bitmap waiting2-bitmap))]) (let-values ([(cw ch) (get-client-size)]) (send dc draw-bitmap bm (- (/ cw 2) (/ (send bm get-width) 2)) (- (/ ch 2) (/ (send bm get-height) 2)) 'solid (send the-color-database find-color "black") (send bm get-loaded-mask))))) (super-new [stretchable-width #f] [stretchable-height #f] [style '(transparent)]) (inherit min-width min-height) (min-width (apply max (map (λ (x) (send x get-width)) running/waiting-bitmaps))) (min-height (apply max (map (λ (x) (send x get-height)) running/waiting-bitmaps))))) ;; get-mbytes : top-level-window -> (union #f ;; cancel ;; integer[>=100] ;; a limit ;; #t) ;; no limit (define (get-mbytes parent current-limit) (define d (new dialog% [label (string-constant drscheme)] [parent parent])) (define msg1 (new message% [parent d] [label (string-constant limit-memory-msg-1)])) (define msg1.5 (new message% [parent d] [label (string-constant limit-memory-msg-2)])) (define outer-hp (new horizontal-panel% [parent d] [alignment '(center bottom)])) (define rb (new radio-box% [label #f] [choices (list (string-constant limit-memory-unlimited) (string-constant limit-memory-limited))] [callback (λ (a b) (grayizie))] [parent outer-hp])) (define (grayizie) (case (send rb get-selection) [(0) (send tb enable #f) (send msg2 enable #f) (background gray-foreground-sd)] [(1) (send tb enable #t) (send msg2 enable #t) (background black-foreground-sd) (let ([e (send tb get-editor)]) (send e set-position 0 (send e last-position))) (send tb focus)]) (update-ok-button-state)) (define hp (new horizontal-panel% [parent outer-hp] [stretchable-height #f] [stretchable-width #f])) (define tb (new text-field% [label #f] [parent hp] [init-value (if current-limit (format "~a" current-limit) "128")] [stretchable-width #f] [min-width 100] [callback (λ (tf e) (let ([ed (send tf get-editor)]) (cond [(is-valid-number? ed) (background clear-sd)] [else (background yellow-sd)])) (update-ok-button-state))])) (define (update-ok-button-state) (case (send rb get-selection) [(0) (send ok-button enable #t)] [(1) (send ok-button enable (is-valid-number? (send tb get-editor)))])) (define msg2 (new message% [parent hp] [label (string-constant limit-memory-megabytes)])) (define bp (new horizontal-panel% [parent d])) (define-values (ok-button cancel-button) (gui-utils:ok/cancel-buttons bp (λ (a b) (case (send rb get-selection) [(0) (set! result #t)] [(1) (set! result (string->number (send (send tb get-editor) get-text)))]) (send d show #f)) (λ (a b) (send d show #f)))) (define result #f) (define clear-sd (make-object style-delta%)) (define yellow-sd (make-object style-delta%)) (define black-foreground-sd (make-object style-delta%)) (define gray-foreground-sd (make-object style-delta%)) (define (is-valid-number? txt) (let* ([n (string->number (send txt get-text))]) (and n (integer? n) (100 . <= . n)))) (define (background sd) (let ([txt (send tb get-editor)]) (send txt change-style sd 0 (send txt last-position)))) (send clear-sd set-delta-background "white") (send yellow-sd set-delta-background "yellow") (send black-foreground-sd set-delta-foreground "black") (send gray-foreground-sd set-delta-foreground "gray") (send d set-alignment 'left 'center) (send bp set-alignment 'right 'center) (when current-limit (send rb set-selection 1)) (update-ok-button-state) (grayizie) (send tb focus) (let ([e (send tb get-editor)]) (send e set-position 0 (send e last-position))) (send d show #t) result) (define (limit-length l n) (let loop ([l l] [n n]) (cond [(or (null? l) (zero? n)) null] [else (cons (car l) (loop (cdr l) (- n 1)))]))) (define (remove-duplicate-languages l) (reverse (let loop ([l (reverse l)]) (cond [(null? l) l] [else (if (member (car (car l)) (map car (cdr l))) (loop (cdr l)) (cons (car l) (loop (cdr l))))])))) (define language-label-message% (class name-message% (init-field frame) (inherit refresh) (inherit set-message) (define yellow? #f) (define/override (get-background-color) (and yellow? "yellow")) (define/public (set-yellow y?) (set! yellow? y?) (refresh)) (define/public (set-yellow/lang y? lang) (set-message #f lang) (set-yellow y?)) (define/override (fill-popup menu reset) (let ([added-one? #f]) (send (new menu-item% [label (string-constant recent-languages)] [callback void] [parent menu]) enable #f) (for-each (λ (name/settings) (let* ([name (car name/settings)] [marshalled-settings (cdr name/settings)] [lang (ormap (λ (l) (and (equal? (send l get-language-name) name) l)) (drscheme:language-configuration:get-languages))]) (when lang ;; this test can fail when a language has been added wrongly via the tools interface ;; just ignore that menu item, in that case. (let ([settings (or (send lang unmarshall-settings marshalled-settings) (send lang default-settings))]) (when lang (set! added-one? #t) (new menu-item% [parent menu] [label (send lang get-language-name)] [callback (λ (x y) (send (send frame get-definitions-text) set-next-settings (drscheme:language-configuration:make-language-settings lang settings)))])))))) (preferences:get 'drscheme:recent-language-names)) (unless added-one? (send (new menu-item% [label (string-append " << " (string-constant no-recently-chosen-languages) " >>")] [parent menu] [callback void]) enable #f)) (new separator-menu-item% [parent menu])) (new menu-item% [label (string-constant choose-language-menu-item-label)] [parent menu] [callback (λ (x y) (send frame choose-language-callback))])) (super-new [label ""] [font small-control-font] [string-constant-untitled (string-constant untitled)] [string-constant-no-full-name-since-not-saved (string-constant no-full-name-since-not-saved)]) (inherit set-allow-shrinking) (set-allow-shrinking 100))) (define -frame% (frame-mixin super-frame%)) (define module-browser-dragable-panel% (class panel:horizontal-dragable% (inherit get-percentages) (define/augment (after-percentage-change) (let ([percentages (get-percentages)]) (when (and (pair? percentages) (pair? (cdr percentages)) (null? (cddr percentages))) (preferences:set 'drscheme:module-browser-size-percentage (car percentages)))) (inner (void) after-percentage-change)) (super-new))) (define drs-name-message% (class name-message% (define/override (on-choose-directory dir) (let ([file (finder:get-file dir (string-constant select-file) #f "" (send this get-top-level-window))]) (when file (handler:edit-file file)))) (super-new [string-constant-untitled (string-constant untitled)] [string-constant-no-full-name-since-not-saved (string-constant no-full-name-since-not-saved)]))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; lambda-snipclass is for backwards compatibility ;; (define lambda-snipclass (make-object (class snip-class% (define/override (read p) (make-object string-snip% "λ")) (super-new)))) (send lambda-snipclass set-version 1) (send lambda-snipclass set-classname "drscheme:lambda-snip%") (send (get-the-snip-class-list) add lambda-snipclass) (define newest-frame 'nothing-yet) (define open-drscheme-window (case-lambda [() (open-drscheme-window #f)] [(name) (cond [(and newest-frame name (not (eq? newest-frame 'nothing-yet)) (send newest-frame still-untouched?)) (send newest-frame change-to-file name) (send newest-frame show #t) (begin0 newest-frame (set! newest-frame #f))] [(and name ;; only open a tab if we have a filename (preferences:get 'drscheme:open-in-tabs)) (let ([fr (let loop ([frs (cons (send (group:get-the-frame-group) get-active-frame) (send (group:get-the-frame-group) get-frames))]) (cond [(null? frs) #f] [else (let ([fr (car frs)]) (or (and (is-a? fr -frame<%>) fr) (loop (cdr frs))))]))]) (if fr (begin (send fr open-in-new-tab name) (send fr show #t) fr) (create-new-drscheme-frame name)))] [else (create-new-drscheme-frame name)])])) (define first-frame? #t) (define (create-new-drscheme-frame filename) (let* ([drs-frame% (drscheme:get/extend:get-unit-frame)] [frame (new drs-frame% (filename filename))]) (send (send frame get-interactions-text) initialize-console) (when first-frame? (let ([pos (preferences:get 'drscheme:frame:initial-position)]) (when pos (send frame move (car pos) (cdr pos)))) (unless (eq? (system-type) 'macosx) ;; mac os x has a bug where maximizing can make the window too big. (send frame maximize (preferences:get 'drscheme:unit-window-max?)))) (send frame update-toolbar-visibility) (send frame show #t) (set! first-frame? #f) frame))))