diff --git a/collects/drscheme/private/auto-language.ss b/collects/drscheme/private/auto-language.ss new file mode 100644 index 0000000000..a066aa90d7 --- /dev/null +++ b/collects/drscheme/private/auto-language.ss @@ -0,0 +1,43 @@ +(module auto-language mzscheme + (require (lib "mred.ss" "mred") + (lib "class.ss")) + + (provide pick-new-language) + + (define (pick-new-language text module-spec->language module-language) + (with-handlers ((exn:fail:read? void)) + (let ([found-language? #f]) + (let* ([tp (open-input-text-editor text)] + [l (with-handlers ([exn:fail:contract? (λ (x) eof)]) + ;; catch exceptions that occur with GUI syntax in the beginning of the buffer + (read-line tp))]) + (unless (eof-object? l) + (unless (regexp-match #rx"[;#]" l) ;; no comments on the first line + (when (equal? #\) (send text get-character (- (send text last-position) 1))) + (let ([sp (open-input-string l)]) + (when (regexp-match #rx"[(]" sp) + (let-values ([(mod name module-spec) + (values (parameterize ([read-accept-reader #f]) (read sp)) + (parameterize ([read-accept-reader #f]) (read sp)) + (parameterize ([read-accept-reader #f]) (read sp)))]) + (when (eq? mod 'module) + (let ([matching-language (module-spec->language module-spec)]) + (when matching-language + (send text delete (- (send text last-position) 1) (send text last-position)) + (send text delete + (send text paragraph-start-position 0) + (send text paragraph-start-position 1)) + (set! found-language? matching-language) + (send text set-modified #f))))))))))) + (unless found-language? + (when module-language + (let* ([tp (open-input-text-editor text 0 'end (lambda (s) s) text #t)] + [r1 (parameterize ([read-accept-reader #f]) (read tp))] + [r2 (parameterize ([read-accept-reader #f]) (read tp))]) + (when (and (eof-object? r2) + (pair? r1) + (eq? (car r1) 'module)) + (set! found-language? module-language) + (send text set-modified #f))))) + + found-language?)))) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index d11698ca95..90318413d6 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -57,7 +57,8 @@ '("Scheme (.ss)" "*.ss") (finder:default-filters))) (application:current-app-name (string-constant drscheme)) - + + (preferences:set-default 'drscheme:recent-language-names null (λ (x) @@ -177,6 +178,9 @@ drscheme:teachpack:marshall-teachpack-cache drscheme:teachpack:unmarshall-teachpack-cache) + (preferences:set-default 'drscheme:switch-to-module-language-automatically? #t boolean?) + + (drscheme:font:setup-preferences) (drscheme:help-desk:add-help-desk-font-prefs #t) (color-prefs:add-background-preferences-panel) @@ -206,6 +210,11 @@ (string-constant show-interactions-on-execute) editor-panel) + (make-check-box 'drscheme:switch-to-module-language-automatically? + (string-constant switch-to-module-language-automatically) + editor-panel) + + ;; come back to this one. #; (letrec ([hp (new horizontal-panel% diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index 6bde452221..dc50b33642 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -505,13 +505,13 @@ ;; returns the name after "(module " suffixed with .scm ;; in the beginning of the editor ;; or #f if the beginning doesn't match "(module " - (define (get-module-filename) + (define/private (get-module-filename) (let ([open-paren (skip-whitespace 0)]) (or (match-paren open-paren "(") (match-paren open-paren "[") (match-paren open-paren "{")))) - (define (match-paren open-paren paren) + (define/private (match-paren open-paren paren) (and (matches open-paren paren) (let ([module (skip-whitespace (+ open-paren 1))]) (and (matches module "module") @@ -523,7 +523,7 @@ ".scm"))))))) - (define (matches start string) + (define/private (matches start string) (let ([last-pos (last-position)]) (let loop ([i 0]) (cond @@ -535,7 +535,7 @@ [(= i (string-length string)) #t] [else #f])))) - (define (skip-whitespace start) + (define/private (skip-whitespace start) (let ([last-pos (last-position)]) (let loop ([pos start]) (cond @@ -547,7 +547,7 @@ (loop (+ pos 1))] [else pos]))])))) - (define (skip-to-whitespace start) + (define/private (skip-to-whitespace start) (let ([last-pos (last-position)]) (let loop ([pos start]) (cond @@ -558,4 +558,4 @@ [else (loop (+ pos 1))])))) - (super-instantiate ()))))) \ No newline at end of file + (super-new))))) \ No newline at end of file diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 8d5f42c26a..968fba43d6 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -25,6 +25,7 @@ module browser threading seems wrong. (lib "bitmap-label.ss" "mrlib") "drsig.ss" + "auto-language.ss" (prefix drscheme:arrow: "../arrow.ss") @@ -459,61 +460,31 @@ module browser threading seems wrong. (begin-edit-sequence)) (define/augment (after-load-file success?) (when success? - (with-handlers ((exn:fail:read? void)) - (let ([found-language? #f]) - (let* ([tp (open-input-text-editor this)] - [l (with-handlers ([exn:fail:contract? (λ (x) eof)]) - ;; catch exceptions that occur with GUI syntax in the beginning of the buffer - (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-values ([(mod name module-spec) - (values (parameterize ([read-accept-reader #f]) (read sp)) - (parameterize ([read-accept-reader #f]) (read sp)) - (parameterize ([read-accept-reader #f]) (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))]) - (when matching-language - (delete (- (last-position) 1) (last-position)) - (delete (paragraph-start-position 0) - (paragraph-start-position 1)) - (set! found-language? #t) - (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))))))))))) - (unless found-language? - (let* ([tp (open-input-text-editor this 0 'end (lambda (s) s) this #t)] - [r1 (parameterize ([read-accept-reader #f]) (read tp))] - [r2 (parameterize ([read-accept-reader #f]) (read tp))]) - (when (and (eof-object? r2) - (pair? r1) - (eq? (car r1) 'module)) - (let ([ml (ormap (λ (lang) - (and (is-a? lang drscheme:module-language:module-language<%>) - lang)) - (drscheme:language-configuration:get-languages))]) - (when ml - (unless (eq? (drscheme:language-configuration:language-settings-language - next-settings) - ml) - (set-next-settings - (drscheme:language-configuration:make-language-settings - ml - (send ml default-settings)))) - (set-modified #f))))))))) + (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)))] + [matching-language (pick-new-language + this + (λ (module-spec) + (ormap + (λ (lang) + (and (equal? module-spec (send lang get-save-module)) + lang)) + (drscheme:language-configuration:get-languages))) + module-language)]) + (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)) + #f))))) (end-edit-sequence) (inner (void) after-load-file success?)) @@ -544,35 +515,38 @@ module browser threading seems wrong. [next-settings execute-settings]) (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) - - (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-duplicates - (cons (cons (send lang get-language-name) - (send lang marshall-settings sets)) - (preferences:get 'drscheme:recent-language-names))) - 10))) - (preferences:set - drscheme:language-configuration:settings-preferences-symbol - next-settings) - - (after-set-next-settings _next-settings)) + (define/pubment set-next-settings + (opt-lambda (_next-settings [update-prefs? #t]) + (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) + + (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-duplicates + (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)) diff --git a/collects/framework/decorated-editor-snip.ss b/collects/framework/decorated-editor-snip.ss index 10c8f1c200..21a0a1499f 100644 --- a/collects/framework/decorated-editor-snip.ss +++ b/collects/framework/decorated-editor-snip.ss @@ -5,7 +5,8 @@ decorated-editor-snip-mixin) (require (lib "class.ss") - (lib "mred.ss" "mred")) + (lib "mred.ss" "mred") + "preferences.ss") (define (decorated-editor-snip-mixin super%) (class super% @@ -15,7 +16,7 @@ (define/public (get-corner-bitmap) #f) ;; get-color : -> (union string (is-a?/c color%)) - (define/public (get-color) "black") + (define/public (get-color) (if (preferences:get 'framework:white-on-black?) "white" "black")) ;; get-menu : -> (union #f (is-a?/c popup-menu%)) ;; returns the popup menu that should appear @@ -30,7 +31,7 @@ (define/public (get-position) 'top-right) [define/private (get-pen) (send the-pen-list find-or-create-pen (get-color) 1 'solid)] - [define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)] + [define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)] (inherit get-admin) (define/override (on-event dc x y editorx editory evt) @@ -88,10 +89,16 @@ (get-margin bml bmt bmr bmb) (super draw dc x y left top right bottom dx dy draw-caret) (let* ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) + [old-brush (send dc get-brush)] + [white-on-black? (preferences:get 'framework:white-on-black?)]) - (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent)) - (send dc set-brush (send the-brush-list find-or-create-brush "white" 'solid)) + (send dc set-pen (send the-pen-list find-or-create-pen + (if white-on-black? "black" "white") + 1 + 'transparent)) + (send dc set-brush (send the-brush-list find-or-create-brush + (if white-on-black? "black" "white") + 'solid)) (case (get-position) [(top-right) (send dc draw-rectangle @@ -106,8 +113,13 @@ (- (unbox bml) (unbox bil)) (max 0 (- (unbox bh) (unbox bmt) (unbox bmb))))]) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush "black" 'solid)) + (send dc set-pen (send the-pen-list find-or-create-pen + (if white-on-black? "white" "black") + 1 + 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush + (if white-on-black? "white" "black") + 'solid)) (when bm (let ([bm-w (send bm get-width)] @@ -173,6 +185,9 @@ (top-margin top-margin) (left-margin left-margin))) + (inherit use-style-background) + (use-style-background #t) + (reset-min-sizes))) (define decorated-editor-snip% @@ -211,4 +226,4 @@ (let ([snip (make-snip stream-in)]) (send (send snip get-editor) read-from-file stream-in #f) snip)) - (super-instantiate ())))) \ No newline at end of file + (super-new)))) \ No newline at end of file diff --git a/collects/stepper/xml-tool.ss b/collects/stepper/xml-tool.ss index c1384b67a2..01d388460d 100644 --- a/collects/stepper/xml-tool.ss +++ b/collects/stepper/xml-tool.ss @@ -274,7 +274,7 @@ (let ([xml-delta (make-object style-delta% 'change-family 'default)]) (send style-list new-named-style "XML" (send style-list find-or-create-style - (send style-list find-named-style "Standard") + (send style-list find-named-style (editor:get-default-color-style-name)) xml-delta))))) (define xml-text-mixin diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 0906ac3b06..c557ca28a6 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -416,6 +416,7 @@ please adhere to these guidelines: (online-coloring-active "Color syntax interactively") (open-files-in-tabs "Open files in separate tabs (not separate windows)") (show-interactions-on-execute "Automatically open interactions window when running a program") + (switch-to-module-language-automatically "Automatically switch to the module language when opening a module") (limit-interactions-size "Limit interactions size") (background-color "Background Color") (default-text-color "Default text") ;; used for configuring colors, but doesn't need the word "color"