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

moved to unit/s and new mred initialization system

Browse Source 
original commit: 8e5bc8572fb3e75a962b5f5314f53ea9b6fff100
This commit is contained in:
Robby Findler 1996-06-15 20:39:16 +00:00
parent ace788472e
commit ab53e9de2f
4 changed files with 1506 additions and 1500 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/mred/edit.ss
View File

@ -1,6 +1,9 @@
(define-sigfunctor (mred:edit@ mred:edit^) (define mred:edit@
(import mred:debug^ mred:finder^ mred:path-utils^ mred:mode^ (unit/s mred:edit^
mred:scheme-paren^ mred:keymap^ mzlib:function^) (import [mred:debug mred:debug^] [mred:finder mred:finder^]
[mred:path-utils mred:path-utils^] [mred:mode mred:mode^]
[mred:scheme-paren mred:scheme-paren^] [mred:keymap mred:keymap^]
[mzlib:function mzlib:function^])
(define-struct range (start end pen brush)) (define-struct range (start end pen brush))
(define-struct rectangle (left top width height pen brush)) (define-struct rectangle (left top width height pen brush))
@ -19,11 +22,11 @@
[auto-save-out-of-date? #t] [auto-save-out-of-date? #t]
[auto-save-error? #f]) [auto-save-error? #f])
(public (public
[get-file (lambda (d) (let ([v (mred:finder^:get-file d)]) [get-file (lambda (d) (let ([v (mred:finder:get-file d)])
(if v (if v
v v
'())))] '())))]
[put-file (lambda (d f) (let ([v (mred:finder^:put-file f d)]) [put-file (lambda (d f) (let ([v (mred:finder:put-file f d)])
(if v (if v
v v
'())))] '())))]
@ -46,7 +49,7 @@
(set! canvases (cons canvas canvases)))] (set! canvases (cons canvas canvases)))]
[remove-canvas [remove-canvas
(lambda (canvas) (lambda (canvas)
(set! canvases (mzlib:function^:remove canvas canvases)))] (set! canvases (mzlib:function:remove canvas canvases)))]
[mode #f] [mode #f]
[set-mode [set-mode
@ -83,7 +86,7 @@
(or (not auto-saved-name) (or (not auto-saved-name)
auto-save-out-of-date?)) auto-save-out-of-date?))
(let* ([orig-name (get-filename)] (let* ([orig-name (get-filename)]
[auto-name (mred:path-utils^:generate-autosave-name orig-name)] [auto-name (mred:path-utils:generate-autosave-name orig-name)]
[success (save-file auto-name wx:const-media-ff-copy)]) [success (save-file auto-name wx:const-media-ff-copy)])
(if success (if success
(begin (begin
@ -114,7 +117,7 @@
(if (and backup? (if (and backup?
(not (= format wx:const-media-ff-copy))) (not (= format wx:const-media-ff-copy)))
(if (file-exists? name) (if (file-exists? name)
(let ([back-name (mred:path-utils^:generate-backup-name name)]) (let ([back-name (mred:path-utils:generate-backup-name name)])
(unless (file-exists? back-name) (unless (file-exists? back-name)
(rename-file name back-name))))) (rename-file name back-name)))))
#t) #t)
@ -189,7 +192,7 @@
(lambda (m) (lambda (m)
(if mode (if mode
(send mode deinstall this)) (send mode deinstall this))
(if (is-a? m mred:mode^:mode%) (if (is-a? m mred:mode:mode%)
(begin (begin
(set! mode m) (set! mode m)
(set-file-format (ivar m file-format)) (set-file-format (ivar m file-format))
@ -331,7 +334,7 @@
[old-rectangles range-rectangles]) [old-rectangles range-rectangles])
(set! range-rectangles (set! range-rectangles
(mzlib:function^:foldl (lambda (x l) (append (new-rectangles x) l)) (mzlib:function:foldl (lambda (x l) (append (new-rectangles x) l))
null ranges)) null ranges))
(begin-edit-sequence) (begin-edit-sequence)
(for-each invalidate-rectangle old-rectangles) (for-each invalidate-rectangle old-rectangles)
@ -362,13 +365,13 @@
(apply super-init args) (apply super-init args)
(send edits add this) (send edits add this)
(let ([keymap (get-keymap)]) (let ([keymap (get-keymap)])
(mred:keymap^:set-keymap-error-handler keymap) (mred:keymap:set-keymap-error-handler keymap)
(mred:keymap^:set-keymap-implied-shifts keymap) (mred:keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap mred:keymap^:global-keymap #f)))))) (send keymap chain-to-keymap mred:keymap:global-keymap #f))))))
(define edit% (make-edit% wx:media-edit%)) (define edit% (make-edit% wx:media-edit%))
(define make-pasteboard% make-std-buffer%) (define make-pasteboard% make-std-buffer%)
(define pasteboard% (make-pasteboard% wx:media-pasteboard%))) (define pasteboard% (make-pasteboard% wx:media-pasteboard%))))

12
collects/mred/exit.ss
View File

@ -1,8 +1,6 @@
;; [Robby] (define mred:exit@
;; exit doesn't actually exit, now. (unit/s mred:exit^
(import [mred:debug mred:debug^])
(define-sigfunctor (mred:exit@ mred:exit^)
(import mred:debug^)
(rename (-exit exit)) (rename (-exit exit))
(define exit-callbacks '()) (define exit-callbacks '())
@ -30,8 +28,8 @@
[(not ((car cb-list))) cb-list] [(not ((car cb-list))) cb-list]
[else (loop (cdr cb-list))]))) [else (loop (cdr cb-list))])))
(if (null? exit-callbacks) (if (null? exit-callbacks)
(begin (when mred:debug^:exit? (begin (when mred:debug:exit?
(exit)) (exit))
#t) #t)
#f)))) #f)))))

48
collects/mred/finder.ss
View File

@ -1,10 +1,12 @@
(define-sigfunctor (mred:finder@ mred:finder^) (define mred:finder@
(import mred:debug^ mzlib:string^ mzlib:function^ mzlib:file^) (unit/s mred:finder^
(import [mred:debug mred:debug^] [mzlib:string mzlib:string^]
[mzlib:function mzlib:function^] [mzlib:file mzlib:file^])
(define filter-match? (define filter-match?
(lambda (filter name msg) (lambda (filter name msg)
(let-values ([(base name dir?) (split-path name)]) (let-values ([(base name dir?) (split-path name)])
(if (mzlib:string^:regexp-match-exact? filter name) (if (mzlib:string:regexp-match-exact? filter name)
#t #t
(begin (begin
(wx:message-box msg "Error") (wx:message-box msg "Error")
@ -59,7 +61,7 @@
[menu-list ()]) [menu-list ()])
(let-values ([(base-dir in-dir dir?) (split-path this-dir)]) (let-values ([(base-dir in-dir dir?) (split-path this-dir)])
(if (eq? wx:platform 'windows) (if (eq? wx:platform 'windows)
(mzlib:string^:string-lowercase! in-dir)) (mzlib:string:string-lowercase! in-dir))
(let* ([dir-list (cons this-dir dir-list)] (let* ([dir-list (cons this-dir dir-list)]
[menu-list (cons in-dir menu-list)]) [menu-list (cons in-dir menu-list)])
(if base-dir (if base-dir
@ -78,7 +80,7 @@
(send name-list clear) (send name-list clear)
(send name-list set (send name-list set
(mzlib:function^:quicksort (mzlib:function:quicksort
(let loop ([l (directory-list dir)]) (let loop ([l (directory-list dir)])
(if (null? l) (if (null? l)
'() '()
@ -93,7 +95,7 @@
(macintosh ":"))) (macintosh ":")))
rest) rest)
(if (or (not file-filter) (if (or (not file-filter)
(mzlib:string^:regexp-match-exact? file-filter s)) (mzlib:string:regexp-match-exact? file-filter s))
(cons s rest) (cons s rest)
rest))))) rest)))))
(if (eq? wx:platform 'unix) string<? string-ci<?))) (if (eq? wx:platform 'unix) string<? string-ci<?)))
@ -112,7 +114,7 @@
"Directory" "Go to Directory" "Directory" "Go to Directory"
default)]) default)])
(if (string? orig-dir) (if (string? orig-dir)
(let ([dir (mzlib:file^:normalize-path orig-dir current-dir)]) (let ([dir (mzlib:file:normalize-path orig-dir current-dir)])
(if (directory-exists? dir) (if (directory-exists? dir)
(set-directory dir) (set-directory dir)
(begin (begin
@ -128,7 +130,7 @@
[dir (build-path current-dir [dir (build-path current-dir
(make-relative which))]) (make-relative which))])
(if (directory-exists? dir) (if (directory-exists? dir)
(set-directory (mzlib:file^:normalize-path dir)) (set-directory (mzlib:file:normalize-path dir))
(if save-mode? (if save-mode?
(send name-field set-value which) (send name-field set-value which)
(if multi-mode? (if multi-mode?
@ -154,7 +156,7 @@
(let ([name (build-path current-dir (let ([name (build-path current-dir
(make-relative name))]) (make-relative name))])
(if (directory-exists? name) (if (directory-exists? name)
(set-directory (mzlib:file^:normalize-path name)))))))] (set-directory (mzlib:file:normalize-path name)))))))]
[do-ok [do-ok
(lambda args (lambda args
@ -178,7 +180,7 @@
"Error")] "Error")]
[(and save-mode? [(and save-mode?
file-filter file-filter
(not (mzlib:string^:regexp-match-exact? file-filter name))) (not (mzlib:string:regexp-match-exact? file-filter name)))
(wx:message-box file-filter-msg "Error")] (wx:message-box file-filter-msg "Error")]
[else [else
(let ([file (build-path current-dir (let ([file (build-path current-dir
@ -188,7 +190,7 @@
(wx:message-box (wx:message-box
"That is the name of a directory." "That is the name of a directory."
"Error") "Error")
(set-directory (mzlib:file^:normalize-path file))) (set-directory (mzlib:file:normalize-path file)))
(if (or (not save-mode?) (if (or (not save-mode?)
(not (file-exists? file)) (not (file-exists? file))
replace-ok? replace-ok?
@ -202,7 +204,7 @@
wx:const-yes-no) wx:const-yes-no)
wx:const-yes)) wx:const-yes))
(begin (begin
(set-box! result-box (mzlib:file^:normalize-path file)) (set-box! result-box (mzlib:file:normalize-path file))
(show #f)))))]))))] (show #f)))))]))))]
[add-one [add-one
@ -210,7 +212,7 @@
(unless (or (directory-exists? name) (unless (or (directory-exists? name)
(> (send result-list find-string name) -1)) (> (send result-list find-string name) -1))
(set! select-counter (add1 select-counter)) (set! select-counter (add1 select-counter))
(send result-list append (mzlib:file^:normalize-path name))))] (send result-list append (mzlib:file:normalize-path name))))]
[do-add [do-add
(lambda args (lambda args
(let ([name (send name-list get-string-selection)]) (let ([name (send name-list get-string-selection)])
@ -333,7 +335,7 @@
[(and start-dir [(and start-dir
(not (null? start-dir)) (not (null? start-dir))
(directory-exists? start-dir)) (directory-exists? start-dir))
(set-directory (mzlib:file^:normalize-path start-dir))] (set-directory (mzlib:file:normalize-path start-dir))]
[last-directory (set-directory last-directory)] [last-directory (set-directory last-directory)]
[else (set-directory (current-directory))]) [else (set-directory (current-directory))])
@ -347,10 +349,10 @@
[filter-msg "That name does not have the right form"]) [filter-msg "That name does not have the right form"])
(let* ([directory (if (and (null? directory) (let* ([directory (if (and (null? directory)
(string? name)) (string? name))
(or (mzlib:file^:path-only name) null) (or (mzlib:file:path-only name) null)
directory)] directory)]
[name (or (and (string? name) [name (or (and (string? name)
(mzlib:file^:file-name-from-path name)) (mzlib:file:file-name-from-path name))
name)] name)]
[v (box #f)]) [v (box #f)])
(make-object finder-dialog% #t replace? #f v (make-object finder-dialog% #t replace? #f v
@ -380,10 +382,10 @@
"That filename does not have the right form."]) "That filename does not have the right form."])
(let* ([directory (if (and (null? directory) (let* ([directory (if (and (null? directory)
(string? name)) (string? name))
(or (mzlib:file^:path-only name) null) (or (mzlib:file:path-only name) null)
directory)] directory)]
[name (or (and (string? name) [name (or (and (string? name)
(mzlib:file^:file-name-from-path name)) (mzlib:file:file-name-from-path name))
name)] name)]
[f (wx:file-selector prompt directory name [f (wx:file-selector prompt directory name
'() '()
@ -395,9 +397,9 @@
f f
filter-msg)))) filter-msg))))
#f #f
(let* ([f (mzlib:file^:normalize-path f)] (let* ([f (mzlib:file:normalize-path f)]
[dir (mzlib:file^:path-only f)] [dir (mzlib:file:path-only f)]
[name (mzlib:file^:file-name-from-path f)]) [name (mzlib:file:file-name-from-path f)])
(cond (cond
[(not (and (string? dir) (directory-exists? dir))) [(not (and (string? dir) (directory-exists? dir)))
(wx:message-box "Error" "That directory does not exist.") (wx:message-box "Error" "That directory does not exist.")
@ -415,7 +417,7 @@
(if (null? f) (if (null? f)
#f #f
(if (or (not filter) (filter-match? filter f filter-msg)) (if (or (not filter) (filter-match? filter f filter-msg))
(let ([f (mzlib:file^:normalize-path f)]) (let ([f (mzlib:file:normalize-path f)])
(cond (cond
[(directory-exists? f) [(directory-exists? f)
(wx:message-box "Error" (wx:message-box "Error"
@ -429,4 +431,4 @@
; By default, use platform-specific get/put ; By default, use platform-specific get/put
(define put-file std-put-file) (define put-file std-put-file)
(define get-file std-get-file)) (define get-file std-get-file)))

19
collects/mred/keys.ss
View File

@ -1,7 +1,10 @@
(define-sigfunctor (mred:keymap@ mred:keymap^) (define mred:keymap@
(import mred:debug^ mred:finder^ mred:handler^ mred:find-string^ mred:scheme-paren^) (unit/s mred:keymap^
(import [mred:debug mred:debug^] [mred:finder mred:finder^]
[mred:handler mred:handler^] [mred:find-string mred:find-string^]
[mred:scheme-paren mred:scheme-paren^])
(mred:debug^:dprintf "mred:keymap@~n") (mred:debug:dprintf "mred:keymap@~n")
; This is a list of keys that are typed with the SHIFT key, but ; This is a list of keys that are typed with the SHIFT key, but
; are not normally thought of as shifted. It will have to be ; are not normally thought of as shifted. It will have to be
@ -48,7 +51,7 @@
(wx:bell))] (wx:bell))]
[save-file-as [save-file-as
(lambda (edit event) (lambda (edit event)
(let ([file (mred:finder^:put-file)]) (let ([file (mred:finder:put-file)])
(if file (if file
(send edit save-file file))) (send edit save-file file)))
#t)] #t)]
@ -60,7 +63,7 @@
#t)] #t)]
[load-file [load-file
(lambda (edit event) (lambda (edit event)
(mred:handler^:open-file) (mred:handler:open-file)
#t)] #t)]
[find-string [find-string
(lambda (edit event . extras) (lambda (edit event . extras)
@ -69,7 +72,7 @@
[canvas (send event get-event-object)]) [canvas (send event get-event-object)])
(send event position x-box y-box) (send event position x-box y-box)
(send canvas client-to-screen x-box y-box) (send canvas client-to-screen x-box y-box)
(mred:find-string^:find-string canvas () (mred:find-string:find-string canvas ()
(- (unbox x-box) 30) (- (unbox x-box) 30)
(- (unbox y-box) 30) (- (unbox y-box) 30)
(cons 'ignore-case extras))))] (cons 'ignore-case extras))))]
@ -87,7 +90,7 @@
[flash-paren-match [flash-paren-match
(lambda (edit event) (lambda (edit event)
(send edit on-default-char event) (send edit on-default-char event)
(let ([pos (mred:scheme-paren^:scheme-backward-match (let ([pos (mred:scheme-paren:scheme-backward-match
edit edit
(send edit get-start-position) (send edit get-start-position)
0)]) 0)])
@ -743,4 +746,4 @@
(map "c:rightbutton" "copy-clipboard"))))) (map "c:rightbutton" "copy-clipboard")))))
(define global-keymap (make-object wx:keymap%)) (define global-keymap (make-object wx:keymap%))
(setup-global-keymap global-keymap)) (setup-global-keymap global-keymap)))