diff --git a/collects/algol60/tool.ss b/collects/algol60/tool.ss index c62a6e9f7c..d1e87ed1c0 100644 --- a/collects/algol60/tool.ss +++ b/collects/algol60/tool.ss @@ -49,6 +49,7 @@ (define lang% (class* object% (drscheme:language:language<%>) + (define/public (get-save-module) #f) (define/public (capability-value s) (drscheme:language:get-capability-default s)) (define/public (first-opened) (void)) (define/public (config-panel parent) diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 572d1b785d..235b31d18d 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -1379,10 +1379,9 @@ (let* ([extras-mixin (λ (mred-launcher? one-line-summary) (λ (%) - (class % + (class* % (drscheme:language:language<%>) (define/override (get-one-line-summary) one-line-summary) (define/override (use-namespace-require/copy?) #t) - (inherit get-module get-transformer-module get-init-code) (define/override (create-executable setting parent program-filename teachpacks) (let ([executable-fn @@ -1403,7 +1402,7 @@ (get-init-code setting teachpacks) mred-launcher? (use-namespace-require/copy?))))) - (super-instantiate ()))))] + (super-new))))] [make-simple (λ (module id position numbers mred-launcher? one-line-summary extra-mixin) (let ([% diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 70f51bed3c..0211535fb5 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -34,34 +34,35 @@ ;; text/pos = (make-text/pos (instanceof text% number number)) ;; this represents a portion of a text to be processed. - (define language<%> - (interface () - marshall-settings - unmarshall-settings - default-settings - default-settings? - - order-manuals - - front-end/complete-program - front-end/interaction - config-panel - on-execute - first-opened - render-value/format - render-value - - capability-value - - create-executable - - get-language-position - get-language-name - get-style-delta - get-language-numbers - get-one-line-summary - get-language-url - get-comment-character)) + (define language<%> + (interface () + marshall-settings + unmarshall-settings + default-settings + default-settings? + + order-manuals + + front-end/complete-program + front-end/interaction + config-panel + on-execute + first-opened + render-value/format + render-value + + capability-value + + create-executable + + get-save-module + get-language-position + get-language-name + get-style-delta + get-language-numbers + get-one-line-summary + get-language-url + get-comment-character)) (define module-based-language<%> (interface () @@ -508,6 +509,8 @@ (inherit get-module get-transformer-module use-namespace-require/copy? get-init-code use-mred-launcher get-reader) + (define/public (get-save-module) #f) + (define/pubment (capability-value s) (inner (get-capability-default s) capability-value s)) diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index 8dc718b851..471fba9016 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -45,7 +45,7 @@ ;; module-mixin : (implements drscheme:language:language<%>) ;; -> (implements drscheme:language:language<%>) (define (module-mixin %) - (class* % (module-language<%>) + (class* % (drscheme:language:language<%> module-language<%>) (define/override (use-namespace-require/copy?) #t) (field [iteration-number 0]) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index d0b89b2627..6abd00e254 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -359,7 +359,7 @@ module browser threading seems wrong. ; ; - + (define get-definitions-text% (let ([definitions-text% #f]) (λ () @@ -420,6 +420,23 @@ module browser threading seems wrong. (set-current-mode mode)) (loop (cdr modes))))])))) + (inherit begin-edit-sequence end-edit-sequence + delete insert last-position paragraph-start-position + get-character) + (define/augment (on-save-file filename fmt) + (inner (void) on-save-file filename fmt) + (let ([name-mod (send (drscheme:language-configuration:language-settings-language next-settings) + get-save-module)]) + (when name-mod + (begin-edit-sequence) + (let-values ([(base name dir) (split-path filename)]) + (insert (format "(module ~s ~s\n" + (string->symbol (regexp-replace #rx"\\.[^.]*$" + (path->string name) + "")) + name-mod) + 0 0)) + (insert ")" (last-position) (last-position))))) (define/augment (after-save-file success?) (when success? (let ([filename (get-filename)]) @@ -429,8 +446,56 @@ module browser threading seems wrong. (with-handlers ([exn:fail:filesystem? void]) (let-values ([(creator type) (file-creator-and-type filename)]) (file-creator-and-type filename #"DrSc" type)))))) + (let ([name-mod (send (drscheme:language-configuration:language-settings-language next-settings) + get-save-module)]) + (when name-mod + (delete (- (last-position) 1) (last-position)) + (delete (paragraph-start-position 0) + (paragraph-start-position 1)) + (end-edit-sequence) + (set-modified #f))) (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* ([tp (open-input-text-editor this)] + [l (read-line tp)]) + (unless (eof-object? l) + (unless (regexp-match #rx"[;#]" l) ;; no comments on the first line + (when (equal? #\) (get-character (- (last-position) 1))) + (let ([sp (open-input-string l)]) + (when (regexp-match #rx"[(]" sp) + (let/ec k + (let-values ([(mod name module-spec) + (with-handlers ([exn:fail:read? (λ (x) (k (void)))]) + (values (read sp) + (read sp) + (read sp)))]) + (when (eq? mod 'module) + (let ([matching-language + (ormap + (λ (lang) + (and (equal? module-spec (send lang get-save-module)) + lang)) + (drscheme:language-configuration:get-languages))]) + (delete (- (last-position) 1) (last-position)) + (delete (paragraph-start-position 0) + (paragraph-start-position 1)) + (when matching-language + (unless (eq? (drscheme:language-configuration:language-settings-language + next-settings) + matching-language) + (set-next-settings + (drscheme:language-configuration:make-language-settings + matching-language + (send matching-language default-settings))))) + (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?) @@ -458,12 +523,17 @@ module browser threading seems wrong. (define/pubment (get-next-settings) next-settings) (define/pubment (set-next-settings _next-settings) + (when (or (send (drscheme:language-configuration:language-settings-language _next-settings) + get-save-module) + (send (drscheme:language-configuration:language-settings-language next-settings) + get-save-module)) + (set-modified #t)) (set! next-settings _next-settings) (change-mode-to-match) (after-set-next-settings _next-settings)) (define/pubment (after-set-next-settings s) - (inner (void) after-set-next-settings s)) + (inner (void) after-set-next-settings s)) (define/public (needs-execution) (or needs-execution-state diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 190f290df5..30962bf69c 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -450,7 +450,9 @@ tracing todo: [else (inner (drscheme:language:get-capability-default key) capability-value key)])) - + + (define/override (get-save-module) (get-module)) + (super-new))) (define (stepper-settings-language %) diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index 647aab3b7e..45df92a5e7 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -101,7 +101,9 @@ (class % (inherit get-top-level-window) (define/augment (after-set-next-settings s) - (send (get-top-level-window) check-language) + (let ([tlw (get-top-level-window)]) + (when tlw + (send tlw check-language))) (inner (void) after-set-next-settings s)) (super-new))) diff --git a/collects/mztake/debug-tool.ss b/collects/mztake/debug-tool.ss index b94561d473..7de1141e68 100644 --- a/collects/mztake/debug-tool.ss +++ b/collects/mztake/debug-tool.ss @@ -436,7 +436,9 @@ (loop start-pos (rest marks))))))))) (define/augment (after-set-next-settings s) - (send (get-top-level-window) check-current-language-for-debugger) + (let ([tlw (get-top-level-window)]) + (when tlw + (send tlw check-current-language-for-debugger))) (inner (void) after-set-next-settings s)))) (define (debug-interactions-text-mixin super%) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 278f31db73..21437e24f8 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -150,7 +150,7 @@ (define (java-lang-mixin level name number one-line dyn?) (when dyn? (dynamic? #t)) (class* object% (drscheme:language:language<%>) - + (define/public (get-save-module) #f) (define/public (capability-value s) (cond [(eq? s 'drscheme:language-menu-title) (string-constant profj-java)] diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index 6f86d7fa27..ff150f906c 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -635,7 +635,9 @@ (inner (void) on-delete x y)) (define/augment (after-set-next-settings s) - (send (get-top-level-window) check-current-language-for-stepper) + (let ([tlw (get-top-level-window)]) + (when tlw + (send tlw check-current-language-for-stepper))) (inner (void) after-set-next-settings s)) (super-new)))