diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index ebb73869..6bb3fe83 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -638,7 +638,7 @@ (finder:put-file name))]) (when file (send (get-editor) save-file file format))))]) - (inherit get-menu-item%) + (inherit get-checkable-menu-item% get-menu-item%) (override [file-menu:revert (lambda (item control) @@ -697,12 +697,29 @@ (edit-menu:do 'insert-pasteboard-box)) (make-object (get-menu-item%) "Insert Image..." edit-menu (edit-menu:do 'insert-image)) - (make-object (get-menu-item%) "Toggle Wrap Text" edit-menu + + (letrec ([c% (class (get-checkable-menu-item%) args + (rename [super-on-demand on-demand]) + (override + [on-demand + (lambda () + (let ([edit (get-edit-target-object)]) + (if (and edit + (is-a? edit editor<%>)) + (begin + (send wrap-text-item enable #t) + (send wrap-text-item check (send edit auto-wrap))) + (send wrap-text-item enable #f))))]) + (sequence (apply super-init args)))] + [wrap-text-item + (make-object c% "Wrap Text" edit-menu (lambda (item event) (let ([edit (get-edit-target-object)]) (when (and edit (is-a? edit editor<%>)) - (send edit auto-wrap (not (send edit auto-wrap))))))) + (send edit auto-wrap (not (send edit auto-wrap)))))))]) + (void)) + (make-object separator-menu-item% edit-menu))]) (override diff --git a/collects/framework/gen-standard-menus.ss b/collects/framework/gen-standard-menus.ss index 2a0cec34..132fd50d 100755 --- a/collects/framework/gen-standard-menus.ss +++ b/collects/framework/gen-standard-menus.ss @@ -1,6 +1,6 @@ #!/bin/sh -string=? ; exec mred -mgaqvf $0 +string=? ; exec mred -qr $0 (require-library "pretty.ss") (require-library "function.ss") diff --git a/collects/framework/prefs.ss b/collects/framework/prefs.ss index 685610bd..c5d2c0ba 100644 --- a/collects/framework/prefs.ss +++ b/collects/framework/prefs.ss @@ -13,6 +13,7 @@ [(macos) "MrEd Preferences"] [(windows) "mred.pre"] [else ".mred.prefs"]))) + (define default-preferences-filename (build-path (collection-path "defaults") "prefs.ss")) (define preferences (make-hash-table)) (define marshall-unmarshall (make-hash-table)) @@ -184,12 +185,12 @@ 'truncate 'text))))) (define -read - (let ([parse-pref - (lambda (p marshalled) - (let/ec k - (let* ([ht-pref (hash-table-get preferences p (lambda () #f))] - [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))]) - (cond + (let* ([parse-pref + (lambda (p marshalled) + (let/ec k + (let* ([ht-pref (hash-table-get preferences p (lambda () #f))] + [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))]) + (cond [unmarshall-struct (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))] @@ -205,56 +206,65 @@ (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))] [(not ht-pref) (hash-table-put! preferences p (make-marshalled marshalled))] - [else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))]) + [else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))] + [read-from-filename + (lambda (preferences-filename) + (let/ec k + (let ([err + (lambda (input msg) + (message-box "Preferences" + (let* ([max-len 150] + [s1 (format "~s" input)] + [ell "..."] + [s2 (if (<= (string-length s1) max-len) + s1 + (string-append + (substring s1 0 (- max-len + (string-length ell))) + ell))]) + (format "found bad pref in ~a: ~a~n~a" + preferences-filename msg s2))))]) + (let ([input (with-handlers + ([(lambda (exn) #t) + (lambda (exn) + (message-box + "Error reading preferences" + (format "Error reading preferences~n~a" + (exn-message exn))) + (k #f))]) + (call-with-input-file preferences-filename + read + 'text))]) + (let loop ([input input]) + (cond + [(pair? input) + (let ([err-msg + (let/ec k + (let ([first (car input)]) + (unless (pair? first) + (k "expected pair of pair")) + (let ([arg1 (car first)] + [t1 (cdr first)]) + (unless (pair? t1) + (k "expected pair of two pairs")) + (let ([arg2 (car t1)] + [t2 (cdr t1)]) + (unless (null? t2) + (k "expected null after two pairs")) + (parse-pref arg1 arg2) + (k #f)))))]) + (when err-msg + (err input err-msg))) + (loop (cdr input))] + [(null? input) (void)] + [else (err input "expected a pair")]))))))]) (lambda () - (let/ec k - (when (file-exists? preferences-filename) - (let ([err - (lambda (input msg) - (message-box "Preferences" - (let* ([max-len 150] - [s1 (format "~s" input)] - [ell "..."] - [s2 (if (<= (string-length s1) max-len) - s1 - (string-append (substring s1 0 (- max-len - (string-length ell))) - ell))]) - (format "found bad pref: ~a~n~a" msg s2))))]) - (let ([input (with-handlers - ([(lambda (exn) #t) - (lambda (exn) - (message-box - "Error reading preferences" - (format "Error reading preferences~n~a" - (exn-message exn))) - (k #f))]) - (call-with-input-file preferences-filename - read - 'text))]) - (let loop ([input input]) - (cond - [(pair? input) - (let ([err-msg - (let/ec k - (let ([first (car input)]) - (unless (pair? first) - (k "expected pair of pair")) - (let ([arg1 (car first)] - [t1 (cdr first)]) - (unless (pair? t1) - (k "expected pair of two pairs")) - (let ([arg2 (car t1)] - [t2 (cdr t1)]) - (unless (null? t2) - (k "expected null after two pairs")) - (parse-pref arg1 arg2) - (k #f)))))]) - (when err-msg - (err input err-msg))) - (loop (cdr input))] - [(null? input) (void)] - [else (err input "expected a pair")]))))))))) + (cond + [(file-exists? preferences-filename) + (read-from-filename preferences-filename)] + [(file-exists? default-preferences-filename) + (read-from-filename default-preferences-filename)] + [else (void)])))) (define-struct ppanel (title container panel)) diff --git a/collects/framework/standard-menus-items.ss b/collects/framework/standard-menus-items.ss index 9b46923c..b1b311b4 100644 --- a/collects/framework/standard-menus-items.ss +++ b/collects/framework/standard-menus-items.ss @@ -60,6 +60,16 @@ "" "defaultly returns" "@link menu-item")) + (make-generic 'get-checkable-menu-item% '(lambda () checkable-menu-item%) + '("The result of this method is used as the class for creating" + "checkable menu items in this class (see " + "@link frame:standard-menus" + "for a list)." + "" + "@return : (derived-from \\iscmclass{checkable-menu-item})" + "" + "defaultly returns" + "@link menu-item")) (make-generic 'get-file-menu '(let ([m (make-object (get-menu%)