187 lines
7.7 KiB
Scheme
187 lines
7.7 KiB
Scheme
|
|
(module gen-standard-menus mzscheme
|
|
(require (lib "pretty.ss"))
|
|
(require (lib "list.ss"))
|
|
(require "standard-menus-items.ss")
|
|
|
|
;; build-before-super-item-clause : an-item -> (listof clause)
|
|
(define build-before-super-item-clause
|
|
(λ (item)
|
|
(list
|
|
`[define/public ,(an-item->callback-name item) ,(an-item-proc item)]
|
|
`(define/public (,(an-item->get-item-name item))
|
|
,(an-item->item-name item))
|
|
`(define/public (,(an-item->string-name item))
|
|
,(an-item-menu-string item))
|
|
`(define/public (,(an-item->help-string-name item))
|
|
,(an-item-help-string item))
|
|
`(define/public ,(an-item->on-demand-name item) ,(an-item-on-demand item))
|
|
`(define/public (,(an-item->create-menu-item-name item))
|
|
,(an-item-create item)))))
|
|
|
|
;; build-before-super-clause : ((X -> sym) (X sexp) -> X -> (listof clause))
|
|
(define build-before-super-clause
|
|
(λ (->name -procedure)
|
|
(λ (obj)
|
|
(list `(define/public ,(->name obj)
|
|
,(case (-procedure obj)
|
|
[(nothing) '(λ (menu) (void))]
|
|
[(separator) '(λ (menu) (make-object separator-menu-item% menu))]
|
|
[(nothing-with-standard-menus)
|
|
'(λ (menu)
|
|
(unless (current-eventspace-has-standard-menus?)
|
|
(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
|
|
(build-before-super-clause
|
|
between->name
|
|
between-procedure))
|
|
|
|
;; build-before-super-before/after-clause : before/after -> (listof clause)
|
|
(define build-before-super-before/after-clause
|
|
(build-before-super-clause
|
|
before/after->name
|
|
before/after-procedure))
|
|
|
|
;; build-after-super-item-clause : an-item -> (list clause)
|
|
(define (build-after-super-item-clause item)
|
|
(let* ([callback-name (an-item->callback-name item)]
|
|
[create-menu-item-name (an-item->create-menu-item-name item)]
|
|
[callback-name-string (symbol->string callback-name)]
|
|
[key (an-item-key item)])
|
|
(list `(define
|
|
,(an-item->item-name item)
|
|
(and (,create-menu-item-name)
|
|
,(if (a-submenu-item? item)
|
|
`(instantiate (get-menu%) ()
|
|
(label (,(an-item->string-name item)))
|
|
(parent ,(menu-item-menu-name item))
|
|
(help-string (,(an-item->help-string-name item)))
|
|
(demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))
|
|
`(instantiate (get-menu-item%) ()
|
|
(label (,(an-item->string-name item)))
|
|
(parent ,(menu-item-menu-name item))
|
|
(callback (let ([,callback-name (λ (item evt) (,callback-name item evt))])
|
|
,callback-name))
|
|
(shortcut ,key)
|
|
(help-string (,(an-item->help-string-name item)))
|
|
(demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))))))))
|
|
|
|
;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause))
|
|
(define build-after-super-clause
|
|
(λ (->name)
|
|
(λ (between/after)
|
|
(list
|
|
`(,(->name between/after)
|
|
(,(menu-name->get-menu-name between/after)))))))
|
|
|
|
;; build-after-super-between-clause : between -> (listof clause)
|
|
(define build-after-super-between-clause (build-after-super-clause between->name))
|
|
;; build-after-super-before/after-clause : before/after -> (listof clause)
|
|
(define build-after-super-before/after-clause (build-after-super-clause before/after->name))
|
|
|
|
;; build-after-super-generic-clause : generic -> (listof clause)
|
|
(define (build-after-super-generic-clause x)
|
|
(cond
|
|
[(generic-private-field? x)
|
|
(list `(define
|
|
,(generic-name x)
|
|
,(generic-initializer x)))]
|
|
[(generic-override? x)
|
|
(list)]
|
|
[(generic-augment? x)
|
|
(list)]
|
|
[(generic-method? x)
|
|
null]))
|
|
|
|
;; build-before-super-generic-clause : generic -> (listof clause)
|
|
(define (build-before-super-generic-clause generic)
|
|
(cond
|
|
[(generic-private-field? generic)
|
|
null]
|
|
[(generic-override? generic)
|
|
(list `(define/override ,(generic-name generic)
|
|
,(generic-initializer generic)))]
|
|
[(generic-augment? generic)
|
|
(list `(define/augment ,(generic-name generic)
|
|
,(generic-initializer generic)))]
|
|
[(generic-method? generic)
|
|
(list `(define/public ,(generic-name generic)
|
|
,(generic-initializer generic)))]))
|
|
|
|
|
|
(define standard-menus.ss-filename (build-path (collection-path "framework" "private") "standard-menus.ss"))
|
|
(printf "writing to ~a~n" standard-menus.ss-filename)
|
|
|
|
(call-with-output-file standard-menus.ss-filename
|
|
(λ (port)
|
|
(pretty-print
|
|
`(define standard-menus<%>
|
|
(interface (basic<%>)
|
|
,@(apply append (map
|
|
(λ (x)
|
|
(cond
|
|
[(an-item? x)
|
|
(list
|
|
(an-item->callback-name x)
|
|
(an-item->get-item-name x)
|
|
(an-item->string-name x)
|
|
(an-item->help-string-name x)
|
|
(an-item->on-demand-name x)
|
|
(an-item->create-menu-item-name x))]
|
|
[(between? x) (list (between->name x))]
|
|
[(or (after? x) (before? x))
|
|
(list (before/after->name x))]
|
|
[(generic? x)
|
|
(if (generic-method? x)
|
|
(list (generic-name x))
|
|
null)]))
|
|
items))))
|
|
port)
|
|
|
|
(newline port)
|
|
|
|
(pretty-print
|
|
`(define standard-menus-mixin
|
|
(mixin (basic<%>) (standard-menus<%>)
|
|
(inherit on-menu-char on-traverse-char)
|
|
|
|
(define remove-prefs-callback
|
|
(preferences:add-callback
|
|
'framework:menu-bindings
|
|
(λ (p v)
|
|
(let loop ([menu (get-menu-bar)])
|
|
(when (is-a? menu menu:can-restore<%>)
|
|
(if v
|
|
(send menu restore-keybinding)
|
|
(send menu set-shortcut #f)))
|
|
(when (is-a? menu menu:can-restore-underscore<%>)
|
|
(if v
|
|
(send menu restore-underscores)
|
|
(send menu erase-underscores)))
|
|
(when (is-a? menu menu-item-container<%>)
|
|
(for-each loop (send menu get-items)))))))
|
|
|
|
(inherit get-menu-bar show can-close? get-edit-target-object)
|
|
,@(apply append (map (λ (x)
|
|
(cond
|
|
[(between? x) (build-before-super-between-clause x)]
|
|
[(or (after? x) (before? x)) (build-before-super-before/after-clause x)]
|
|
[(an-item? x) (build-before-super-item-clause x)]
|
|
[(generic? x) (build-before-super-generic-clause x)]))
|
|
items))
|
|
(super-instantiate ())
|
|
,@(apply append (map (λ (x)
|
|
(cond
|
|
[(between? x) (build-after-super-between-clause x)]
|
|
[(an-item? x) (build-after-super-item-clause x)]
|
|
[(or (after? x) (before? x)) (build-after-super-before/after-clause x)]
|
|
[(generic? x) (build-after-super-generic-clause x)]))
|
|
items))
|
|
(reorder-menus this)))
|
|
port))
|
|
'text
|
|
'truncate))
|