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^)
(import mred:debug^ mred:finder^ mred:path-utils^ mred:mode^
mred:scheme-paren^ mred:keymap^ mzlib:function^)
(define mred:edit@
(unit/s mred:edit^
(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 rectangle (left top width height pen brush))
@ -19,11 +22,11 @@
[auto-save-out-of-date? #t]
[auto-save-error? #f])
(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
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
v
'())))]
@ -46,7 +49,7 @@
(set! canvases (cons canvas canvases)))]
[remove-canvas
(lambda (canvas)
(set! canvases (mzlib:function^:remove canvas canvases)))]
(set! canvases (mzlib:function:remove canvas canvases)))]
[mode #f]
[set-mode
@ -83,7 +86,7 @@
(or (not auto-saved-name)
auto-save-out-of-date?))
(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)])
(if success
(begin
@ -114,7 +117,7 @@
(if (and backup?
(not (= format wx:const-media-ff-copy)))
(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)
(rename-file name back-name)))))
#t)
@ -189,7 +192,7 @@
(lambda (m)
(if mode
(send mode deinstall this))
(if (is-a? m mred:mode^:mode%)
(if (is-a? m mred:mode:mode%)
(begin
(set! mode m)
(set-file-format (ivar m file-format))
@ -331,7 +334,7 @@
[old-rectangles 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))
(begin-edit-sequence)
(for-each invalidate-rectangle old-rectangles)
@ -362,13 +365,13 @@
(apply super-init args)
(send edits add this)
(let ([keymap (get-keymap)])
(mred:keymap^:set-keymap-error-handler keymap)
(mred:keymap^:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap mred:keymap^:global-keymap #f))))))
(mred:keymap:set-keymap-error-handler keymap)
(mred:keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap mred:keymap:global-keymap #f))))))
(define edit% (make-edit% wx:media-edit%))
(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]
;; exit doesn't actually exit, now.
(define-sigfunctor (mred:exit@ mred:exit^)
(import mred:debug^)
(define mred:exit@
(unit/s mred:exit^
(import [mred:debug mred:debug^])
(rename (-exit exit))
(define exit-callbacks '())
@ -30,8 +28,8 @@
[(not ((car cb-list))) cb-list]
[else (loop (cdr cb-list))])))
(if (null? exit-callbacks)
(begin (when mred:debug^:exit?
(begin (when mred:debug:exit?
(exit))
#t)
#f))))
#f)))))

48
collects/mred/finder.ss
View File

@ -1,10 +1,12 @@
(define-sigfunctor (mred:finder@ mred:finder^)
(import mred:debug^ mzlib:string^ mzlib:function^ mzlib:file^)
(define mred:finder@
(unit/s mred:finder^
(import [mred:debug mred:debug^] [mzlib:string mzlib:string^]
[mzlib:function mzlib:function^] [mzlib:file mzlib:file^])
(define filter-match?
(lambda (filter name msg)
(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
(begin
(wx:message-box msg "Error")
@ -59,7 +61,7 @@
[menu-list ()])
(let-values ([(base-dir in-dir dir?) (split-path this-dir)])
(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)]
[menu-list (cons in-dir menu-list)])
(if base-dir
@ -78,7 +80,7 @@
(send name-list clear)
(send name-list set
(mzlib:function^:quicksort
(mzlib:function:quicksort
(let loop ([l (directory-list dir)])
(if (null? l)
'()
@ -93,7 +95,7 @@
(macintosh ":")))
rest)
(if (or (not file-filter)
(mzlib:string^:regexp-match-exact? file-filter s))
(mzlib:string:regexp-match-exact? file-filter s))
(cons s rest)
rest)))))
(if (eq? wx:platform 'unix) string<? string-ci<?)))
@ -112,7 +114,7 @@
"Directory" "Go to Directory"
default)])
(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)
(set-directory dir)
(begin
@ -128,7 +130,7 @@
[dir (build-path current-dir
(make-relative which))])
(if (directory-exists? dir)
(set-directory (mzlib:file^:normalize-path dir))
(set-directory (mzlib:file:normalize-path dir))
(if save-mode?
(send name-field set-value which)
(if multi-mode?
@ -154,7 +156,7 @@
(let ([name (build-path current-dir
(make-relative name))])
(if (directory-exists? name)
(set-directory (mzlib:file^:normalize-path name)))))))]
(set-directory (mzlib:file:normalize-path name)))))))]
[do-ok
(lambda args
@ -178,7 +180,7 @@
"Error")]
[(and save-mode?
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")]
[else
(let ([file (build-path current-dir
@ -188,7 +190,7 @@
(wx:message-box
"That is the name of a directory."
"Error")
(set-directory (mzlib:file^:normalize-path file)))
(set-directory (mzlib:file:normalize-path file)))
(if (or (not save-mode?)
(not (file-exists? file))
replace-ok?
@ -202,7 +204,7 @@
wx:const-yes-no)
wx:const-yes))
(begin
(set-box! result-box (mzlib:file^:normalize-path file))
(set-box! result-box (mzlib:file:normalize-path file))
(show #f)))))]))))]
[add-one
@ -210,7 +212,7 @@
(unless (or (directory-exists? name)
(> (send result-list find-string name) -1))
(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
(lambda args
(let ([name (send name-list get-string-selection)])
@ -333,7 +335,7 @@
[(and start-dir
(not (null? 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)]
[else (set-directory (current-directory))])
@ -347,10 +349,10 @@
[filter-msg "That name does not have the right form"])
(let* ([directory (if (and (null? directory)
(string? name))
(or (mzlib:file^:path-only name) null)
(or (mzlib:file:path-only name) null)
directory)]
[name (or (and (string? name)
(mzlib:file^:file-name-from-path name))
(mzlib:file:file-name-from-path name))
name)]
[v (box #f)])
(make-object finder-dialog% #t replace? #f v
@ -380,10 +382,10 @@
"That filename does not have the right form."])
(let* ([directory (if (and (null? directory)
(string? name))
(or (mzlib:file^:path-only name) null)
(or (mzlib:file:path-only name) null)
directory)]
[name (or (and (string? name)
(mzlib:file^:file-name-from-path name))
(mzlib:file:file-name-from-path name))
name)]
[f (wx:file-selector prompt directory name
'()
@ -395,9 +397,9 @@
f
filter-msg))))
#f
(let* ([f (mzlib:file^:normalize-path f)]
[dir (mzlib:file^:path-only f)]
[name (mzlib:file^:file-name-from-path f)])
(let* ([f (mzlib:file:normalize-path f)]
[dir (mzlib:file:path-only f)]
[name (mzlib:file:file-name-from-path f)])
(cond
[(not (and (string? dir) (directory-exists? dir)))
(wx:message-box "Error" "That directory does not exist.")
@ -415,7 +417,7 @@
(if (null? f)
#f
(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
[(directory-exists? f)
(wx:message-box "Error"
@ -429,4 +431,4 @@
; By default, use platform-specific get/put
(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^)
(import mred:debug^ mred:finder^ mred:handler^ mred:find-string^ mred:scheme-paren^)
(define mred:keymap@
(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
; are not normally thought of as shifted. It will have to be
@ -48,7 +51,7 @@
(wx:bell))]
[save-file-as
(lambda (edit event)
(let ([file (mred:finder^:put-file)])
(let ([file (mred:finder:put-file)])
(if file
(send edit save-file file)))
#t)]
@ -60,7 +63,7 @@
#t)]
[load-file
(lambda (edit event)
(mred:handler^:open-file)
(mred:handler:open-file)
#t)]
[find-string
(lambda (edit event . extras)
@ -69,7 +72,7 @@
[canvas (send event get-event-object)])
(send event position 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 y-box) 30)
(cons 'ignore-case extras))))]
@ -87,7 +90,7 @@
[flash-paren-match
(lambda (edit event)
(send edit on-default-char event)
(let ([pos (mred:scheme-paren^:scheme-backward-match
(let ([pos (mred:scheme-paren:scheme-backward-match
edit
(send edit get-start-position)
0)])
@ -743,4 +746,4 @@
(map "c:rightbutton" "copy-clipboard")))))
(define global-keymap (make-object wx:keymap%))
(setup-global-keymap global-keymap))
(setup-global-keymap global-keymap)))