suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

a few changes to the automaically changing language stuff, plus more white-on-black improvements

Browse Source 
svn: r5917
This commit is contained in:
Robby Findler 2007-04-10 19:41:09 +00:00
parent 822cf3fd56
commit 031cd94b5c
7 changed files with 143 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/drscheme/private/auto-language.ss Normal file
View File

@ -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?))))

11
collects/drscheme/private/main.ss
View File

@ -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%

12
collects/drscheme/private/module-language.ss
View File

@ -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 ())))))
(super-new)))))

142
collects/drscheme/private/unit.ss
View File

@ -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))

33
collects/framework/decorated-editor-snip.ss
View File

@ -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 ()))))
(super-new))))

2
collects/stepper/xml-tool.ss
View File

@ -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

1
collects/string-constants/english-string-constants.ss
View File

@ -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"