suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

..

Browse Source 
original commit: e878278cc0fdb37daf00477ba1347ade428e58d7
This commit is contained in:
Robby Findler 2000-03-27 16:57:00 +00:00
parent 542d0e650d
commit 27967a52bb
4 changed files with 96 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/framework/frame.ss
View File

@ -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

2
collects/framework/gen-standard-menus.ss
View File

@ -1,6 +1,6 @@
#!/bin/sh
string=? ; exec mred -mgaqvf $0
string=? ; exec mred -qr $0
(require-library "pretty.ss")
(require-library "function.ss")

120
collects/framework/prefs.ss
View File

@ -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))

10
collects/framework/standard-menus-items.ss
View File

@ -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%)