diff --git a/collects/framework/private/gen-standard-menus.ss b/collects/framework/private/gen-standard-menus.ss index 2eeaa46c..74662bfc 100644 --- a/collects/framework/private/gen-standard-menus.ss +++ b/collects/framework/private/gen-standard-menus.ss @@ -1,209 +1,206 @@ #!/bin/sh string=? ; exec mred -qr $0 -(require (lib "pretty.ss")) -(require (lib "list.ss")) -(require (lib "standard-menus-items.ss" "framework" "private")) -(define build-id - (case-lambda - [(name post) (build-id name post "")] - [(item post pre) - (let* ([name (an-item->name item pre)] - [name-string (symbol->string name)] - [answer (string->symbol (string-append name-string post))]) - answer)])) - -(define menu-name->id - (lambda (name-string) - (let ([file-menu? (string=? (substring name-string 0 9) "file-menu")] - [edit-menu? (string=? (substring name-string 0 9) "edit-menu")] - [windows-menu? (string=? (substring name-string 0 9) "windows-m")] - [help-menu? (string=? (substring name-string 0 9) "help-menu")]) - `(,(cond - [file-menu? 'get-file-menu] - [edit-menu? 'get-edit-menu] - [windows-menu? 'get-windows-menu] - [help-menu? 'get-help-menu] - [else (printf "WARNING: defaulting item to file-menu ~s~n" name-string) - 'get-file-menu]))))) - -(define (an-item->names item) - (list (an-item->name item) - (build-id item "-item" "get-") - (build-id item "-string") - (build-id item "-help-string") - (build-id item "-on-demand"))) - -(define build-fill-in-item-clause - (lambda (item) - (let ([help-string (an-item-help-string item)] - [proc (an-item-proc item)]) - `(public - ,@(map (lambda (x y) `[,x ,y]) - (an-item->names item) - (list proc - `(lambda () ,(build-id item "-item")) - `(lambda () "") - `(lambda () ,help-string) - (an-item-on-demand item))))))) - -(define build-fill-in-clause - (lambda (->name -procedure) - (lambda (obj) - `(public - [,(->name obj) - ,(case (-procedure obj) - [(nothing) '(lambda (menu) (void))] - [(separator) '(lambda (menu) (make-object separator-menu-item% menu))])])))) - -(define build-fill-in-between-clause - (build-fill-in-clause - between->name - between-procedure)) -(define build-fill-in-before/after-clause - (build-fill-in-clause - before/after->name - before/after-procedure)) - -(define (build-item-menu-clause item) - (let* ([name (an-item->name item)] - [name-string (symbol->string name)] - [menu-before-string (an-item-menu-string-before item)] - [menu-after-string (an-item-menu-string-after item)] - [key (an-item-key item)] - [join (lambda (base-text suffix-text special-text) - `(let ([special ,special-text] - [base ,base-text] - [suffix ,suffix-text]) - (if (string=? special "") - (string-append base suffix) - (string-append base " " special suffix))))]) - `(private-field - [,(build-id item "-item") - (and ,name - (make-object (class (get-menu-item%) args - (rename [super-on-demand on-demand]) - (override - [on-demand - (lambda () - (,(build-id item "-on-demand") this) - (super-on-demand))]) - (sequence (apply super-init args))) - ,(join menu-before-string menu-after-string - `(,(build-id item "-string"))) - ,(menu-name->id name-string) - (let ([,name (lambda (item evt) (,name item evt))]) - ,name) - ,key - (,(build-id item "-help-string"))))]))) - -(define build-menu-clause - (lambda (->name -menu) - (lambda (between/after) - `(sequence - (,(->name between/after) - ,(menu-name->get-menu (-menu between/after))))))) - -(define build-between-menu-clause - (build-menu-clause between->name between-menu)) -(define build-before/after-menu-clause - (build-menu-clause before/after->name before/after-menu)) - -(define menu-name->get-menu - (lambda (menu-name) - `(,(string->symbol - (string-append - "get-" - (symbol->string - menu-name)))))) - -(define build-between-menu-clause - (lambda (between) - `(sequence - (,(between->name between) - ,(menu-name->get-menu (between-menu between)))))) - -(define (build-generic-clause x) '(sequence (void))) -(define (build-fill-in-generic-clause generic) - `(public - [,(generic-name generic) - ,(generic-initializer generic)])) - -(define (build-generic-override-clause x) - `(rename [,(string->symbol (format "super-~a" (generic-override-name x))) - ,(generic-override-name x)])) -(define (build-fill-in-generic-override-clause generic) - `(override - [,(generic-override-name generic) - ,(generic-override-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 - (lambda (port) - (pretty-print - `(define standard-menus<%> - (interface (basic<%>) - ,@(apply append (map - (lambda (x) - (cond - [(an-item? x) (an-item->names x)] - [(between? x) (list (between->name x))] - [(or (after? x) (before? x)) - (list (before/after->name x))] - [(generic-override? x) null] - [(generic? x) (list (generic-name x))])) - items)))) - port) - - (newline port) - - (pretty-print - `(define standard-menus-mixin - (mixin (basic<%>) (standard-menus<%>) args - (inherit on-menu-char on-traverse-char) - (private-field - [remove-prefs-callback - (preferences:add-callback - 'framework:menu-bindings - (lambda (p v) - (let ([mb (get-menu-bar)]) - (let loop ([menu (get-menu-bar)]) - (cond - [(is-a? menu menu-item-container<%>) - (for-each loop (send menu get-items))] - [(is-a? menu selectable-menu-item<%>) - (when (is-a? menu menu:can-restore<%>) - (if v - (send menu restore-keybinding) - (send menu set-shortcut #f)))])))))]) - - (inherit get-menu-bar show can-close? get-edit-target-object) - (sequence (apply super-init args)) - ,@(append - (map (lambda (x) - (cond - [(between? x) (build-fill-in-between-clause x)] - [(or (after? x) (before? x)) - (build-fill-in-before/after-clause x)] - [(an-item? x) (build-fill-in-item-clause x)] - [(generic? x) (build-fill-in-generic-clause x)] - [(generic-override? x) (build-fill-in-generic-override-clause x)] - [else (printf "~a~n" x)])) - items) - (map (lambda (x) - (cond - [(between? x) (build-between-menu-clause x)] - [(an-item? x) (build-item-menu-clause x)] - [(or (after? x) (before? x)) - (build-before/after-menu-clause x)] - [(generic? x) (build-generic-clause x)] - [(generic-override? x) (build-generic-override-clause x)])) - items) - (list `(sequence (reorder-menus this)))))) - port)) - 'text - 'truncate) +(module gen-standard-menus mzscheme + (require (lib "pretty.ss")) + (require (lib "list.ss")) + (require (lib "standard-menus-items.ss" "framework" "private")) + + (define build-id + (case-lambda + [(name post) (build-id name post "")] + [(item post pre) + (let* ([name (an-item->name item pre)] + [name-string (symbol->string name)] + [answer (string->symbol (string-append name-string post))]) + answer)])) + + (define menu-name->id + (lambda (name-string) + (let ([file-menu? (string=? (substring name-string 0 9) "file-menu")] + [edit-menu? (string=? (substring name-string 0 9) "edit-menu")] + [windows-menu? (string=? (substring name-string 0 9) "windows-m")] + [help-menu? (string=? (substring name-string 0 9) "help-menu")]) + `(,(cond + [file-menu? 'get-file-menu] + [edit-menu? 'get-edit-menu] + [windows-menu? 'get-windows-menu] + [help-menu? 'get-help-menu] + [else (printf "WARNING: defaulting item to file-menu ~s~n" name-string) + 'get-file-menu]))))) + + (define (an-item->names item) + (list (an-item->name item) + (build-id item "-item" "get-") + (build-id item "-string") + (build-id item "-help-string") + (build-id item "-on-demand"))) + + (define build-fill-in-item-clause + (lambda (item) + (let ([help-string (an-item-help-string item)] + [proc (an-item-proc item)]) + `(public + ,@(map (lambda (x y) `[,x ,y]) + (an-item->names item) + (list proc + `(lambda () ,(build-id item "-item")) + `(lambda () "") + `(lambda () ,help-string) + (an-item-on-demand item))))))) + + (define build-fill-in-clause + (lambda (->name -procedure) + (lambda (obj) + `(public + [,(->name obj) + ,(case (-procedure obj) + [(nothing) '(lambda (menu) (void))] + [(separator) '(lambda (menu) (make-object separator-menu-item% menu))])])))) + + (define build-fill-in-between-clause + (build-fill-in-clause + between->name + between-procedure)) + (define build-fill-in-before/after-clause + (build-fill-in-clause + before/after->name + before/after-procedure)) + + (define (build-item-menu-clause item) + (let* ([name (an-item->name item)] + [create-menu-item-name (an-item->create-menu-item-name item)] + [name-string (symbol->string name)] + [menu-before-string (an-item-menu-string-before item)] + [menu-after-string (an-item-menu-string-after item)] + [key (an-item-key item)] + [join (lambda (base-text suffix-text special-text) + `(let ([special ,special-text] + [base ,base-text] + [suffix ,suffix-text]) + (if (string=? special "") + (string-append base suffix) + (string-append base " " special suffix))))]) + `(private-field + [,(build-id item "-item") + (and (,create-menu-item-name) + (make-object (class (get-menu-item%) args + (rename [super-on-demand on-demand]) + (override + [on-demand + (lambda () + (,(build-id item "-on-demand") this) + (super-on-demand))]) + (sequence (apply super-init args))) + ,(join menu-before-string menu-after-string + `(,(build-id item "-string"))) + ,(menu-name->id name-string) + (let ([,name (lambda (item evt) (,name item evt))]) + ,name) + ,key + (,(build-id item "-help-string"))))]))) + + (define build-menu-clause + (lambda (->name -menu) + (lambda (between/after) + `(sequence + (,(->name between/after) + ,(menu-name->get-menu (-menu between/after))))))) + + (define build-between-menu-clause + (build-menu-clause between->name between-menu)) + (define build-before/after-menu-clause + (build-menu-clause before/after->name before/after-menu)) + + (define menu-name->get-menu + (lambda (menu-name) + `(,(string->symbol + (string-append + "get-" + (symbol->string + menu-name)))))) + + (define (build-generic-clause x) '(sequence (void))) + (define (build-fill-in-generic-clause generic) + `(public + [,(generic-name generic) + ,(generic-initializer generic)])) + + (define (build-generic-override-clause x) + `(rename [,(string->symbol (format "super-~a" (generic-override-name x))) + ,(generic-override-name x)])) + (define (build-fill-in-generic-override-clause generic) + `(override + [,(generic-override-name generic) + ,(generic-override-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 + (lambda (port) + (pretty-print + `(define standard-menus<%> + (interface (basic<%>) + ,@(apply append (map + (lambda (x) + (cond + [(an-item? x) (an-item->names x)] + [(between? x) (list (between->name x))] + [(or (after? x) (before? x)) + (list (before/after->name x))] + [(generic-override? x) null] + [(generic? x) (list (generic-name x))])) + items)))) + port) + + (newline port) + + (pretty-print + `(define standard-menus-mixin + (mixin (basic<%>) (standard-menus<%>) args + (inherit on-menu-char on-traverse-char) + (private-field + [remove-prefs-callback + (preferences:add-callback + 'framework:menu-bindings + (lambda (p v) + (let ([mb (get-menu-bar)]) + (let loop ([menu (get-menu-bar)]) + (cond + [(is-a? menu menu-item-container<%>) + (for-each loop (send menu get-items))] + [(is-a? menu selectable-menu-item<%>) + (when (is-a? menu menu:can-restore<%>) + (if v + (send menu restore-keybinding) + (send menu set-shortcut #f)))])))))]) + + (inherit get-menu-bar show can-close? get-edit-target-object) + (sequence (apply super-init args)) + ,@(append + (map (lambda (x) + (cond + [(between? x) (build-fill-in-between-clause x)] + [(or (after? x) (before? x)) + (build-fill-in-before/after-clause x)] + [(an-item? x) (build-fill-in-item-clause x)] + [(generic? x) (build-fill-in-generic-clause x)] + [(generic-override? x) (build-fill-in-generic-override-clause x)] + [else (printf "~a~n" x)])) + items) + (map (lambda (x) + (cond + [(between? x) (build-between-menu-clause x)] + [(an-item? x) (build-item-menu-clause x)] + [(or (after? x) (before? x)) + (build-before/after-menu-clause x)] + [(generic? x) (build-generic-clause x)] + [(generic-override? x) (build-generic-override-clause x)])) + items) + (list `(sequence (reorder-menus this)))))) + port)) + 'text + 'truncate)) \ No newline at end of file diff --git a/collects/framework/private/standard-menus-items.ss b/collects/framework/private/standard-menus-items.ss index 915f45bd..b690302c 100644 --- a/collects/framework/private/standard-menus-items.ss +++ b/collects/framework/private/standard-menus-items.ss @@ -1,22 +1,37 @@ (module standard-menus-items mzscheme (provide - (struct generic (name initializer documentation)) - (struct generic-override (name initializer documentation)) + ;(struct generic (name initializer documentation)) + generic? generic-name generic-initializer generic-documentation + ;(struct generic-override (name initializer documentation)) + generic-override? generic-override-name generic-override-initializer generic-override-documentation + - (struct before/after (menu name procedure)) - (struct before ()) - (struct after ()) + ;(struct before/after (menu name procedure)) + ;(struct before ()) + ;(struct after ()) + before? after? + before/after-menu before/after-name before/after-procedure + + ;(struct between (menu before after procedure)) + between? + between-menu between-before between-after between-procedure + + ;(struct an-item (menu-name item-name help-string proc key menu-string-before menu-string-after on-demand)) + an-item? + an-item-menu-name an-item-item-name an-item-help-string an-item-proc an-item-key + an-item-menu-string-before an-item-menu-string-after an-item-on-demand - (struct between (menu before after procedure)) before/after->name between->name an-item->name + an-item->create-menu-item-name + items - edit-menu:do - edit-menu:do-on-demand - edit-menu:edit-target-on-demand - edit-menu:edit-target-on-demand) + ;edit-menu:do + ;edit-menu:can-do-on-demand + ;edit-menu:edit-target-on-demand + ) (define-struct generic (name initializer documentation)) (define-struct generic-override (name initializer documentation)) @@ -56,6 +71,9 @@ middle (an-item-item-name item)))])) + (define (an-item->create-menu-item-name item) + (format "~a:create-~a?" (an-item-menu-name item) (an-item-item-name item))) + (define (edit-menu:do const) `(lambda (menu evt) (let ([edit (get-edit-target-object)])