diff --git a/collects/framework/gui-utils.ss b/collects/framework/gui-utils.ss index 98966765..57f40191 100644 --- a/collects/framework/gui-utils.ss +++ b/collects/framework/gui-utils.ss @@ -235,6 +235,10 @@ (inherit get-dc) (define/override (on-paint) (let ([dc (get-dc)]) + (send dc set-brush background-brush) + (send dc set-pen background-pen) + (let-values ([(cw ch) (get-client-size)]) + (send dc draw-rectangle 0 0 cw ch)) (let loop ([names choices] [n 0] [x (get-initial-x dc)]) @@ -374,6 +378,7 @@ [(button-down/over) button-down/over-brush] [(unselected) unselected-brush] [else (error 'draw-name "unknown state: ~s\n" state)])) + (send dc set-pen name-box-pen) (send dc set-clipping-region region) (send dc draw-rectangle (bz (min (send p1 get-x) @@ -507,7 +512,23 @@ (send the-brush-list find-or-create-brush (make-object color% 225 225 255) 'solid)])) + + ;; name-box-pen : pen + ;; this pen draws the lines around each individual item + (define name-box-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) + + ;; background-brush : brush + ;; this brush is set when drawing the background for the control + (define background-brush + (case (system-type) + [(macosx) (send the-brush-list find-or-create-brush (get-panel-background) 'panel)] + [else (send the-brush-list find-or-create-brush "white" 'solid)])) + + ;; background-pen : pen + ;; this pen is set when drawing the background for the control + (define background-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + ;; label-font : font (define label-font (send the-font-list find-or-create-font 12 diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 976e62eb..7649e165 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -211,6 +211,14 @@ (define locked-message (string-constant read-only)) (define unlocked-message (string-constant read/write)) + (define lock-canvas-font (send the-font-list find-or-create-font + (if (eq? (system-type) 'macosx) + 13 + 12) + 'system 'normal + 'normal + #f)) + (define lock-canvas% (class100 canvas% (parent . args) (private-field @@ -226,25 +234,26 @@ (lambda () (let* ([dc (get-dc)] [draw - (lambda (str bg-color line-color) + (lambda (str bg-color bg-style line-color) + (send dc set-font lock-canvas-font) (let-values ([(w h) (get-client-size)] [(tw th ta td) (send dc get-text-extent str)]) (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush bg-color 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style)) (send dc draw-rectangle 0 0 w h) (send dc draw-text str (- (/ w 2) (/ tw 2)) (- (/ h 2) (/ th 2)))))]) (if locked? - (draw locked-message "yellow" "black") - (draw unlocked-message (get-panel-background) (get-panel-background)))))]) + (draw locked-message "yellow" 'solid "black") + (draw unlocked-message (get-panel-background) 'panel (get-panel-background)))))]) (inherit min-width min-height stretchable-width stretchable-height) (sequence (apply super-init parent args) (let ([dc (get-dc)]) (send dc set-font (send parent get-label-font)) - (let-values ([(w1 h1 _1 _2) (send dc get-text-extent locked-message)] - [(w2 h2 _3 _4) (send dc get-text-extent unlocked-message)]) + (let-values ([(w1 h1 _1 _2) (send dc get-text-extent locked-message lock-canvas-font)] + [(w2 h2 _3 _4) (send dc get-text-extent unlocked-message lock-canvas-font)]) (stretchable-width #f) (stretchable-height #t) (min-width (inexact->exact (floor (max w1 w2)))) diff --git a/collects/framework/private/gen-standard-menus.ss b/collects/framework/private/gen-standard-menus.ss index 37f7d0bb..03351bb0 100644 --- a/collects/framework/private/gen-standard-menus.ss +++ b/collects/framework/private/gen-standard-menus.ss @@ -14,8 +14,7 @@ ,(an-item->help-string-name item) ,(an-item->on-demand-name item) ,(an-item->create-menu-item-name item)) - `[define ,(an-item->callback-name item) - ,(or (an-item-proc item) `(lambda (x y) (void)))] + `[define ,(an-item->callback-name item) ,(an-item-proc item)] `[define ,(an-item->get-item-name item) (lambda () ,(an-item->item-name item))] `[define ,(an-item->string-name item) @@ -25,7 +24,7 @@ `[define ,(an-item->on-demand-name item) ,(an-item-on-demand item)] `[define ,(an-item->create-menu-item-name item) - (lambda () ,(not (not (an-item-proc item))))]))) + (lambda () ,(an-item-create item))]))) ;; build-before-super-clause : ((X -> sym) (X sexp) -> X -> (listof clause)) (define build-before-super-clause @@ -35,7 +34,12 @@ `[define ,(->name obj) ,(case (-procedure obj) [(nothing) '(lambda (menu) (void))] - [(separator) '(lambda (menu) (make-object separator-menu-item% menu))])])))) + [(separator) '(lambda (menu) (make-object separator-menu-item% menu))] + [(nothing-on-macosx) + '(lambda (menu) + (unless (eq? (system-type) 'macosx) + (make-object separator-menu-item% menu)))] + [else (error 'gen-standard-menus "unknown between sym: ~e" (-procedure obj))])])))) ;; build-before-super-between-clause : between -> (listof clause) (define build-before-super-between-clause diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 592a4d3b..f84939f3 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -17,6 +17,8 @@ [group : framework:group^] [handler : framework:handler^]) + (application-preferences-handler (lambda () (preferences:show-dialog))) + ;; preferences (preferences:set-default 'framework:recent-max-count 50 diff --git a/collects/framework/private/standard-menus-items.ss b/collects/framework/private/standard-menus-items.ss index aaa1aecf..983ab751 100644 --- a/collects/framework/private/standard-menus-items.ss +++ b/collects/framework/private/standard-menus-items.ss @@ -18,7 +18,7 @@ (struct between (before after procedure)) - (struct an-item (item-name help-string proc key menu-string on-demand)) + (struct an-item (item-name help-string proc key menu-string on-demand create)) (struct a-submenu-item ()) ;; an-item -> symbol @@ -71,7 +71,8 @@ proc key menu-string - on-demand)) + on-demand + create)) (define-struct (a-submenu-item an-item) ()) (define (an-item->callback-name item) @@ -214,49 +215,62 @@ '(lambda (item control) (handler:edit-file #f) #t) #\n '(string-constant new-menu-item) - on-demand-do-nothing) + on-demand-do-nothing + #t) (make-between 'file-menu 'new 'open 'nothing) (make-an-item 'file-menu 'open '(string-constant open-info) '(lambda (item control) (handler:open-file) #t) #\o '(string-constant open-menu-item) - on-demand-do-nothing) - (make-a-submenu-item 'file-menu 'open-recent '(string-constant open-recent-info) - '(lambda (x y) (void)) ;; hack to avoid rewriting lots of stuff (really shouldn't have this) - #f ;; this also shouldn't need to be here + on-demand-do-nothing + #t) + (make-a-submenu-item 'file-menu 'open-recent + '(string-constant open-recent-info) + '(lambda (x y) (void)) + #f '(string-constant open-recent-menu-item) '(lambda (menu) - (handler:install-recent-items menu))) + (handler:install-recent-items menu)) + #t) (make-between 'file-menu 'open 'revert 'nothing) (make-an-item 'file-menu 'revert '(string-constant revert-info) - #f #f + '(lambda (item control) (void)) + #f '(string-constant revert-menu-item) - on-demand-do-nothing) + on-demand-do-nothing + #f) (make-between 'file-menu 'revert 'save 'nothing) (make-an-item 'file-menu 'save '(string-constant save-info) - #f #\s + '(lambda (item control) (void)) + #\s '(string-constant save-menu-item) - on-demand-do-nothing) + on-demand-do-nothing + #f) (make-an-item 'file-menu 'save-as '(string-constant save-as-info) - #f #f + '(lambda (item control) (void)) + #f '(string-constant save-as-menu-item) - on-demand-do-nothing) + on-demand-do-nothing + #f) (make-between 'file-menu 'save-as 'print 'separator) (make-an-item 'file-menu 'print '(string-constant print-info) - #f #\p + '(lambda (item control) (void)) + #\p '(string-constant print-menu-item) - on-demand-do-nothing) + on-demand-do-nothing + #f) (make-between 'file-menu 'print 'close 'separator) (make-an-item 'file-menu 'close '(string-constant close-info) '(lambda (item control) (when (can-close?) (on-close) (show #f)) #t) #\w '(string-constant close-menu-item) - on-demand-do-nothing) + on-demand-do-nothing + #t) (make-between 'file-menu 'close 'quit 'nothing) (make-an-item 'file-menu 'quit '(string-constant quit-info) @@ -267,7 +281,8 @@ '(if (eq? (system-type) 'windows) (string-constant quit-menu-item-windows) (string-constant quit-menu-item-others)) - on-demand-do-nothing) + on-demand-do-nothing + '(not (eq? (system-type) 'macosx))) (make-after 'file-menu 'quit 'nothing) (make-an-item 'edit-menu 'undo @@ -275,33 +290,38 @@ (edit-menu:do 'undo) #\z '(string-constant undo-menu-item) - (edit-menu:can-do-on-demand 'undo)) + (edit-menu:can-do-on-demand 'undo) + #t) (make-an-item 'edit-menu 'redo '(string-constant redo-info) (edit-menu:do 'redo) #\y '(string-constant redo-menu-item) - (edit-menu:can-do-on-demand 'redo)) + (edit-menu:can-do-on-demand 'redo) + #t) (make-between 'edit-menu 'redo 'cut 'separator) (make-an-item 'edit-menu 'cut '(string-constant cut-info) (edit-menu:do 'cut) #\x '(string-constant cut-menu-item) - (edit-menu:can-do-on-demand 'cut)) + (edit-menu:can-do-on-demand 'cut) + #t) (make-between 'edit-menu 'cut 'copy 'nothing) (make-an-item 'edit-menu 'copy '(string-constant copy-info) (edit-menu:do 'copy) #\c '(string-constant copy-menu-item) - (edit-menu:can-do-on-demand 'copy)) + (edit-menu:can-do-on-demand 'copy) + #t) (make-between 'edit-menu 'copy 'paste 'nothing) (make-an-item 'edit-menu 'paste '(string-constant paste-info) (edit-menu:do 'paste) #\v '(string-constant paste-menu-item) - (edit-menu:can-do-on-demand 'paste)) + (edit-menu:can-do-on-demand 'paste) + #t) (make-between 'edit-menu 'paste 'clear 'nothing) (make-an-item 'edit-menu 'clear '(string-constant clear-info) @@ -310,47 +330,57 @@ '(if (eq? (system-type) 'windows) (string-constant clear-menu-item-windows) (string-constant clear-menu-item-windows)) - (edit-menu:can-do-on-demand 'clear)) + (edit-menu:can-do-on-demand 'clear) + #t) (make-between 'edit-menu 'clear 'select-all 'nothing) (make-an-item 'edit-menu 'select-all '(string-constant select-all-info) (edit-menu:do 'select-all) #\a '(string-constant select-all-menu-item) - (edit-menu:can-do-on-demand 'select-all)) + (edit-menu:can-do-on-demand 'select-all) + #t) (make-between 'edit-menu 'select-all 'find 'separator) (make-an-item 'edit-menu 'find '(string-constant find-info) - #f + '(lambda (item control) (void)) #\f '(string-constant find-menu-item) - edit-menu:edit-target-on-demand) + edit-menu:edit-target-on-demand + #f) (make-an-item 'edit-menu 'find-again '(string-constant find-again-info) - #f + '(lambda (item control) (void)) #\g '(string-constant find-again-menu-item) - edit-menu:edit-target-on-demand) + edit-menu:edit-target-on-demand + #f) (make-an-item 'edit-menu 'replace-and-find-again '(string-constant replace-and-find-again-info) - #f #\h + '(lambda (item control) (void)) + #\h '(string-constant replace-and-find-again-menu-item) - edit-menu:edit-target-on-demand) - (make-between 'edit-menu 'find 'preferences 'separator) + edit-menu:edit-target-on-demand + #f) + + (make-between 'edit-menu 'find 'preferences + 'nothing-on-macosx) (make-an-item 'edit-menu 'preferences '(string-constant preferences-info) '(lambda (item control) (preferences:show-dialog) #t) #\; '(string-constant preferences-menu-item) - on-demand-do-nothing) + on-demand-do-nothing + '(not (eq? (system-type) 'macosx))) (make-after 'edit-menu 'preferences 'nothing) (make-before 'help-menu 'about 'nothing) (make-an-item 'help-menu 'about '(string-constant about-info) - #f + '(lambda (item control) (void)) #f '(string-constant about-menu-item) - on-demand-do-nothing) + on-demand-do-nothing + #f) (make-after 'help-menu 'about 'nothing))))