diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index ff8a1753..e7d92193 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -626,13 +626,14 @@ "." "" "It finds a handler based on \\var{filename}.") + (handler:edit-file (opt-> ((union string? false?)) ((-> (is-a?/c frame:editor<%>))) (union false? (is-a?/c frame:editor<%>))) ((filename) - ((make-default (lambda () (make-object frame:text-info-file\% filename))))) + ((make-default (lambda () ((handler:current-create-new-window) filename))))) "This function creates a frame or re-uses an existing frame to edit a file. " "" "If the preference \\scheme{'framework:open-here} is set to \\scheme{#t}," @@ -671,6 +672,23 @@ "\\item" "If \\var{filename} is \\rawscm{\\#f}, \\var{make-default} is used." "\\end{itemize}") + + (handler:current-create-new-window + (case-> + (((union false? string?) . -> . (is-a?/c frame%)) . -> . void) + (-> ((union false? string?) . -> . (is-a?/c frame%)))) + ((new-window-handler) ()) + "This is a parameter that controls how the framework" + "creates new application windows." + "" + "The default setting is this:" + "\\begin{schemedisplay}" + "(lambda (filename)" + " (let ([frame (make-object frame:text-info-file% filename)])" + " (send frame show #t)" + " frame))" + "\\end{schemedisplay}") + (handler:open-file (-> (union false? (is-a?/c frame:basic<%>))) () diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index c6ed581d..39832e1f 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -874,7 +874,8 @@ (define open-here<%> (interface (-editor<%>) get-open-here-editor - open-here)) + open-here + create-empty-window)) (define open-here-mixin (mixin (-editor<%>) (open-here<%>) @@ -886,7 +887,6 @@ (string-constant new-...-menu-item) (string-constant new-menu-item)))) - (rename [super-file-menu:new-callback file-menu:new-callback]) (define/override (file-menu:new-callback item event) (cond [(preferences:get 'framework:open-here?) @@ -894,14 +894,30 @@ (cond [(eq? clear-current 'cancel) (void)] [clear-current - (let ([editor (get-editor)]) - (send editor begin-edit-sequence) - (send editor set-filename #f) - (send editor erase) - (send editor set-modified #f) - (send editor end-edit-sequence))] - [else (super-file-menu:new-callback item event)]))] - [else (super-file-menu:new-callback item event)])) + (let* ([editor (get-editor)] + [canceled? (cancel-due-to-unsaved-changes editor)]) + (unless canceled? + (send editor begin-edit-sequence) + (send editor set-filename #f) + (send editor erase) + (send editor set-modified #f) + (send editor clear-undos) + (send editor end-edit-sequence)))] + [else ((handler:current-create-new-window) #f)]))] + [else ((handler:current-create-new-window) #f)])) + + ;; cancel-due-to-unsaved-changes : -> boolean + (define (cancel-due-to-unsaved-changes editor) + (and (send editor is-modified?) + (let ([save (gui-utils:unsaved-warning + (or (send editor get-filename) (get-label)) + (string-constant clear-anyway) + #t + this)]) + (case save + [(continue) #f] + [(save) (not (send editor save-file))] + [(cancel) #t])))) ;; ask-about-new-here : -> (union 'cancel boolean?) ;; prompts the user about creating a new window @@ -911,10 +927,15 @@ (string-constant create-new-window-or-clear-current) (string-constant clear-current) (string-constant new-window) - (string-constant drscheme) + (string-constant warning) 'cancel this)) - + + ;; create-empty-window : -> void + (define/public (create-empty-window) + (make-object text-info-file%) + (void)) + (rename [super-file-menu:open-on-demand file-menu:open-on-demand]) (define/override (file-menu:open-on-demand item) (super-file-menu:open-on-demand item) diff --git a/collects/framework/private/handler.ss b/collects/framework/private/handler.ss index 24aa399e..5d056037 100644 --- a/collects/framework/private/handler.ss +++ b/collects/framework/private/handler.ss @@ -97,14 +97,19 @@ (find-named-handler name format-handlers))) ; Open a file for editing + (define current-create-new-window + (make-parameter + (lambda (filename) + (let ([frame (make-object frame:text-info-file% filename)]) + (send frame show #t) + frame)))) + (define edit-file (case-lambda [(filename) (edit-file filename (lambda () - (let ([frame (make-object frame:text-info-file% filename)]) - (send frame show #t) - frame)))] + ((current-create-new-window) filename)))] [(filename make-default) (gui-utils:show-busy-cursor (lambda () diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 7b704f1c..05a33023 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -378,6 +378,7 @@ insert-format-handler find-format-handler find-named-format-handler + current-create-new-window edit-file open-file install-recent-items