moved to unit/s and new mred initialization system
original commit: 8e5bc8572fb3e75a962b5f5314f53ea9b6fff100
This commit is contained in:
Robby Findler
parent
ace788472e
commit
ab53e9de2f
|
|
@ -1,374 +1,377 @@
|
||||||
(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))
|
||||||
|
|
||||||
(define make-std-buffer%
|
(define make-std-buffer%
|
||||||
(lambda (buffer%)
|
(lambda (buffer%)
|
||||||
(class buffer% args
|
(class buffer% args
|
||||||
(inherit modified? get-filename save-file set-max-width)
|
(inherit modified? get-filename save-file set-max-width)
|
||||||
(rename
|
(rename
|
||||||
[super-set-filename set-filename]
|
[super-set-filename set-filename]
|
||||||
[super-set-modified set-modified]
|
[super-set-modified set-modified]
|
||||||
[super-on-change on-change]
|
[super-on-change on-change]
|
||||||
[super-on-save-file on-save-file])
|
[super-on-save-file on-save-file])
|
||||||
(private
|
(private
|
||||||
[auto-saved-name #f]
|
[auto-saved-name #f]
|
||||||
[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
|
||||||
'())))]
|
'())))]
|
||||||
|
|
||||||
[auto-set-wrap? #f]
|
[auto-set-wrap? #f]
|
||||||
[set-auto-set-wrap
|
[set-auto-set-wrap
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(set! auto-set-wrap? v)
|
(set! auto-set-wrap? v)
|
||||||
(if (not v)
|
(if (not v)
|
||||||
(set-max-width -1)))]
|
(set-max-width -1)))]
|
||||||
|
|
||||||
[active-canvas #f]
|
[active-canvas #f]
|
||||||
[set-active-canvas
|
[set-active-canvas
|
||||||
(lambda (c)
|
(lambda (c)
|
||||||
(set! active-canvas c))]
|
(set! active-canvas c))]
|
||||||
|
|
||||||
[canvases '()]
|
[canvases '()]
|
||||||
[add-canvas
|
[add-canvas
|
||||||
(lambda (canvas)
|
(lambda (canvas)
|
||||||
(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
|
||||||
(lambda (m)
|
(lambda (m)
|
||||||
#f)]
|
#f)]
|
||||||
|
|
||||||
[set-modified
|
[set-modified
|
||||||
(lambda (modified?)
|
(lambda (modified?)
|
||||||
(if auto-saved-name
|
(if auto-saved-name
|
||||||
(if (not modified?)
|
(if (not modified?)
|
||||||
(begin
|
(begin
|
||||||
(delete-file auto-saved-name)
|
(delete-file auto-saved-name)
|
||||||
(set! auto-saved-name #f))
|
(set! auto-saved-name #f))
|
||||||
(set! auto-save-out-of-date? #t)))
|
(set! auto-save-out-of-date? #t)))
|
||||||
(super-set-modified modified?)
|
(super-set-modified modified?)
|
||||||
(for-each (lambda (canvas) (send canvas edit-modified modified?))
|
(for-each (lambda (canvas) (send canvas edit-modified modified?))
|
||||||
canvases))]
|
canvases))]
|
||||||
[set-filename
|
[set-filename
|
||||||
(opt-lambda (name [temp? #f])
|
(opt-lambda (name [temp? #f])
|
||||||
(super-set-filename name temp?)
|
(super-set-filename name temp?)
|
||||||
(for-each (lambda (canvas) (send canvas edit-renamed name))
|
(for-each (lambda (canvas) (send canvas edit-renamed name))
|
||||||
canvases))]
|
canvases))]
|
||||||
|
|
||||||
[on-change
|
[on-change
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(super-on-change)
|
(super-on-change)
|
||||||
(set! auto-save-out-of-date? #t))]
|
(set! auto-save-out-of-date? #t))]
|
||||||
[auto-save? #t]
|
[auto-save? #t]
|
||||||
[do-autosave
|
[do-autosave
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(when (and auto-save?
|
(when (and auto-save?
|
||||||
(not auto-save-error?)
|
(not auto-save-error?)
|
||||||
(modified?)
|
(modified?)
|
||||||
(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
|
||||||
(if auto-saved-name
|
(if auto-saved-name
|
||||||
(delete-file auto-saved-name))
|
(delete-file auto-saved-name))
|
||||||
(set! auto-saved-name auto-name)
|
(set! auto-saved-name auto-name)
|
||||||
(set! auto-save-out-of-date? #f))
|
(set! auto-save-out-of-date? #f))
|
||||||
(begin
|
(begin
|
||||||
(wx:message-box
|
(wx:message-box
|
||||||
(format "Error autosaving ~s.~n~a~n~a"
|
(format "Error autosaving ~s.~n~a~n~a"
|
||||||
(if (null? orig-name) "Untitled" orig-name)
|
(if (null? orig-name) "Untitled" orig-name)
|
||||||
"Autosaving is turned off"
|
"Autosaving is turned off"
|
||||||
"until the file is saved.")
|
"until the file is saved.")
|
||||||
"Warning")
|
"Warning")
|
||||||
(set! auto-save-error? #t))))))]
|
(set! auto-save-error? #t))))))]
|
||||||
[remove-autosave
|
[remove-autosave
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(when auto-saved-name
|
(when auto-saved-name
|
||||||
(delete-file auto-saved-name)
|
(delete-file auto-saved-name)
|
||||||
(set! auto-saved-name #f)))]
|
(set! auto-saved-name #f)))]
|
||||||
|
|
||||||
[backup? #t]
|
[backup? #t]
|
||||||
[on-save-file
|
[on-save-file
|
||||||
(lambda (name format)
|
(lambda (name format)
|
||||||
(set! auto-save-error? #f)
|
(set! auto-save-error? #f)
|
||||||
(if (super-on-save-file name format)
|
(if (super-on-save-file name format)
|
||||||
(begin
|
(begin
|
||||||
(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)
|
||||||
#f))]
|
#f))]
|
||||||
|
|
||||||
[get-canvas
|
[get-canvas
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(cond
|
(cond
|
||||||
[(and active-canvas
|
[(and active-canvas
|
||||||
(member active-canvas canvases))
|
(member active-canvas canvases))
|
||||||
active-canvas]
|
active-canvas]
|
||||||
[(null? canvases) #f]
|
[(null? canvases) #f]
|
||||||
[else (car canvases)]))]
|
[else (car canvases)]))]
|
||||||
[get-frame
|
[get-frame
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ([c (get-canvas)])
|
(let ([c (get-canvas)])
|
||||||
(if c
|
(if c
|
||||||
(let ([f (send c get-parent)])
|
(let ([f (send c get-parent)])
|
||||||
(if (null? f)
|
(if (null? f)
|
||||||
#f
|
#f
|
||||||
f))
|
f))
|
||||||
#f)))])
|
#f)))])
|
||||||
(sequence
|
(sequence
|
||||||
(apply super-init args)))))
|
(apply super-init args)))))
|
||||||
|
|
||||||
(define edits%
|
(define edits%
|
||||||
(class-asi wx:snip%
|
(class-asi wx:snip%
|
||||||
(private
|
(private
|
||||||
[edits null])
|
[edits null])
|
||||||
(public
|
(public
|
||||||
[add
|
[add
|
||||||
(lambda (edit)
|
(lambda (edit)
|
||||||
(unless (let loop ([e edits])
|
(unless (let loop ([e edits])
|
||||||
(cond
|
(cond
|
||||||
[(null? e) #f]
|
[(null? e) #f]
|
||||||
[else (if (eq? this (car e))
|
[else (if (eq? this (car e))
|
||||||
#t
|
#t
|
||||||
(loop (cdr e)))]))
|
(loop (cdr e)))]))
|
||||||
(set! edits (cons edit edits))))])))
|
(set! edits (cons edit edits))))])))
|
||||||
|
|
||||||
(define edits (make-object edits%))
|
(define edits (make-object edits%))
|
||||||
|
|
||||||
(define make-edit%
|
(define make-edit%
|
||||||
(lambda (super%)
|
(lambda (super%)
|
||||||
(class (make-std-buffer% super%) args
|
(class (make-std-buffer% super%) args
|
||||||
(inherit mode canvases
|
(inherit mode canvases
|
||||||
invalidate-bitmap-cache
|
invalidate-bitmap-cache
|
||||||
begin-edit-sequence end-edit-sequence
|
begin-edit-sequence end-edit-sequence
|
||||||
flash-on get-keymap get-start-position
|
flash-on get-keymap get-start-position
|
||||||
on-default-char on-default-event
|
on-default-char on-default-event
|
||||||
set-file-format get-style-list)
|
set-file-format get-style-list)
|
||||||
(rename [super-on-focus on-focus]
|
(rename [super-on-focus on-focus]
|
||||||
[super-on-paint on-paint]
|
[super-on-paint on-paint]
|
||||||
[super-on-local-event on-local-event]
|
[super-on-local-event on-local-event]
|
||||||
[super-on-local-char on-local-char]
|
[super-on-local-char on-local-char]
|
||||||
|
|
||||||
[super-after-set-position after-set-position]
|
[super-after-set-position after-set-position]
|
||||||
|
|
||||||
[super-on-edit-sequence on-edit-sequence]
|
[super-on-edit-sequence on-edit-sequence]
|
||||||
[super-on-change-style on-change-style]
|
[super-on-change-style on-change-style]
|
||||||
[super-on-insert on-insert]
|
[super-on-insert on-insert]
|
||||||
[super-on-delete on-delete]
|
[super-on-delete on-delete]
|
||||||
[super-on-set-size-constraint on-set-size-constraint]
|
[super-on-set-size-constraint on-set-size-constraint]
|
||||||
|
|
||||||
[super-after-edit-sequence after-edit-sequence]
|
[super-after-edit-sequence after-edit-sequence]
|
||||||
[super-after-change-style after-change-style]
|
[super-after-change-style after-change-style]
|
||||||
[super-after-insert after-insert]
|
[super-after-insert after-insert]
|
||||||
[super-after-delete after-delete]
|
[super-after-delete after-delete]
|
||||||
[super-after-set-size-constraint after-set-size-constraint])
|
[super-after-set-size-constraint after-set-size-constraint])
|
||||||
(public
|
(public
|
||||||
[set-mode
|
[set-mode
|
||||||
(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))
|
||||||
(send (send (get-style-list)
|
(send (send (get-style-list)
|
||||||
find-named-style "Standard")
|
find-named-style "Standard")
|
||||||
set-delta (ivar m standard-style-delta))
|
set-delta (ivar m standard-style-delta))
|
||||||
(send m install this))
|
(send m install this))
|
||||||
(begin
|
(begin
|
||||||
(set! mode #f)
|
(set! mode #f)
|
||||||
(send (send (get-style-list)
|
(send (send (get-style-list)
|
||||||
find-named-style "Standard")
|
find-named-style "Standard")
|
||||||
set-delta (make-object wx:style-delta%)))))]
|
set-delta (make-object wx:style-delta%)))))]
|
||||||
[on-focus
|
[on-focus
|
||||||
(lambda (on?)
|
(lambda (on?)
|
||||||
(super-on-focus on?)
|
(super-on-focus on?)
|
||||||
(when mode
|
(when mode
|
||||||
(send mode on-focus this on?)))]
|
(send mode on-focus this on?)))]
|
||||||
[on-local-event
|
[on-local-event
|
||||||
(lambda (mouse)
|
(lambda (mouse)
|
||||||
(if (or (not mode)
|
(if (or (not mode)
|
||||||
(not (send mode on-event this mouse)))
|
(not (send mode on-event this mouse)))
|
||||||
(super-on-local-event mouse)))]
|
(super-on-local-event mouse)))]
|
||||||
[on-insert
|
[on-insert
|
||||||
(lambda (start len)
|
(lambda (start len)
|
||||||
(if (or (not mode) (send mode on-insert this start len))
|
(if (or (not mode) (send mode on-insert this start len))
|
||||||
(super-on-insert start len)))]
|
(super-on-insert start len)))]
|
||||||
[on-delete
|
[on-delete
|
||||||
(lambda (start len)
|
(lambda (start len)
|
||||||
(if (or (not mode) (send mode on-delete this start len))
|
(if (or (not mode) (send mode on-delete this start len))
|
||||||
(super-on-delete start len)))]
|
(super-on-delete start len)))]
|
||||||
[on-change-style
|
[on-change-style
|
||||||
(lambda (start len)
|
(lambda (start len)
|
||||||
(if (or (not mode) (send mode on-change-style this start len))
|
(if (or (not mode) (send mode on-change-style this start len))
|
||||||
(super-on-change-style start len)))]
|
(super-on-change-style start len)))]
|
||||||
[on-edit-sequence
|
[on-edit-sequence
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(when mode
|
(when mode
|
||||||
(send mode on-edit-sequence this))
|
(send mode on-edit-sequence this))
|
||||||
(super-on-edit-sequence))]
|
(super-on-edit-sequence))]
|
||||||
[on-set-size-constraint
|
[on-set-size-constraint
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(if (or (not mode) (send mode on-set-size-constraint this))
|
(if (or (not mode) (send mode on-set-size-constraint this))
|
||||||
(super-on-set-size-constraint)))]
|
(super-on-set-size-constraint)))]
|
||||||
|
|
||||||
[after-insert
|
[after-insert
|
||||||
(lambda (start len)
|
(lambda (start len)
|
||||||
(if mode (send mode after-insert this start len))
|
(if mode (send mode after-insert this start len))
|
||||||
(super-after-insert start len))]
|
(super-after-insert start len))]
|
||||||
[after-delete
|
[after-delete
|
||||||
(lambda (start len)
|
(lambda (start len)
|
||||||
(if mode (send mode after-delete this start len))
|
(if mode (send mode after-delete this start len))
|
||||||
(super-after-delete start len))]
|
(super-after-delete start len))]
|
||||||
[after-change-style
|
[after-change-style
|
||||||
(lambda (start len)
|
(lambda (start len)
|
||||||
(when mode (send mode after-change-style this start len))
|
(when mode (send mode after-change-style this start len))
|
||||||
(super-after-change-style start len))]
|
(super-after-change-style start len))]
|
||||||
[after-edit-sequence
|
[after-edit-sequence
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(when mode
|
(when mode
|
||||||
(send mode after-edit-sequence this))
|
(send mode after-edit-sequence this))
|
||||||
(super-after-edit-sequence))]
|
(super-after-edit-sequence))]
|
||||||
[after-set-size-constraint
|
[after-set-size-constraint
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(when mode
|
(when mode
|
||||||
(send mode after-set-size-constraint this))
|
(send mode after-set-size-constraint this))
|
||||||
(super-after-set-size-constraint))]
|
(super-after-set-size-constraint))]
|
||||||
|
|
||||||
[after-set-position
|
[after-set-position
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(when mode
|
(when mode
|
||||||
(send mode after-set-position this))
|
(send mode after-set-position this))
|
||||||
(super-after-set-position))]
|
(super-after-set-position))]
|
||||||
|
|
||||||
[ranges null]
|
[ranges null]
|
||||||
[add-range
|
[add-range
|
||||||
(lambda (start end pen brush)
|
(lambda (start end pen brush)
|
||||||
(let ([l (make-range start end pen brush)])
|
(let ([l (make-range start end pen brush)])
|
||||||
(set! ranges (cons l ranges))
|
(set! ranges (cons l ranges))
|
||||||
(recompute-range-rectangles)
|
(recompute-range-rectangles)
|
||||||
(lambda () (set! ranges
|
(lambda () (set! ranges
|
||||||
(let loop ([r ranges])
|
(let loop ([r ranges])
|
||||||
(cond
|
(cond
|
||||||
[(null? r) r]
|
[(null? r) r]
|
||||||
[else (if (eq? (car r) l)
|
[else (if (eq? (car r) l)
|
||||||
(cdr r)
|
(cdr r)
|
||||||
(cons (car r) (loop (cdr r))))])))
|
(cons (car r) (loop (cdr r))))])))
|
||||||
(recompute-range-rectangles))))]
|
(recompute-range-rectangles))))]
|
||||||
[range-rectangles null]
|
[range-rectangles null]
|
||||||
[recompute-range-rectangles
|
[recompute-range-rectangles
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ([new-rectangles
|
(let ([new-rectangles
|
||||||
(lambda (range)
|
(lambda (range)
|
||||||
(let ([start (range-start range)]
|
(let ([start (range-start range)]
|
||||||
[end (range-end range)]
|
[end (range-end range)]
|
||||||
[pen (range-pen range)]
|
[pen (range-pen range)]
|
||||||
[brush (range-brush range)]
|
[brush (range-brush range)]
|
||||||
[buffer-width (box 0)]
|
[buffer-width (box 0)]
|
||||||
[start-x (box 0)]
|
[start-x (box 0)]
|
||||||
[top-start-y (box 0)]
|
[top-start-y (box 0)]
|
||||||
[bottom-start-y (box 0)]
|
[bottom-start-y (box 0)]
|
||||||
[end-x (box 0)]
|
[end-x (box 0)]
|
||||||
[top-end-y (box 0)]
|
[top-end-y (box 0)]
|
||||||
[bottom-end-y (box 0)])
|
[bottom-end-y (box 0)])
|
||||||
(send this get-extent buffer-width null)
|
(send this get-extent buffer-width null)
|
||||||
(send this position-location start start-x top-start-y #t #f #t)
|
(send this position-location start start-x top-start-y #t #f #t)
|
||||||
(send this position-location end end-x top-end-y #t #t #t)
|
(send this position-location end end-x top-end-y #t #t #t)
|
||||||
(send this position-location start start-x bottom-start-y #f #f #t)
|
(send this position-location start start-x bottom-start-y #f #f #t)
|
||||||
(send this position-location end end-x bottom-end-y #f #t #t)
|
(send this position-location end end-x bottom-end-y #f #t #t)
|
||||||
(cond
|
(cond
|
||||||
[(= (unbox top-start-y) (unbox top-end-y))
|
[(= (unbox top-start-y) (unbox top-end-y))
|
||||||
(list (make-rectangle (unbox start-x)
|
(list (make-rectangle (unbox start-x)
|
||||||
(unbox top-start-y)
|
(unbox top-start-y)
|
||||||
(- (unbox end-x) (unbox start-x))
|
(- (unbox end-x) (unbox start-x))
|
||||||
(- (unbox bottom-start-y) (unbox top-start-y))
|
(- (unbox bottom-start-y) (unbox top-start-y))
|
||||||
pen brush))]
|
pen brush))]
|
||||||
[else
|
[else
|
||||||
(list
|
(list
|
||||||
(make-rectangle (unbox start-x)
|
(make-rectangle (unbox start-x)
|
||||||
(unbox top-start-y)
|
(unbox top-start-y)
|
||||||
(- (unbox buffer-width) (unbox start-x))
|
(- (unbox buffer-width) (unbox start-x))
|
||||||
(- (unbox bottom-start-y) (unbox top-start-y))
|
(- (unbox bottom-start-y) (unbox top-start-y))
|
||||||
pen brush)
|
pen brush)
|
||||||
(make-rectangle 0
|
(make-rectangle 0
|
||||||
(unbox bottom-start-y)
|
(unbox bottom-start-y)
|
||||||
(unbox buffer-width)
|
(unbox buffer-width)
|
||||||
(- (unbox top-end-y) (unbox bottom-start-y))
|
(- (unbox top-end-y) (unbox bottom-start-y))
|
||||||
pen brush)
|
pen brush)
|
||||||
(make-rectangle 0
|
(make-rectangle 0
|
||||||
(unbox top-end-y)
|
(unbox top-end-y)
|
||||||
(unbox end-x)
|
(unbox end-x)
|
||||||
(- (unbox bottom-end-y) (unbox top-end-y))
|
(- (unbox bottom-end-y) (unbox top-end-y))
|
||||||
pen brush))])))]
|
pen brush))])))]
|
||||||
[invalidate-rectangle
|
[invalidate-rectangle
|
||||||
(lambda (r)
|
(lambda (r)
|
||||||
(invalidate-bitmap-cache (rectangle-left r)
|
(invalidate-bitmap-cache (rectangle-left r)
|
||||||
(rectangle-top r)
|
(rectangle-top r)
|
||||||
(rectangle-width r)
|
(rectangle-width r)
|
||||||
(rectangle-height r)))]
|
(rectangle-height r)))]
|
||||||
[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)
|
||||||
(for-each invalidate-rectangle range-rectangles)
|
(for-each invalidate-rectangle range-rectangles)
|
||||||
(end-edit-sequence)))]
|
(end-edit-sequence)))]
|
||||||
[on-paint
|
[on-paint
|
||||||
(lambda (before dc left top right bottom dx dy draw-caret)
|
(lambda (before dc left top right bottom dx dy draw-caret)
|
||||||
(super-on-paint before dc left top right bottom dx dy draw-caret)
|
(super-on-paint before dc left top right bottom dx dy draw-caret)
|
||||||
(unless before
|
(unless before
|
||||||
(for-each (lambda (rectangle)
|
(for-each (lambda (rectangle)
|
||||||
(let ([pen (rectangle-pen rectangle)]
|
(let ([pen (rectangle-pen rectangle)]
|
||||||
[brush (rectangle-brush rectangle)]
|
[brush (rectangle-brush rectangle)]
|
||||||
[old-pen (send dc get-pen)]
|
[old-pen (send dc get-pen)]
|
||||||
[old-brush (send dc get-brush)]
|
[old-brush (send dc get-brush)]
|
||||||
[left (rectangle-left rectangle)]
|
[left (rectangle-left rectangle)]
|
||||||
[top (rectangle-top rectangle)]
|
[top (rectangle-top rectangle)]
|
||||||
[width (rectangle-width rectangle)]
|
[width (rectangle-width rectangle)]
|
||||||
[height (rectangle-height rectangle)])
|
[height (rectangle-height rectangle)])
|
||||||
(send dc set-pen pen)
|
(send dc set-pen pen)
|
||||||
(send dc set-brush brush)
|
(send dc set-brush brush)
|
||||||
(unless (or (zero? width)
|
(unless (or (zero? width)
|
||||||
(zero? height))
|
(zero? height))
|
||||||
(send dc draw-rectangle (+ left dx) (+ top dy) width height))
|
(send dc draw-rectangle (+ left dx) (+ top dy) width height))
|
||||||
(send dc set-pen old-pen)
|
(send dc set-pen old-pen)
|
||||||
(send dc set-brush old-brush)))
|
(send dc set-brush old-brush)))
|
||||||
range-rectangles)))])
|
range-rectangles)))])
|
||||||
(sequence
|
(sequence
|
||||||
(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%))))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,37 +1,35 @@
|
||||||
;; [Robby]
|
(define mred:exit@
|
||||||
;; exit doesn't actually exit, now.
|
(unit/s mred:exit^
|
||||||
|
(import [mred:debug mred:debug^])
|
||||||
|
(rename (-exit exit))
|
||||||
|
|
||||||
(define-sigfunctor (mred:exit@ mred:exit^)
|
(define exit-callbacks '())
|
||||||
(import mred:debug^)
|
|
||||||
(rename (-exit exit))
|
|
||||||
|
|
||||||
(define exit-callbacks '())
|
(define insert-exit-callback
|
||||||
|
(lambda (f)
|
||||||
|
(set! exit-callbacks (cons f exit-callbacks))
|
||||||
|
f))
|
||||||
|
|
||||||
(define insert-exit-callback
|
(define remove-exit-callback
|
||||||
(lambda (f)
|
(lambda (cb)
|
||||||
(set! exit-callbacks (cons f exit-callbacks))
|
(set! exit-callbacks
|
||||||
f))
|
(let loop ([cb-list exit-callbacks])
|
||||||
|
(cond
|
||||||
|
[(null? cb-list) ()]
|
||||||
|
[(eq? cb (car cb-list)) (cdr cb-list)]
|
||||||
|
[else (cons (car cb-list) (loop (cdr cb-list)))])))))
|
||||||
|
|
||||||
(define remove-exit-callback
|
(define -exit
|
||||||
(lambda (cb)
|
(lambda ()
|
||||||
(set! exit-callbacks
|
(set! exit-callbacks
|
||||||
(let loop ([cb-list exit-callbacks])
|
(let loop ([cb-list exit-callbacks])
|
||||||
(cond
|
(cond
|
||||||
[(null? cb-list) ()]
|
[(null? cb-list) ()]
|
||||||
[(eq? cb (car cb-list)) (cdr cb-list)]
|
[(not ((car cb-list))) cb-list]
|
||||||
[else (cons (car cb-list) (loop (cdr cb-list)))])))))
|
[else (loop (cdr cb-list))])))
|
||||||
|
(if (null? exit-callbacks)
|
||||||
(define -exit
|
(begin (when mred:debug:exit?
|
||||||
(lambda ()
|
(exit))
|
||||||
(set! exit-callbacks
|
#t)
|
||||||
(let loop ([cb-list exit-callbacks])
|
#f)))))
|
||||||
(cond
|
|
||||||
[(null? cb-list) ()]
|
|
||||||
[(not ((car cb-list))) cb-list]
|
|
||||||
[else (loop (cdr cb-list))])))
|
|
||||||
(if (null? exit-callbacks)
|
|
||||||
(begin (when mred:debug^:exit?
|
|
||||||
(exit))
|
|
||||||
#t)
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,432 +1,434 @@
|
||||||
(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")
|
||||||
#f)))))
|
#f)))))
|
||||||
|
|
||||||
(define last-directory #f)
|
(define last-directory #f)
|
||||||
|
|
||||||
(define make-relative
|
(define make-relative
|
||||||
(lambda (s) s))
|
(lambda (s) s))
|
||||||
|
|
||||||
(define current-find-file-directory
|
(define current-find-file-directory
|
||||||
(opt-lambda ([dir 'get])
|
(opt-lambda ([dir 'get])
|
||||||
(cond
|
(cond
|
||||||
[(eq? dir 'get)
|
[(eq? dir 'get)
|
||||||
(if (not last-directory)
|
(if (not last-directory)
|
||||||
(set! last-directory (current-directory)))
|
(set! last-directory (current-directory)))
|
||||||
last-directory]
|
last-directory]
|
||||||
[(and (string? dir)
|
[(and (string? dir)
|
||||||
(directory-exists? dir))
|
(directory-exists? dir))
|
||||||
(set! last-directory dir)
|
(set! last-directory dir)
|
||||||
#t]
|
#t]
|
||||||
[else #f])))
|
[else #f])))
|
||||||
|
|
||||||
(define finder-dialog%
|
(define finder-dialog%
|
||||||
(class wx:dialog-box% (save-mode? replace-ok? multi-mode?
|
(class wx:dialog-box% (save-mode? replace-ok? multi-mode?
|
||||||
result-box start-dir
|
result-box start-dir
|
||||||
start-name prompt
|
start-name prompt
|
||||||
file-filter file-filter-msg)
|
file-filter file-filter-msg)
|
||||||
(inherit
|
(inherit
|
||||||
new-line tab fit center
|
new-line tab fit center
|
||||||
show
|
show
|
||||||
popup-menu)
|
popup-menu)
|
||||||
|
|
||||||
(private
|
(private
|
||||||
[WIDTH 500]
|
[WIDTH 500]
|
||||||
[HEIGHT 500]
|
[HEIGHT 500]
|
||||||
|
|
||||||
dirs current-dir
|
dirs current-dir
|
||||||
last-selected
|
last-selected
|
||||||
|
|
||||||
[select-counter 0])
|
[select-counter 0])
|
||||||
|
|
||||||
(private
|
(private
|
||||||
[set-directory
|
[set-directory
|
||||||
(lambda (dir) ; dir is normalied
|
(lambda (dir) ; dir is normalied
|
||||||
(set! current-dir dir)
|
(set! current-dir dir)
|
||||||
(set! last-directory dir)
|
(set! last-directory dir)
|
||||||
(let-values
|
(let-values
|
||||||
([(dir-list menu-list)
|
([(dir-list menu-list)
|
||||||
(let loop ([this-dir dir]
|
(let loop ([this-dir dir]
|
||||||
[dir-list ()]
|
[dir-list ()]
|
||||||
[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
|
||||||
(loop base-dir dir-list menu-list)
|
(loop base-dir dir-list menu-list)
|
||||||
; No more
|
; No more
|
||||||
(values dir-list menu-list)))))])
|
(values dir-list menu-list)))))])
|
||||||
(set! dirs dir-list)
|
(set! dirs dir-list)
|
||||||
|
|
||||||
(send dir-choice clear)
|
(send dir-choice clear)
|
||||||
(let loop ([choices menu-list])
|
(let loop ([choices menu-list])
|
||||||
(unless (null? choices)
|
(unless (null? choices)
|
||||||
(send dir-choice append (car choices))
|
(send dir-choice append (car choices))
|
||||||
(loop (cdr choices))))
|
(loop (cdr choices))))
|
||||||
(send dir-choice set-selection (sub1 (length dirs)))
|
(send dir-choice set-selection (sub1 (length dirs)))
|
||||||
(send dir-choice set-size -1 -1 -1 -1))
|
(send dir-choice set-size -1 -1 -1 -1))
|
||||||
|
|
||||||
(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)
|
||||||
'()
|
'()
|
||||||
(let ([s (car l)]
|
(let ([s (car l)]
|
||||||
[rest (loop (cdr l))])
|
[rest (loop (cdr l))])
|
||||||
(if (directory-exists? (build-path dir s))
|
(if (directory-exists? (build-path dir s))
|
||||||
(cons
|
(cons
|
||||||
(string-append s
|
(string-append s
|
||||||
(case wx:platform
|
(case wx:platform
|
||||||
(unix "/")
|
(unix "/")
|
||||||
(windows "\\")
|
(windows "\\")
|
||||||
(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<?)))
|
||||||
(set! last-selected -1))])
|
(set! last-selected -1))])
|
||||||
|
|
||||||
(public
|
(public
|
||||||
[do-dir
|
[do-dir
|
||||||
(lambda (choice event)
|
(lambda (choice event)
|
||||||
(let ([which (send event get-selection)])
|
(let ([which (send event get-selection)])
|
||||||
(if (< which (length dirs))
|
(if (< which (length dirs))
|
||||||
(set-directory (list-ref dirs which)))))]
|
(set-directory (list-ref dirs which)))))]
|
||||||
|
|
||||||
[do-goto
|
[do-goto
|
||||||
(opt-lambda (button event [default ""])
|
(opt-lambda (button event [default ""])
|
||||||
(let ([orig-dir (wx:get-text-from-user
|
(let ([orig-dir (wx:get-text-from-user
|
||||||
"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
|
||||||
(wx:message-box
|
(wx:message-box
|
||||||
(string-append "Bad directory: " dir)
|
(string-append "Bad directory: " dir)
|
||||||
"Error")
|
"Error")
|
||||||
(do-goto button event orig-dir)))))))]
|
(do-goto button event orig-dir)))))))]
|
||||||
|
|
||||||
[on-default-action
|
[on-default-action
|
||||||
(lambda (which)
|
(lambda (which)
|
||||||
(if (eq? which name-list)
|
(if (eq? which name-list)
|
||||||
(let* ([which (send name-list get-string-selection)]
|
(let* ([which (send name-list get-string-selection)]
|
||||||
[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?
|
||||||
(do-add)
|
(do-add)
|
||||||
(do-ok)))))
|
(do-ok)))))
|
||||||
(if (eq? which name-field)
|
(if (eq? which name-field)
|
||||||
(do-ok))))]
|
(do-ok))))]
|
||||||
|
|
||||||
[do-name
|
[do-name
|
||||||
(lambda (text event)
|
(lambda (text event)
|
||||||
(if (eq? (send event get-event-type)
|
(if (eq? (send event get-event-type)
|
||||||
wx:const-event-type-text-enter-command)
|
wx:const-event-type-text-enter-command)
|
||||||
(do-ok)))]
|
(do-ok)))]
|
||||||
[do-name-list
|
[do-name-list
|
||||||
(lambda args #f)]
|
(lambda args #f)]
|
||||||
[do-result-list
|
[do-result-list
|
||||||
(lambda args #f)]
|
(lambda args #f)]
|
||||||
|
|
||||||
[do-into-dir
|
[do-into-dir
|
||||||
(lambda args
|
(lambda args
|
||||||
(let ([name (send name-list get-string-selection)])
|
(let ([name (send name-list get-string-selection)])
|
||||||
(if (string? name)
|
(if (string? name)
|
||||||
(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
|
||||||
(if multi-mode?
|
(if multi-mode?
|
||||||
(let loop ([n (sub1 select-counter)][result ()])
|
(let loop ([n (sub1 select-counter)][result ()])
|
||||||
(if (< n 0)
|
(if (< n 0)
|
||||||
(begin
|
|
||||||
(set-box! result-box result)
|
|
||||||
(show #f))
|
|
||||||
(loop (sub1 n)
|
|
||||||
(cons (send result-list get-string n)
|
|
||||||
result))))
|
|
||||||
(let ([name
|
|
||||||
(if save-mode?
|
|
||||||
(send name-field get-value)
|
|
||||||
(send name-list get-string-selection))])
|
|
||||||
(cond
|
|
||||||
[(not (string? name)) 'nothing-selected]
|
|
||||||
[(string=? name "")
|
|
||||||
(wx:message-box "You must specify a file name"
|
|
||||||
"Error")]
|
|
||||||
[(and save-mode?
|
|
||||||
file-filter
|
|
||||||
(not (mzlib:string^:regexp-match-exact? file-filter name)))
|
|
||||||
(wx:message-box file-filter-msg "Error")]
|
|
||||||
[else
|
|
||||||
(let ([file (build-path current-dir
|
|
||||||
(make-relative name))])
|
|
||||||
(if (directory-exists? file)
|
|
||||||
(if save-mode?
|
|
||||||
(wx:message-box
|
|
||||||
"That is the name of a directory."
|
|
||||||
"Error")
|
|
||||||
(set-directory (mzlib:file^:normalize-path file)))
|
|
||||||
(if (or (not save-mode?)
|
|
||||||
(not (file-exists? file))
|
|
||||||
replace-ok?
|
|
||||||
(= (wx:message-box
|
|
||||||
(string-append
|
|
||||||
"The file "
|
|
||||||
name
|
|
||||||
" already exists. "
|
|
||||||
"Replace it?")
|
|
||||||
"Warning"
|
|
||||||
wx:const-yes-no)
|
|
||||||
wx:const-yes))
|
|
||||||
(begin
|
(begin
|
||||||
(set-box! result-box (mzlib:file^:normalize-path file))
|
(set-box! result-box result)
|
||||||
(show #f)))))]))))]
|
(show #f))
|
||||||
|
(loop (sub1 n)
|
||||||
|
(cons (send result-list get-string n)
|
||||||
|
result))))
|
||||||
|
(let ([name
|
||||||
|
(if save-mode?
|
||||||
|
(send name-field get-value)
|
||||||
|
(send name-list get-string-selection))])
|
||||||
|
(cond
|
||||||
|
[(not (string? name)) 'nothing-selected]
|
||||||
|
[(string=? name "")
|
||||||
|
(wx:message-box "You must specify a file name"
|
||||||
|
"Error")]
|
||||||
|
[(and save-mode?
|
||||||
|
file-filter
|
||||||
|
(not (mzlib:string:regexp-match-exact? file-filter name)))
|
||||||
|
(wx:message-box file-filter-msg "Error")]
|
||||||
|
[else
|
||||||
|
(let ([file (build-path current-dir
|
||||||
|
(make-relative name))])
|
||||||
|
(if (directory-exists? file)
|
||||||
|
(if save-mode?
|
||||||
|
(wx:message-box
|
||||||
|
"That is the name of a directory."
|
||||||
|
"Error")
|
||||||
|
(set-directory (mzlib:file:normalize-path file)))
|
||||||
|
(if (or (not save-mode?)
|
||||||
|
(not (file-exists? file))
|
||||||
|
replace-ok?
|
||||||
|
(= (wx:message-box
|
||||||
|
(string-append
|
||||||
|
"The file "
|
||||||
|
name
|
||||||
|
" already exists. "
|
||||||
|
"Replace it?")
|
||||||
|
"Warning"
|
||||||
|
wx:const-yes-no)
|
||||||
|
wx:const-yes))
|
||||||
|
(begin
|
||||||
|
(set-box! result-box (mzlib:file:normalize-path file))
|
||||||
|
(show #f)))))]))))]
|
||||||
|
|
||||||
[add-one
|
[add-one
|
||||||
(lambda (name)
|
(lambda (name)
|
||||||
(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)])
|
||||||
(if (string? name)
|
(if (string? name)
|
||||||
(let ([name (build-path current-dir
|
(let ([name (build-path current-dir
|
||||||
(make-relative name))])
|
(make-relative name))])
|
||||||
(add-one name)))))]
|
(add-one name)))))]
|
||||||
[do-add-all
|
[do-add-all
|
||||||
(lambda args
|
(lambda args
|
||||||
(let loop ([n 0])
|
(let loop ([n 0])
|
||||||
(let ([name (send name-list get-string n)])
|
(let ([name (send name-list get-string n)])
|
||||||
(if (and (string? name)
|
(if (and (string? name)
|
||||||
(positive? (string-length name)))
|
(positive? (string-length name)))
|
||||||
(let ([name (build-path current-dir
|
(let ([name (build-path current-dir
|
||||||
(make-relative name))])
|
(make-relative name))])
|
||||||
(add-one name)
|
(add-one name)
|
||||||
(loop (add1 n)))))))]
|
(loop (add1 n)))))))]
|
||||||
[do-remove
|
[do-remove
|
||||||
(lambda args
|
(lambda args
|
||||||
(let loop ([n 0])
|
(let loop ([n 0])
|
||||||
(if (< n select-counter)
|
(if (< n select-counter)
|
||||||
(if (send result-list selected? n)
|
(if (send result-list selected? n)
|
||||||
(begin
|
(begin
|
||||||
(send result-list delete n)
|
(send result-list delete n)
|
||||||
(set! select-counter (sub1 select-counter))
|
(set! select-counter (sub1 select-counter))
|
||||||
(loop n))
|
(loop n))
|
||||||
(loop (add1 n))))))]
|
(loop (add1 n))))))]
|
||||||
|
|
||||||
[do-cancel
|
[do-cancel
|
||||||
(lambda args
|
(lambda args
|
||||||
(set-box! result-box #f)
|
(set-box! result-box #f)
|
||||||
(show #f))]
|
(show #f))]
|
||||||
|
|
||||||
[on-close (lambda () #f)])
|
[on-close (lambda () #f)])
|
||||||
(sequence
|
(sequence
|
||||||
|
|
||||||
(super-init () (if save-mode? "Put File" "Get File")
|
(super-init () (if save-mode? "Put File" "Get File")
|
||||||
#t 300 300 WIDTH HEIGHT)
|
#t 300 300 WIDTH HEIGHT)
|
||||||
|
|
||||||
(make-object wx:message% this prompt)
|
(make-object wx:message% this prompt)
|
||||||
|
|
||||||
(new-line))
|
(new-line))
|
||||||
|
|
||||||
(private
|
(private
|
||||||
[dir-choice (make-object wx:choice%
|
[dir-choice (make-object wx:choice%
|
||||||
this do-dir '() -1 -1 -1 -1
|
this do-dir '() -1 -1 -1 -1
|
||||||
'("XXXXXXXXXXXXXXXXXXXXXXXXXXX"))]
|
'("XXXXXXXXXXXXXXXXXXXXXXXXXXX"))]
|
||||||
|
|
||||||
[name-list (begin
|
[name-list (begin
|
||||||
(new-line)
|
(new-line)
|
||||||
|
(make-object wx:list-box%
|
||||||
|
this do-name-list
|
||||||
|
() wx:const-single
|
||||||
|
-1 -1
|
||||||
|
(if multi-mode? (* 1/2 WIDTH) WIDTH) 300
|
||||||
|
() wx:const-needed-sb))]
|
||||||
|
|
||||||
|
[result-list
|
||||||
|
(if multi-mode?
|
||||||
(make-object wx:list-box%
|
(make-object wx:list-box%
|
||||||
this do-name-list
|
this do-result-list
|
||||||
() wx:const-single
|
()
|
||||||
-1 -1
|
(if (eq? wx:window-system 'motif)
|
||||||
(if multi-mode? (* 1/2 WIDTH) WIDTH) 300
|
wx:const-extended
|
||||||
() wx:const-needed-sb))]
|
wx:const-multiple)
|
||||||
|
-1 -1
|
||||||
|
(* 1/2 WIDTH) 300
|
||||||
|
() wx:const-needed-sb))])
|
||||||
|
(sequence
|
||||||
|
(new-line))
|
||||||
|
|
||||||
[result-list
|
(private
|
||||||
(if multi-mode?
|
[name-field
|
||||||
(make-object wx:list-box%
|
(if save-mode?
|
||||||
this do-result-list
|
(let ([v (make-object wx:text%
|
||||||
()
|
this do-name
|
||||||
(if (eq? wx:window-system 'motif)
|
"Name: " ""
|
||||||
wx:const-extended
|
-1 -1
|
||||||
wx:const-multiple)
|
400 -1
|
||||||
-1 -1
|
wx:const-process-enter)])
|
||||||
(* 1/2 WIDTH) 300
|
(if (string? start-name)
|
||||||
() wx:const-needed-sb))])
|
(send v set-value start-name))
|
||||||
(sequence
|
(new-line)
|
||||||
(new-line))
|
v))]
|
||||||
|
[into-dir-button
|
||||||
|
(if save-mode?
|
||||||
|
(make-object wx:button%
|
||||||
|
this do-into-dir "Open Directory"))]
|
||||||
|
[goto-button (make-object wx:button%
|
||||||
|
this do-goto "Go to Directory...")]
|
||||||
|
[add-button (if multi-mode?
|
||||||
|
(make-object wx:button%
|
||||||
|
this do-add
|
||||||
|
"Add"))]
|
||||||
|
[add-all-button (if multi-mode?
|
||||||
|
(make-object wx:button%
|
||||||
|
this do-add-all
|
||||||
|
"Add All"))]
|
||||||
|
[remove-button (if multi-mode?
|
||||||
|
(make-object wx:button%
|
||||||
|
this do-remove
|
||||||
|
"Remove"))])
|
||||||
|
(sequence
|
||||||
|
(if multi-mode?
|
||||||
|
(tab 40)
|
||||||
|
(tab 100)))
|
||||||
|
(private
|
||||||
|
[cancel-button (make-object wx:button%
|
||||||
|
this do-cancel
|
||||||
|
"Cancel")]
|
||||||
|
[ok-button
|
||||||
|
(let ([w (send cancel-button get-width)])
|
||||||
|
(make-object wx:button%
|
||||||
|
this do-ok
|
||||||
|
"OK" -1 -1 w))])
|
||||||
|
(sequence
|
||||||
|
(fit)
|
||||||
|
|
||||||
(private
|
(cond
|
||||||
[name-field
|
[(and start-dir
|
||||||
(if save-mode?
|
(not (null? start-dir))
|
||||||
(let ([v (make-object wx:text%
|
(directory-exists? start-dir))
|
||||||
this do-name
|
(set-directory (mzlib:file:normalize-path start-dir))]
|
||||||
"Name: " ""
|
[last-directory (set-directory last-directory)]
|
||||||
-1 -1
|
[else (set-directory (current-directory))])
|
||||||
400 -1
|
|
||||||
wx:const-process-enter)])
|
|
||||||
(if (string? start-name)
|
|
||||||
(send v set-value start-name))
|
|
||||||
(new-line)
|
|
||||||
v))]
|
|
||||||
[into-dir-button
|
|
||||||
(if save-mode?
|
|
||||||
(make-object wx:button%
|
|
||||||
this do-into-dir "Open Directory"))]
|
|
||||||
[goto-button (make-object wx:button%
|
|
||||||
this do-goto "Go to Directory...")]
|
|
||||||
[add-button (if multi-mode?
|
|
||||||
(make-object wx:button%
|
|
||||||
this do-add
|
|
||||||
"Add"))]
|
|
||||||
[add-all-button (if multi-mode?
|
|
||||||
(make-object wx:button%
|
|
||||||
this do-add-all
|
|
||||||
"Add All"))]
|
|
||||||
[remove-button (if multi-mode?
|
|
||||||
(make-object wx:button%
|
|
||||||
this do-remove
|
|
||||||
"Remove"))])
|
|
||||||
(sequence
|
|
||||||
(if multi-mode?
|
|
||||||
(tab 40)
|
|
||||||
(tab 100)))
|
|
||||||
(private
|
|
||||||
[cancel-button (make-object wx:button%
|
|
||||||
this do-cancel
|
|
||||||
"Cancel")]
|
|
||||||
[ok-button
|
|
||||||
(let ([w (send cancel-button get-width)])
|
|
||||||
(make-object wx:button%
|
|
||||||
this do-ok
|
|
||||||
"OK" -1 -1 w))])
|
|
||||||
(sequence
|
|
||||||
(fit)
|
|
||||||
|
|
||||||
(cond
|
(center wx:const-both)
|
||||||
[(and start-dir
|
|
||||||
(not (null? start-dir))
|
|
||||||
(directory-exists? start-dir))
|
|
||||||
(set-directory (mzlib:file^:normalize-path start-dir))]
|
|
||||||
[last-directory (set-directory last-directory)]
|
|
||||||
[else (set-directory (current-directory))])
|
|
||||||
|
|
||||||
(center wx:const-both)
|
(show #t))))
|
||||||
|
|
||||||
(show #t))))
|
(define common-put-file
|
||||||
|
(opt-lambda ([name ()][directory ()][replace? #f]
|
||||||
|
[prompt "Select File"][filter #f]
|
||||||
|
[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)
|
||||||
|
directory)]
|
||||||
|
[name (or (and (string? name)
|
||||||
|
(mzlib:file:file-name-from-path name))
|
||||||
|
name)]
|
||||||
|
[v (box #f)])
|
||||||
|
(make-object finder-dialog% #t replace? #f v
|
||||||
|
directory name prompt filter filter-msg)
|
||||||
|
(unbox v))))
|
||||||
|
|
||||||
(define common-put-file
|
(define common-get-file
|
||||||
(opt-lambda ([name ()][directory ()][replace? #f]
|
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
||||||
[prompt "Select File"][filter #f]
|
[filter-msg "Bad name"])
|
||||||
[filter-msg "That name does not have the right form"])
|
(let ([v (box #f)])
|
||||||
(let* ([directory (if (and (null? directory)
|
(make-object finder-dialog% #f #f #f v directory '() prompt
|
||||||
(string? name))
|
filter filter-msg)
|
||||||
(or (mzlib:file^:path-only name) null)
|
(unbox v))))
|
||||||
directory)]
|
|
||||||
[name (or (and (string? name)
|
|
||||||
(mzlib:file^:file-name-from-path name))
|
|
||||||
name)]
|
|
||||||
[v (box #f)])
|
|
||||||
(make-object finder-dialog% #t replace? #f v
|
|
||||||
directory name prompt filter filter-msg)
|
|
||||||
(unbox v))))
|
|
||||||
|
|
||||||
(define common-get-file
|
(define common-get-file-list
|
||||||
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
(opt-lambda ([directory ()][prompt "Select Files"][filter #f]
|
||||||
[filter-msg "Bad name"])
|
[filter-msg "Bad name"])
|
||||||
(let ([v (box #f)])
|
(let ([v (box ())])
|
||||||
(make-object finder-dialog% #f #f #f v directory '() prompt
|
(make-object finder-dialog% #f #f #t v directory '() prompt
|
||||||
filter filter-msg)
|
filter filter-msg)
|
||||||
(unbox v))))
|
(unbox v))))
|
||||||
|
|
||||||
(define common-get-file-list
|
(define std-put-file
|
||||||
(opt-lambda ([directory ()][prompt "Select Files"][filter #f]
|
(opt-lambda ([name ()][directory ()][replace? #f][prompt "Select File"]
|
||||||
[filter-msg "Bad name"])
|
[filter #f]
|
||||||
(let ([v (box ())])
|
[filter-msg
|
||||||
(make-object finder-dialog% #f #f #t v directory '() prompt
|
"That filename does not have the right form."])
|
||||||
filter filter-msg)
|
(let* ([directory (if (and (null? directory)
|
||||||
(unbox v))))
|
(string? name))
|
||||||
|
(or (mzlib:file:path-only name) null)
|
||||||
|
directory)]
|
||||||
|
[name (or (and (string? name)
|
||||||
|
(mzlib:file:file-name-from-path name))
|
||||||
|
name)]
|
||||||
|
[f (wx:file-selector prompt directory name
|
||||||
|
'()
|
||||||
|
(if (eq? wx:platform 'windows)
|
||||||
|
"*.*"
|
||||||
|
"*")
|
||||||
|
wx:const-save)])
|
||||||
|
(if (or (null? f) (and filter (not (filter-match? filter
|
||||||
|
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)])
|
||||||
|
(cond
|
||||||
|
[(not (and (string? dir) (directory-exists? dir)))
|
||||||
|
(wx:message-box "Error" "That directory does not exist.")
|
||||||
|
#f]
|
||||||
|
[(or (not name) (equal? name ""))
|
||||||
|
(wx:message-box "Error" "Empty filename.")
|
||||||
|
#f]
|
||||||
|
[else f]))))))
|
||||||
|
|
||||||
(define std-put-file
|
(define std-get-file
|
||||||
(opt-lambda ([name ()][directory ()][replace? #f][prompt "Select File"]
|
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
||||||
[filter #f]
|
[filter-msg
|
||||||
[filter-msg
|
"That filename does not have the right form."])
|
||||||
"That filename does not have the right form."])
|
(let ([f (wx:file-selector prompt directory)])
|
||||||
(let* ([directory (if (and (null? directory)
|
(if (null? f)
|
||||||
(string? name))
|
#f
|
||||||
(or (mzlib:file^:path-only name) null)
|
(if (or (not filter) (filter-match? filter f filter-msg))
|
||||||
directory)]
|
(let ([f (mzlib:file:normalize-path f)])
|
||||||
[name (or (and (string? name)
|
(cond
|
||||||
(mzlib:file^:file-name-from-path name))
|
[(directory-exists? f)
|
||||||
name)]
|
(wx:message-box "Error"
|
||||||
[f (wx:file-selector prompt directory name
|
"That is a directory name.")
|
||||||
'()
|
#f]
|
||||||
(if (eq? wx:platform 'windows)
|
[(not (file-exists? f))
|
||||||
"*.*"
|
(wx:message-box "That file does not exist.")
|
||||||
"*")
|
#f]
|
||||||
wx:const-save)])
|
[else f]))
|
||||||
(if (or (null? f) (and filter (not (filter-match? filter
|
#f)))))
|
||||||
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)])
|
|
||||||
(cond
|
|
||||||
[(not (and (string? dir) (directory-exists? dir)))
|
|
||||||
(wx:message-box "Error" "That directory does not exist.")
|
|
||||||
#f]
|
|
||||||
[(or (not name) (equal? name ""))
|
|
||||||
(wx:message-box "Error" "Empty filename.")
|
|
||||||
#f]
|
|
||||||
[else f]))))))
|
|
||||||
|
|
||||||
(define std-get-file
|
; By default, use platform-specific get/put
|
||||||
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
(define put-file std-put-file)
|
||||||
[filter-msg
|
(define get-file std-get-file)))
|
||||||
"That filename does not have the right form."])
|
|
||||||
(let ([f (wx:file-selector prompt directory)])
|
|
||||||
(if (null? f)
|
|
||||||
#f
|
|
||||||
(if (or (not filter) (filter-match? filter f filter-msg))
|
|
||||||
(let ([f (mzlib:file^:normalize-path f)])
|
|
||||||
(cond
|
|
||||||
[(directory-exists? f)
|
|
||||||
(wx:message-box "Error"
|
|
||||||
"That is a directory name.")
|
|
||||||
#f]
|
|
||||||
[(not (file-exists? f))
|
|
||||||
(wx:message-box "That file does not exist.")
|
|
||||||
#f]
|
|
||||||
[else f]))
|
|
||||||
#f)))))
|
|
||||||
|
|
||||||
; By default, use platform-specific get/put
|
|
||||||
(define put-file std-put-file)
|
|
||||||
(define get-file std-get-file))
|
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user