no message
original commit: 2711ca7727891e9e99871a9fe0267ab1e8138d6b
This commit is contained in:
parent
62aa9de612
commit
c8e89dfd65
|
@ -1,7 +1,3 @@
|
|||
#!/bin/sh
|
||||
|
||||
string=? ; exec mred -qr $0
|
||||
|
||||
(module gen-standard-menus mzscheme
|
||||
(require (lib "pretty.ss"))
|
||||
(require (lib "list.ss"))
|
||||
|
@ -60,14 +56,15 @@ string=? ; exec mred -qr $0
|
|||
`(private-field
|
||||
[,(an-item->item-name item)
|
||||
(and (,create-menu-item-name)
|
||||
(make-object (class (get-menu-item%) args
|
||||
(make-object (class100 (get-menu-item%) args
|
||||
(rename [super-on-demand on-demand])
|
||||
(override on-demand)
|
||||
(define (on-demand)
|
||||
(lambda ()
|
||||
(,(an-item->on-demand-name item) this)
|
||||
(super-on-demand)))
|
||||
(apply super-init args))
|
||||
(override
|
||||
[on-demand
|
||||
(lambda ()
|
||||
(,(an-item->on-demand-name item) this)
|
||||
(super-on-demand))])
|
||||
(sequence
|
||||
(apply super-init args)))
|
||||
,(join menu-before-string menu-after-string
|
||||
`(,(an-item->string-name item)))
|
||||
,(menu-item-menu-name item)
|
||||
|
|
|
@ -5,33 +5,33 @@
|
|||
"sig"
|
||||
"../macro.ss"
|
||||
(lib "mred-sig.ss" "mred"))
|
||||
|
||||
|
||||
(provide menu@)
|
||||
|
||||
|
||||
(define menu@
|
||||
(unit/sig framework:menu^
|
||||
(import mred^
|
||||
[preferences : framework:preferences^])
|
||||
|
||||
(define can-restore<%>
|
||||
(interface (selectable-menu-item<%>)
|
||||
restore-keybinding))
|
||||
|
||||
(define can-restore-mixin
|
||||
(mixin (selectable-menu-item<%>) (can-restore<%>) args
|
||||
(inherit set-shortcut get-shortcut)
|
||||
(private-field
|
||||
[saved-shortcut 'not-yet])
|
||||
(public
|
||||
[restore-keybinding
|
||||
(lambda ()
|
||||
(unless (eq? saved-shortcut 'not-yet)
|
||||
(set-shortcut saved-shortcut)))])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set! saved-shortcut (get-shortcut))
|
||||
(unless (preferences:get 'framework:menu-bindings)
|
||||
(set-shortcut #f)))))
|
||||
|
||||
(define can-restore-menu-item% (can-restore-mixin menu-item%))
|
||||
(define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%)))))
|
||||
(unit/sig framework:menu^
|
||||
(import mred^
|
||||
[preferences : framework:preferences^])
|
||||
|
||||
(define can-restore<%>
|
||||
(interface (selectable-menu-item<%>)
|
||||
restore-keybinding))
|
||||
|
||||
(define can-restore-mixin
|
||||
(mixin (selectable-menu-item<%>) (can-restore<%>) args
|
||||
(inherit set-shortcut get-shortcut)
|
||||
(private-field
|
||||
[saved-shortcut 'not-yet])
|
||||
(public
|
||||
[restore-keybinding
|
||||
(lambda ()
|
||||
(unless (eq? saved-shortcut 'not-yet)
|
||||
(set-shortcut saved-shortcut)))])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set! saved-shortcut (get-shortcut))
|
||||
(unless (preferences:get 'framework:menu-bindings)
|
||||
(set-shortcut #f)))))
|
||||
|
||||
(define can-restore-menu-item% (can-restore-mixin menu-item%))
|
||||
(define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%)))))
|
|
@ -2,7 +2,7 @@
|
|||
(require (lib "unitsig.ss")
|
||||
(lib "class.ss")
|
||||
(lib "class100.ss")
|
||||
"sig"
|
||||
"sig.ss"
|
||||
"../macro.ss"
|
||||
"../gui-utils-sig.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
|
|
|
@ -1,5 +1,3 @@
|
|||
#|
|
||||
|
||||
(define (test-creation name class-expression)
|
||||
(test
|
||||
name
|
||||
|
@ -138,8 +136,6 @@
|
|||
(test-open "frame:searchable open" 'frame:searchable%)
|
||||
(test-open "frame:text-info open" 'frame:text-info-file%)
|
||||
|
||||
|#
|
||||
|
||||
(test
|
||||
"set!-ing menu callback in standard-menus-frame"
|
||||
(lambda (x) (eq? x 'passed))
|
||||
|
|
|
@ -7,11 +7,13 @@
|
|||
(test
|
||||
(string->symbol file)
|
||||
void?
|
||||
`(let ([orig-namespace (current-namespace)])
|
||||
`(let ([mred-name
|
||||
((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)]
|
||||
[orig-namespace (current-namespace)])
|
||||
(parameterize ([current-namespace (make-namespace)])
|
||||
(namespace-attach-module
|
||||
orig-namespace
|
||||
((current-module-name-resolver) '(lib "mred.ss" "mred")))
|
||||
mred-name)
|
||||
(eval '(require (lib ,file "framework")))
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
|
|
|
@ -2,6 +2,7 @@
|
|||
(require (lib "launcher.ss" "launcher")
|
||||
(lib "pretty.ss")
|
||||
(lib "list.ss")
|
||||
(lib "process.ss")
|
||||
"debug.ss")
|
||||
|
||||
(provide
|
||||
|
|
Loading…
Reference in New Issue
Block a user