..
original commit: d8a74e1ebde399e0ad63cfcb1f8874d6f64cdeb5
This commit is contained in:
Robby Findler
parent
84b51af447
commit
a4e60db069
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user