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^)
|
||||
(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))
|
||||
(define-struct range (start end pen brush))
|
||||
(define-struct rectangle (left top width height pen brush))
|
||||
|
||||
(define make-std-buffer%
|
||||
(lambda (buffer%)
|
||||
(class buffer% args
|
||||
(inherit modified? get-filename save-file set-max-width)
|
||||
(rename
|
||||
[super-set-filename set-filename]
|
||||
[super-set-modified set-modified]
|
||||
[super-on-change on-change]
|
||||
[super-on-save-file on-save-file])
|
||||
(private
|
||||
[auto-saved-name #f]
|
||||
[auto-save-out-of-date? #t]
|
||||
[auto-save-error? #f])
|
||||
(public
|
||||
[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)])
|
||||
(if v
|
||||
v
|
||||
'())))]
|
||||
|
||||
[auto-set-wrap? #f]
|
||||
[set-auto-set-wrap
|
||||
(lambda (v)
|
||||
(set! auto-set-wrap? v)
|
||||
(if (not v)
|
||||
(set-max-width -1)))]
|
||||
|
||||
[active-canvas #f]
|
||||
[set-active-canvas
|
||||
(lambda (c)
|
||||
(set! active-canvas c))]
|
||||
|
||||
[canvases '()]
|
||||
[add-canvas
|
||||
(lambda (canvas)
|
||||
(set! canvases (cons canvas canvases)))]
|
||||
[remove-canvas
|
||||
(lambda (canvas)
|
||||
(set! canvases (mzlib:function^:remove canvas canvases)))]
|
||||
|
||||
[mode #f]
|
||||
[set-mode
|
||||
(lambda (m)
|
||||
#f)]
|
||||
|
||||
[set-modified
|
||||
(lambda (modified?)
|
||||
(if auto-saved-name
|
||||
(if (not modified?)
|
||||
(begin
|
||||
(delete-file auto-saved-name)
|
||||
(set! auto-saved-name #f))
|
||||
(set! auto-save-out-of-date? #t)))
|
||||
(super-set-modified modified?)
|
||||
(for-each (lambda (canvas) (send canvas edit-modified modified?))
|
||||
canvases))]
|
||||
[set-filename
|
||||
(opt-lambda (name [temp? #f])
|
||||
(super-set-filename name temp?)
|
||||
(for-each (lambda (canvas) (send canvas edit-renamed name))
|
||||
canvases))]
|
||||
|
||||
[on-change
|
||||
(lambda ()
|
||||
(super-on-change)
|
||||
(set! auto-save-out-of-date? #t))]
|
||||
[auto-save? #t]
|
||||
[do-autosave
|
||||
(lambda ()
|
||||
(when (and auto-save?
|
||||
(not auto-save-error?)
|
||||
(modified?)
|
||||
(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)]
|
||||
[success (save-file auto-name wx:const-media-ff-copy)])
|
||||
(if success
|
||||
(begin
|
||||
(if auto-saved-name
|
||||
(delete-file auto-saved-name))
|
||||
(set! auto-saved-name auto-name)
|
||||
(set! auto-save-out-of-date? #f))
|
||||
(begin
|
||||
(wx:message-box
|
||||
(format "Error autosaving ~s.~n~a~n~a"
|
||||
(if (null? orig-name) "Untitled" orig-name)
|
||||
"Autosaving is turned off"
|
||||
"until the file is saved.")
|
||||
"Warning")
|
||||
(set! auto-save-error? #t))))))]
|
||||
[remove-autosave
|
||||
(lambda ()
|
||||
(when auto-saved-name
|
||||
(delete-file auto-saved-name)
|
||||
(set! auto-saved-name #f)))]
|
||||
|
||||
[backup? #t]
|
||||
[on-save-file
|
||||
(lambda (name format)
|
||||
(set! auto-save-error? #f)
|
||||
(if (super-on-save-file name format)
|
||||
(begin
|
||||
(if (and backup?
|
||||
(not (= format wx:const-media-ff-copy)))
|
||||
(if (file-exists? name)
|
||||
(let ([back-name (mred:path-utils^:generate-backup-name name)])
|
||||
(unless (file-exists? back-name)
|
||||
(rename-file name back-name)))))
|
||||
#t)
|
||||
#f))]
|
||||
|
||||
[get-canvas
|
||||
(lambda ()
|
||||
(cond
|
||||
[(and active-canvas
|
||||
(member active-canvas canvases))
|
||||
active-canvas]
|
||||
[(null? canvases) #f]
|
||||
[else (car canvases)]))]
|
||||
[get-frame
|
||||
(lambda ()
|
||||
(let ([c (get-canvas)])
|
||||
(if c
|
||||
(let ([f (send c get-parent)])
|
||||
(if (null? f)
|
||||
#f
|
||||
f))
|
||||
#f)))])
|
||||
(sequence
|
||||
(apply super-init args)))))
|
||||
(define make-std-buffer%
|
||||
(lambda (buffer%)
|
||||
(class buffer% args
|
||||
(inherit modified? get-filename save-file set-max-width)
|
||||
(rename
|
||||
[super-set-filename set-filename]
|
||||
[super-set-modified set-modified]
|
||||
[super-on-change on-change]
|
||||
[super-on-save-file on-save-file])
|
||||
(private
|
||||
[auto-saved-name #f]
|
||||
[auto-save-out-of-date? #t]
|
||||
[auto-save-error? #f])
|
||||
(public
|
||||
[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)])
|
||||
(if v
|
||||
v
|
||||
'())))]
|
||||
|
||||
[auto-set-wrap? #f]
|
||||
[set-auto-set-wrap
|
||||
(lambda (v)
|
||||
(set! auto-set-wrap? v)
|
||||
(if (not v)
|
||||
(set-max-width -1)))]
|
||||
|
||||
[active-canvas #f]
|
||||
[set-active-canvas
|
||||
(lambda (c)
|
||||
(set! active-canvas c))]
|
||||
|
||||
[canvases '()]
|
||||
[add-canvas
|
||||
(lambda (canvas)
|
||||
(set! canvases (cons canvas canvases)))]
|
||||
[remove-canvas
|
||||
(lambda (canvas)
|
||||
(set! canvases (mzlib:function:remove canvas canvases)))]
|
||||
|
||||
[mode #f]
|
||||
[set-mode
|
||||
(lambda (m)
|
||||
#f)]
|
||||
|
||||
[set-modified
|
||||
(lambda (modified?)
|
||||
(if auto-saved-name
|
||||
(if (not modified?)
|
||||
(begin
|
||||
(delete-file auto-saved-name)
|
||||
(set! auto-saved-name #f))
|
||||
(set! auto-save-out-of-date? #t)))
|
||||
(super-set-modified modified?)
|
||||
(for-each (lambda (canvas) (send canvas edit-modified modified?))
|
||||
canvases))]
|
||||
[set-filename
|
||||
(opt-lambda (name [temp? #f])
|
||||
(super-set-filename name temp?)
|
||||
(for-each (lambda (canvas) (send canvas edit-renamed name))
|
||||
canvases))]
|
||||
|
||||
[on-change
|
||||
(lambda ()
|
||||
(super-on-change)
|
||||
(set! auto-save-out-of-date? #t))]
|
||||
[auto-save? #t]
|
||||
[do-autosave
|
||||
(lambda ()
|
||||
(when (and auto-save?
|
||||
(not auto-save-error?)
|
||||
(modified?)
|
||||
(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)]
|
||||
[success (save-file auto-name wx:const-media-ff-copy)])
|
||||
(if success
|
||||
(begin
|
||||
(if auto-saved-name
|
||||
(delete-file auto-saved-name))
|
||||
(set! auto-saved-name auto-name)
|
||||
(set! auto-save-out-of-date? #f))
|
||||
(begin
|
||||
(wx:message-box
|
||||
(format "Error autosaving ~s.~n~a~n~a"
|
||||
(if (null? orig-name) "Untitled" orig-name)
|
||||
"Autosaving is turned off"
|
||||
"until the file is saved.")
|
||||
"Warning")
|
||||
(set! auto-save-error? #t))))))]
|
||||
[remove-autosave
|
||||
(lambda ()
|
||||
(when auto-saved-name
|
||||
(delete-file auto-saved-name)
|
||||
(set! auto-saved-name #f)))]
|
||||
|
||||
[backup? #t]
|
||||
[on-save-file
|
||||
(lambda (name format)
|
||||
(set! auto-save-error? #f)
|
||||
(if (super-on-save-file name format)
|
||||
(begin
|
||||
(if (and backup?
|
||||
(not (= format wx:const-media-ff-copy)))
|
||||
(if (file-exists? name)
|
||||
(let ([back-name (mred:path-utils:generate-backup-name name)])
|
||||
(unless (file-exists? back-name)
|
||||
(rename-file name back-name)))))
|
||||
#t)
|
||||
#f))]
|
||||
|
||||
[get-canvas
|
||||
(lambda ()
|
||||
(cond
|
||||
[(and active-canvas
|
||||
(member active-canvas canvases))
|
||||
active-canvas]
|
||||
[(null? canvases) #f]
|
||||
[else (car canvases)]))]
|
||||
[get-frame
|
||||
(lambda ()
|
||||
(let ([c (get-canvas)])
|
||||
(if c
|
||||
(let ([f (send c get-parent)])
|
||||
(if (null? f)
|
||||
#f
|
||||
f))
|
||||
#f)))])
|
||||
(sequence
|
||||
(apply super-init args)))))
|
||||
|
||||
(define edits%
|
||||
(class-asi wx:snip%
|
||||
(private
|
||||
[edits null])
|
||||
(public
|
||||
[add
|
||||
(lambda (edit)
|
||||
(unless (let loop ([e edits])
|
||||
(cond
|
||||
[(null? e) #f]
|
||||
[else (if (eq? this (car e))
|
||||
#t
|
||||
(loop (cdr e)))]))
|
||||
(set! edits (cons edit edits))))])))
|
||||
(define edits%
|
||||
(class-asi wx:snip%
|
||||
(private
|
||||
[edits null])
|
||||
(public
|
||||
[add
|
||||
(lambda (edit)
|
||||
(unless (let loop ([e edits])
|
||||
(cond
|
||||
[(null? e) #f]
|
||||
[else (if (eq? this (car e))
|
||||
#t
|
||||
(loop (cdr e)))]))
|
||||
(set! edits (cons edit edits))))])))
|
||||
|
||||
(define edits (make-object edits%))
|
||||
(define edits (make-object edits%))
|
||||
|
||||
(define make-edit%
|
||||
(lambda (super%)
|
||||
(class (make-std-buffer% super%) args
|
||||
(inherit mode canvases
|
||||
invalidate-bitmap-cache
|
||||
begin-edit-sequence end-edit-sequence
|
||||
flash-on get-keymap get-start-position
|
||||
on-default-char on-default-event
|
||||
set-file-format get-style-list)
|
||||
(rename [super-on-focus on-focus]
|
||||
[super-on-paint on-paint]
|
||||
[super-on-local-event on-local-event]
|
||||
[super-on-local-char on-local-char]
|
||||
(define make-edit%
|
||||
(lambda (super%)
|
||||
(class (make-std-buffer% super%) args
|
||||
(inherit mode canvases
|
||||
invalidate-bitmap-cache
|
||||
begin-edit-sequence end-edit-sequence
|
||||
flash-on get-keymap get-start-position
|
||||
on-default-char on-default-event
|
||||
set-file-format get-style-list)
|
||||
(rename [super-on-focus on-focus]
|
||||
[super-on-paint on-paint]
|
||||
[super-on-local-event on-local-event]
|
||||
[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-change-style on-change-style]
|
||||
[super-on-insert on-insert]
|
||||
[super-on-delete on-delete]
|
||||
[super-on-set-size-constraint on-set-size-constraint]
|
||||
[super-on-edit-sequence on-edit-sequence]
|
||||
[super-on-change-style on-change-style]
|
||||
[super-on-insert on-insert]
|
||||
[super-on-delete on-delete]
|
||||
[super-on-set-size-constraint on-set-size-constraint]
|
||||
|
||||
[super-after-edit-sequence after-edit-sequence]
|
||||
[super-after-change-style after-change-style]
|
||||
[super-after-insert after-insert]
|
||||
[super-after-delete after-delete]
|
||||
[super-after-set-size-constraint after-set-size-constraint])
|
||||
(public
|
||||
[set-mode
|
||||
(lambda (m)
|
||||
(if mode
|
||||
(send mode deinstall this))
|
||||
(if (is-a? m mred:mode^:mode%)
|
||||
(begin
|
||||
(set! mode m)
|
||||
(set-file-format (ivar m file-format))
|
||||
(send (send (get-style-list)
|
||||
find-named-style "Standard")
|
||||
set-delta (ivar m standard-style-delta))
|
||||
(send m install this))
|
||||
(begin
|
||||
(set! mode #f)
|
||||
(send (send (get-style-list)
|
||||
find-named-style "Standard")
|
||||
set-delta (make-object wx:style-delta%)))))]
|
||||
[on-focus
|
||||
(lambda (on?)
|
||||
(super-on-focus on?)
|
||||
(when mode
|
||||
(send mode on-focus this on?)))]
|
||||
[on-local-event
|
||||
(lambda (mouse)
|
||||
(if (or (not mode)
|
||||
(not (send mode on-event this mouse)))
|
||||
(super-on-local-event mouse)))]
|
||||
[on-insert
|
||||
(lambda (start len)
|
||||
(if (or (not mode) (send mode on-insert this start len))
|
||||
(super-on-insert start len)))]
|
||||
[on-delete
|
||||
(lambda (start len)
|
||||
(if (or (not mode) (send mode on-delete this start len))
|
||||
(super-on-delete start len)))]
|
||||
[on-change-style
|
||||
(lambda (start len)
|
||||
(if (or (not mode) (send mode on-change-style this start len))
|
||||
(super-on-change-style start len)))]
|
||||
[on-edit-sequence
|
||||
(lambda ()
|
||||
(when mode
|
||||
(send mode on-edit-sequence this))
|
||||
(super-on-edit-sequence))]
|
||||
[on-set-size-constraint
|
||||
(lambda ()
|
||||
(if (or (not mode) (send mode on-set-size-constraint this))
|
||||
(super-on-set-size-constraint)))]
|
||||
|
||||
[after-insert
|
||||
(lambda (start len)
|
||||
(if mode (send mode after-insert this start len))
|
||||
(super-after-insert start len))]
|
||||
[after-delete
|
||||
(lambda (start len)
|
||||
(if mode (send mode after-delete this start len))
|
||||
(super-after-delete start len))]
|
||||
[after-change-style
|
||||
(lambda (start len)
|
||||
(when mode (send mode after-change-style this start len))
|
||||
(super-after-change-style start len))]
|
||||
[after-edit-sequence
|
||||
(lambda ()
|
||||
(when mode
|
||||
(send mode after-edit-sequence this))
|
||||
(super-after-edit-sequence))]
|
||||
[after-set-size-constraint
|
||||
(lambda ()
|
||||
(when mode
|
||||
(send mode after-set-size-constraint this))
|
||||
(super-after-set-size-constraint))]
|
||||
|
||||
[after-set-position
|
||||
(lambda ()
|
||||
(when mode
|
||||
(send mode after-set-position this))
|
||||
(super-after-set-position))]
|
||||
[super-after-edit-sequence after-edit-sequence]
|
||||
[super-after-change-style after-change-style]
|
||||
[super-after-insert after-insert]
|
||||
[super-after-delete after-delete]
|
||||
[super-after-set-size-constraint after-set-size-constraint])
|
||||
(public
|
||||
[set-mode
|
||||
(lambda (m)
|
||||
(if mode
|
||||
(send mode deinstall this))
|
||||
(if (is-a? m mred:mode:mode%)
|
||||
(begin
|
||||
(set! mode m)
|
||||
(set-file-format (ivar m file-format))
|
||||
(send (send (get-style-list)
|
||||
find-named-style "Standard")
|
||||
set-delta (ivar m standard-style-delta))
|
||||
(send m install this))
|
||||
(begin
|
||||
(set! mode #f)
|
||||
(send (send (get-style-list)
|
||||
find-named-style "Standard")
|
||||
set-delta (make-object wx:style-delta%)))))]
|
||||
[on-focus
|
||||
(lambda (on?)
|
||||
(super-on-focus on?)
|
||||
(when mode
|
||||
(send mode on-focus this on?)))]
|
||||
[on-local-event
|
||||
(lambda (mouse)
|
||||
(if (or (not mode)
|
||||
(not (send mode on-event this mouse)))
|
||||
(super-on-local-event mouse)))]
|
||||
[on-insert
|
||||
(lambda (start len)
|
||||
(if (or (not mode) (send mode on-insert this start len))
|
||||
(super-on-insert start len)))]
|
||||
[on-delete
|
||||
(lambda (start len)
|
||||
(if (or (not mode) (send mode on-delete this start len))
|
||||
(super-on-delete start len)))]
|
||||
[on-change-style
|
||||
(lambda (start len)
|
||||
(if (or (not mode) (send mode on-change-style this start len))
|
||||
(super-on-change-style start len)))]
|
||||
[on-edit-sequence
|
||||
(lambda ()
|
||||
(when mode
|
||||
(send mode on-edit-sequence this))
|
||||
(super-on-edit-sequence))]
|
||||
[on-set-size-constraint
|
||||
(lambda ()
|
||||
(if (or (not mode) (send mode on-set-size-constraint this))
|
||||
(super-on-set-size-constraint)))]
|
||||
|
||||
[after-insert
|
||||
(lambda (start len)
|
||||
(if mode (send mode after-insert this start len))
|
||||
(super-after-insert start len))]
|
||||
[after-delete
|
||||
(lambda (start len)
|
||||
(if mode (send mode after-delete this start len))
|
||||
(super-after-delete start len))]
|
||||
[after-change-style
|
||||
(lambda (start len)
|
||||
(when mode (send mode after-change-style this start len))
|
||||
(super-after-change-style start len))]
|
||||
[after-edit-sequence
|
||||
(lambda ()
|
||||
(when mode
|
||||
(send mode after-edit-sequence this))
|
||||
(super-after-edit-sequence))]
|
||||
[after-set-size-constraint
|
||||
(lambda ()
|
||||
(when mode
|
||||
(send mode after-set-size-constraint this))
|
||||
(super-after-set-size-constraint))]
|
||||
|
||||
[after-set-position
|
||||
(lambda ()
|
||||
(when mode
|
||||
(send mode after-set-position this))
|
||||
(super-after-set-position))]
|
||||
|
||||
[ranges null]
|
||||
[add-range
|
||||
(lambda (start end pen brush)
|
||||
(let ([l (make-range start end pen brush)])
|
||||
(set! ranges (cons l ranges))
|
||||
(recompute-range-rectangles)
|
||||
(lambda () (set! ranges
|
||||
(let loop ([r ranges])
|
||||
(cond
|
||||
[(null? r) r]
|
||||
[else (if (eq? (car r) l)
|
||||
(cdr r)
|
||||
(cons (car r) (loop (cdr r))))])))
|
||||
(recompute-range-rectangles))))]
|
||||
[range-rectangles null]
|
||||
[recompute-range-rectangles
|
||||
(lambda ()
|
||||
(let ([new-rectangles
|
||||
(lambda (range)
|
||||
(let ([start (range-start range)]
|
||||
[end (range-end range)]
|
||||
[pen (range-pen range)]
|
||||
[brush (range-brush range)]
|
||||
[buffer-width (box 0)]
|
||||
[start-x (box 0)]
|
||||
[top-start-y (box 0)]
|
||||
[bottom-start-y (box 0)]
|
||||
[end-x (box 0)]
|
||||
[top-end-y (box 0)]
|
||||
[bottom-end-y (box 0)])
|
||||
(send this get-extent buffer-width null)
|
||||
(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 start start-x bottom-start-y #f #f #t)
|
||||
(send this position-location end end-x bottom-end-y #f #t #t)
|
||||
(cond
|
||||
[(= (unbox top-start-y) (unbox top-end-y))
|
||||
(list (make-rectangle (unbox start-x)
|
||||
(unbox top-start-y)
|
||||
(- (unbox end-x) (unbox start-x))
|
||||
(- (unbox bottom-start-y) (unbox top-start-y))
|
||||
pen brush))]
|
||||
[else
|
||||
(list
|
||||
(make-rectangle (unbox start-x)
|
||||
(unbox top-start-y)
|
||||
(- (unbox buffer-width) (unbox start-x))
|
||||
(- (unbox bottom-start-y) (unbox top-start-y))
|
||||
pen brush)
|
||||
(make-rectangle 0
|
||||
(unbox bottom-start-y)
|
||||
(unbox buffer-width)
|
||||
(- (unbox top-end-y) (unbox bottom-start-y))
|
||||
pen brush)
|
||||
(make-rectangle 0
|
||||
(unbox top-end-y)
|
||||
(unbox end-x)
|
||||
(- (unbox bottom-end-y) (unbox top-end-y))
|
||||
pen brush))])))]
|
||||
[invalidate-rectangle
|
||||
(lambda (r)
|
||||
(invalidate-bitmap-cache (rectangle-left r)
|
||||
(rectangle-top r)
|
||||
(rectangle-width r)
|
||||
(rectangle-height r)))]
|
||||
[old-rectangles range-rectangles])
|
||||
[ranges null]
|
||||
[add-range
|
||||
(lambda (start end pen brush)
|
||||
(let ([l (make-range start end pen brush)])
|
||||
(set! ranges (cons l ranges))
|
||||
(recompute-range-rectangles)
|
||||
(lambda () (set! ranges
|
||||
(let loop ([r ranges])
|
||||
(cond
|
||||
[(null? r) r]
|
||||
[else (if (eq? (car r) l)
|
||||
(cdr r)
|
||||
(cons (car r) (loop (cdr r))))])))
|
||||
(recompute-range-rectangles))))]
|
||||
[range-rectangles null]
|
||||
[recompute-range-rectangles
|
||||
(lambda ()
|
||||
(let ([new-rectangles
|
||||
(lambda (range)
|
||||
(let ([start (range-start range)]
|
||||
[end (range-end range)]
|
||||
[pen (range-pen range)]
|
||||
[brush (range-brush range)]
|
||||
[buffer-width (box 0)]
|
||||
[start-x (box 0)]
|
||||
[top-start-y (box 0)]
|
||||
[bottom-start-y (box 0)]
|
||||
[end-x (box 0)]
|
||||
[top-end-y (box 0)]
|
||||
[bottom-end-y (box 0)])
|
||||
(send this get-extent buffer-width null)
|
||||
(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 start start-x bottom-start-y #f #f #t)
|
||||
(send this position-location end end-x bottom-end-y #f #t #t)
|
||||
(cond
|
||||
[(= (unbox top-start-y) (unbox top-end-y))
|
||||
(list (make-rectangle (unbox start-x)
|
||||
(unbox top-start-y)
|
||||
(- (unbox end-x) (unbox start-x))
|
||||
(- (unbox bottom-start-y) (unbox top-start-y))
|
||||
pen brush))]
|
||||
[else
|
||||
(list
|
||||
(make-rectangle (unbox start-x)
|
||||
(unbox top-start-y)
|
||||
(- (unbox buffer-width) (unbox start-x))
|
||||
(- (unbox bottom-start-y) (unbox top-start-y))
|
||||
pen brush)
|
||||
(make-rectangle 0
|
||||
(unbox bottom-start-y)
|
||||
(unbox buffer-width)
|
||||
(- (unbox top-end-y) (unbox bottom-start-y))
|
||||
pen brush)
|
||||
(make-rectangle 0
|
||||
(unbox top-end-y)
|
||||
(unbox end-x)
|
||||
(- (unbox bottom-end-y) (unbox top-end-y))
|
||||
pen brush))])))]
|
||||
[invalidate-rectangle
|
||||
(lambda (r)
|
||||
(invalidate-bitmap-cache (rectangle-left r)
|
||||
(rectangle-top r)
|
||||
(rectangle-width r)
|
||||
(rectangle-height r)))]
|
||||
[old-rectangles range-rectangles])
|
||||
|
||||
(set! range-rectangles
|
||||
(mzlib:function^:foldl (lambda (x l) (append (new-rectangles x) l))
|
||||
null ranges))
|
||||
(begin-edit-sequence)
|
||||
(for-each invalidate-rectangle old-rectangles)
|
||||
(for-each invalidate-rectangle range-rectangles)
|
||||
(end-edit-sequence)))]
|
||||
[on-paint
|
||||
(lambda (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
|
||||
(for-each (lambda (rectangle)
|
||||
(let ([pen (rectangle-pen rectangle)]
|
||||
[brush (rectangle-brush rectangle)]
|
||||
[old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)]
|
||||
[left (rectangle-left rectangle)]
|
||||
[top (rectangle-top rectangle)]
|
||||
[width (rectangle-width rectangle)]
|
||||
[height (rectangle-height rectangle)])
|
||||
(send dc set-pen pen)
|
||||
(send dc set-brush brush)
|
||||
(unless (or (zero? width)
|
||||
(zero? height))
|
||||
(send dc draw-rectangle (+ left dx) (+ top dy) width height))
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)))
|
||||
range-rectangles)))])
|
||||
(sequence
|
||||
(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))))))
|
||||
(set! range-rectangles
|
||||
(mzlib:function:foldl (lambda (x l) (append (new-rectangles x) l))
|
||||
null ranges))
|
||||
(begin-edit-sequence)
|
||||
(for-each invalidate-rectangle old-rectangles)
|
||||
(for-each invalidate-rectangle range-rectangles)
|
||||
(end-edit-sequence)))]
|
||||
[on-paint
|
||||
(lambda (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
|
||||
(for-each (lambda (rectangle)
|
||||
(let ([pen (rectangle-pen rectangle)]
|
||||
[brush (rectangle-brush rectangle)]
|
||||
[old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)]
|
||||
[left (rectangle-left rectangle)]
|
||||
[top (rectangle-top rectangle)]
|
||||
[width (rectangle-width rectangle)]
|
||||
[height (rectangle-height rectangle)])
|
||||
(send dc set-pen pen)
|
||||
(send dc set-brush brush)
|
||||
(unless (or (zero? width)
|
||||
(zero? height))
|
||||
(send dc draw-rectangle (+ left dx) (+ top dy) width height))
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)))
|
||||
range-rectangles)))])
|
||||
(sequence
|
||||
(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))))))
|
||||
|
||||
(define edit% (make-edit% wx:media-edit%))
|
||||
(define edit% (make-edit% wx:media-edit%))
|
||||
|
||||
(define make-pasteboard% make-std-buffer%)
|
||||
(define pasteboard% (make-pasteboard% wx:media-pasteboard%)))
|
||||
(define make-pasteboard% make-std-buffer%)
|
||||
(define pasteboard% (make-pasteboard% wx:media-pasteboard%))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,37 +1,35 @@
|
|||
;; [Robby]
|
||||
;; exit doesn't actually exit, now.
|
||||
(define mred:exit@
|
||||
(unit/s mred:exit^
|
||||
(import [mred:debug mred:debug^])
|
||||
(rename (-exit exit))
|
||||
|
||||
(define-sigfunctor (mred:exit@ mred:exit^)
|
||||
(import mred:debug^)
|
||||
(rename (-exit exit))
|
||||
(define exit-callbacks '())
|
||||
|
||||
(define insert-exit-callback
|
||||
(lambda (f)
|
||||
(set! exit-callbacks (cons f exit-callbacks))
|
||||
f))
|
||||
|
||||
(define exit-callbacks '())
|
||||
|
||||
(define insert-exit-callback
|
||||
(lambda (f)
|
||||
(set! exit-callbacks (cons f exit-callbacks))
|
||||
f))
|
||||
(define remove-exit-callback
|
||||
(lambda (cb)
|
||||
(set! exit-callbacks
|
||||
(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
|
||||
(lambda (cb)
|
||||
(set! exit-callbacks
|
||||
(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 -exit
|
||||
(lambda ()
|
||||
(set! exit-callbacks
|
||||
(let loop ([cb-list exit-callbacks])
|
||||
(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))))
|
||||
(define -exit
|
||||
(lambda ()
|
||||
(set! exit-callbacks
|
||||
(let loop ([cb-list exit-callbacks])
|
||||
(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^)
|
||||
(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)
|
||||
#t
|
||||
(begin
|
||||
(wx:message-box msg "Error")
|
||||
#f)))))
|
||||
|
||||
(define last-directory #f)
|
||||
|
||||
(define make-relative
|
||||
(lambda (s) s))
|
||||
|
||||
(define current-find-file-directory
|
||||
(opt-lambda ([dir 'get])
|
||||
(cond
|
||||
[(eq? dir 'get)
|
||||
(if (not last-directory)
|
||||
(set! last-directory (current-directory)))
|
||||
last-directory]
|
||||
[(and (string? dir)
|
||||
(directory-exists? dir))
|
||||
(set! last-directory dir)
|
||||
#t]
|
||||
[else #f])))
|
||||
(define filter-match?
|
||||
(lambda (filter name msg)
|
||||
(let-values ([(base name dir?) (split-path name)])
|
||||
(if (mzlib:string:regexp-match-exact? filter name)
|
||||
#t
|
||||
(begin
|
||||
(wx:message-box msg "Error")
|
||||
#f)))))
|
||||
|
||||
(define last-directory #f)
|
||||
|
||||
(define make-relative
|
||||
(lambda (s) s))
|
||||
|
||||
(define current-find-file-directory
|
||||
(opt-lambda ([dir 'get])
|
||||
(cond
|
||||
[(eq? dir 'get)
|
||||
(if (not last-directory)
|
||||
(set! last-directory (current-directory)))
|
||||
last-directory]
|
||||
[(and (string? dir)
|
||||
(directory-exists? dir))
|
||||
(set! last-directory dir)
|
||||
#t]
|
||||
[else #f])))
|
||||
|
||||
(define finder-dialog%
|
||||
(class wx:dialog-box% (save-mode? replace-ok? multi-mode?
|
||||
result-box start-dir
|
||||
start-name prompt
|
||||
file-filter file-filter-msg)
|
||||
(inherit
|
||||
new-line tab fit center
|
||||
show
|
||||
popup-menu)
|
||||
|
||||
(private
|
||||
[WIDTH 500]
|
||||
[HEIGHT 500]
|
||||
(define finder-dialog%
|
||||
(class wx:dialog-box% (save-mode? replace-ok? multi-mode?
|
||||
result-box start-dir
|
||||
start-name prompt
|
||||
file-filter file-filter-msg)
|
||||
(inherit
|
||||
new-line tab fit center
|
||||
show
|
||||
popup-menu)
|
||||
|
||||
(private
|
||||
[WIDTH 500]
|
||||
[HEIGHT 500]
|
||||
|
||||
dirs current-dir
|
||||
last-selected
|
||||
|
||||
[select-counter 0])
|
||||
|
||||
(private
|
||||
[set-directory
|
||||
(lambda (dir) ; dir is normalied
|
||||
(set! current-dir dir)
|
||||
(set! last-directory dir)
|
||||
(let-values
|
||||
([(dir-list menu-list)
|
||||
(let loop ([this-dir dir]
|
||||
[dir-list ()]
|
||||
[menu-list ()])
|
||||
(let-values ([(base-dir in-dir dir?) (split-path this-dir)])
|
||||
(if (eq? wx:platform 'windows)
|
||||
(mzlib:string^:string-lowercase! in-dir))
|
||||
(let* ([dir-list (cons this-dir dir-list)]
|
||||
[menu-list (cons in-dir menu-list)])
|
||||
(if base-dir
|
||||
(loop base-dir dir-list menu-list)
|
||||
; No more
|
||||
(values dir-list menu-list)))))])
|
||||
(set! dirs dir-list)
|
||||
|
||||
(send dir-choice clear)
|
||||
(let loop ([choices menu-list])
|
||||
(unless (null? choices)
|
||||
(send dir-choice append (car choices))
|
||||
(loop (cdr choices))))
|
||||
(send dir-choice set-selection (sub1 (length dirs)))
|
||||
(send dir-choice set-size -1 -1 -1 -1))
|
||||
|
||||
(send name-list clear)
|
||||
(send name-list set
|
||||
(mzlib:function^:quicksort
|
||||
(let loop ([l (directory-list dir)])
|
||||
(if (null? l)
|
||||
'()
|
||||
(let ([s (car l)]
|
||||
[rest (loop (cdr l))])
|
||||
(if (directory-exists? (build-path dir s))
|
||||
(cons
|
||||
(string-append s
|
||||
(case wx:platform
|
||||
(unix "/")
|
||||
(windows "\\")
|
||||
(macintosh ":")))
|
||||
rest)
|
||||
(if (or (not file-filter)
|
||||
(mzlib:string^:regexp-match-exact? file-filter s))
|
||||
(cons s rest)
|
||||
rest)))))
|
||||
(if (eq? wx:platform 'unix) string<? string-ci<?)))
|
||||
(set! last-selected -1))])
|
||||
|
||||
(public
|
||||
[do-dir
|
||||
(lambda (choice event)
|
||||
(let ([which (send event get-selection)])
|
||||
(if (< which (length dirs))
|
||||
(set-directory (list-ref dirs which)))))]
|
||||
|
||||
[do-goto
|
||||
(opt-lambda (button event [default ""])
|
||||
(let ([orig-dir (wx:get-text-from-user
|
||||
"Directory" "Go to Directory"
|
||||
default)])
|
||||
(if (string? orig-dir)
|
||||
(let ([dir (mzlib:file^:normalize-path orig-dir current-dir)])
|
||||
(if (directory-exists? dir)
|
||||
(set-directory dir)
|
||||
(begin
|
||||
(wx:message-box
|
||||
(string-append "Bad directory: " dir)
|
||||
"Error")
|
||||
(do-goto button event orig-dir)))))))]
|
||||
|
||||
[on-default-action
|
||||
(lambda (which)
|
||||
(if (eq? which name-list)
|
||||
(let* ([which (send name-list get-string-selection)]
|
||||
[dir (build-path current-dir
|
||||
(make-relative which))])
|
||||
(if (directory-exists? dir)
|
||||
(set-directory (mzlib:file^:normalize-path dir))
|
||||
(if save-mode?
|
||||
(send name-field set-value which)
|
||||
(if multi-mode?
|
||||
(do-add)
|
||||
(do-ok)))))
|
||||
(if (eq? which name-field)
|
||||
(do-ok))))]
|
||||
|
||||
[do-name
|
||||
(lambda (text event)
|
||||
(if (eq? (send event get-event-type)
|
||||
wx:const-event-type-text-enter-command)
|
||||
(do-ok)))]
|
||||
[do-name-list
|
||||
(lambda args #f)]
|
||||
[do-result-list
|
||||
(lambda args #f)]
|
||||
|
||||
[do-into-dir
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(if (directory-exists? name)
|
||||
(set-directory (mzlib:file^:normalize-path name)))))))]
|
||||
|
||||
[do-ok
|
||||
(lambda args
|
||||
(if multi-mode?
|
||||
(let loop ([n (sub1 select-counter)][result ()])
|
||||
(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))
|
||||
dirs current-dir
|
||||
last-selected
|
||||
|
||||
[select-counter 0])
|
||||
|
||||
(private
|
||||
[set-directory
|
||||
(lambda (dir) ; dir is normalied
|
||||
(set! current-dir dir)
|
||||
(set! last-directory dir)
|
||||
(let-values
|
||||
([(dir-list menu-list)
|
||||
(let loop ([this-dir dir]
|
||||
[dir-list ()]
|
||||
[menu-list ()])
|
||||
(let-values ([(base-dir in-dir dir?) (split-path this-dir)])
|
||||
(if (eq? wx:platform 'windows)
|
||||
(mzlib:string:string-lowercase! in-dir))
|
||||
(let* ([dir-list (cons this-dir dir-list)]
|
||||
[menu-list (cons in-dir menu-list)])
|
||||
(if base-dir
|
||||
(loop base-dir dir-list menu-list)
|
||||
; No more
|
||||
(values dir-list menu-list)))))])
|
||||
(set! dirs dir-list)
|
||||
|
||||
(send dir-choice clear)
|
||||
(let loop ([choices menu-list])
|
||||
(unless (null? choices)
|
||||
(send dir-choice append (car choices))
|
||||
(loop (cdr choices))))
|
||||
(send dir-choice set-selection (sub1 (length dirs)))
|
||||
(send dir-choice set-size -1 -1 -1 -1))
|
||||
|
||||
(send name-list clear)
|
||||
(send name-list set
|
||||
(mzlib:function:quicksort
|
||||
(let loop ([l (directory-list dir)])
|
||||
(if (null? l)
|
||||
'()
|
||||
(let ([s (car l)]
|
||||
[rest (loop (cdr l))])
|
||||
(if (directory-exists? (build-path dir s))
|
||||
(cons
|
||||
(string-append s
|
||||
(case wx:platform
|
||||
(unix "/")
|
||||
(windows "\\")
|
||||
(macintosh ":")))
|
||||
rest)
|
||||
(if (or (not file-filter)
|
||||
(mzlib:string:regexp-match-exact? file-filter s))
|
||||
(cons s rest)
|
||||
rest)))))
|
||||
(if (eq? wx:platform 'unix) string<? string-ci<?)))
|
||||
(set! last-selected -1))])
|
||||
|
||||
(public
|
||||
[do-dir
|
||||
(lambda (choice event)
|
||||
(let ([which (send event get-selection)])
|
||||
(if (< which (length dirs))
|
||||
(set-directory (list-ref dirs which)))))]
|
||||
|
||||
[do-goto
|
||||
(opt-lambda (button event [default ""])
|
||||
(let ([orig-dir (wx:get-text-from-user
|
||||
"Directory" "Go to Directory"
|
||||
default)])
|
||||
(if (string? orig-dir)
|
||||
(let ([dir (mzlib:file:normalize-path orig-dir current-dir)])
|
||||
(if (directory-exists? dir)
|
||||
(set-directory dir)
|
||||
(begin
|
||||
(wx:message-box
|
||||
(string-append "Bad directory: " dir)
|
||||
"Error")
|
||||
(do-goto button event orig-dir)))))))]
|
||||
|
||||
[on-default-action
|
||||
(lambda (which)
|
||||
(if (eq? which name-list)
|
||||
(let* ([which (send name-list get-string-selection)]
|
||||
[dir (build-path current-dir
|
||||
(make-relative which))])
|
||||
(if (directory-exists? dir)
|
||||
(set-directory (mzlib:file:normalize-path dir))
|
||||
(if save-mode?
|
||||
(send name-field set-value which)
|
||||
(if multi-mode?
|
||||
(do-add)
|
||||
(do-ok)))))
|
||||
(if (eq? which name-field)
|
||||
(do-ok))))]
|
||||
|
||||
[do-name
|
||||
(lambda (text event)
|
||||
(if (eq? (send event get-event-type)
|
||||
wx:const-event-type-text-enter-command)
|
||||
(do-ok)))]
|
||||
[do-name-list
|
||||
(lambda args #f)]
|
||||
[do-result-list
|
||||
(lambda args #f)]
|
||||
|
||||
[do-into-dir
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(if (directory-exists? name)
|
||||
(set-directory (mzlib:file:normalize-path name)))))))]
|
||||
|
||||
[do-ok
|
||||
(lambda args
|
||||
(if multi-mode?
|
||||
(let loop ([n (sub1 select-counter)][result ()])
|
||||
(if (< n 0)
|
||||
(begin
|
||||
(set-box! result-box (mzlib:file^:normalize-path file))
|
||||
(show #f)))))]))))]
|
||||
|
||||
[add-one
|
||||
(lambda (name)
|
||||
(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))))]
|
||||
[do-add
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)))))]
|
||||
[do-add-all
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
(let ([name (send name-list get-string n)])
|
||||
(if (and (string? name)
|
||||
(positive? (string-length name)))
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)
|
||||
(loop (add1 n)))))))]
|
||||
[do-remove
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
(if (< n select-counter)
|
||||
(if (send result-list selected? n)
|
||||
(begin
|
||||
(send result-list delete n)
|
||||
(set! select-counter (sub1 select-counter))
|
||||
(loop n))
|
||||
(loop (add1 n))))))]
|
||||
|
||||
[do-cancel
|
||||
(lambda args
|
||||
(set-box! result-box #f)
|
||||
(show #f))]
|
||||
(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
|
||||
(set-box! result-box (mzlib:file:normalize-path file))
|
||||
(show #f)))))]))))]
|
||||
|
||||
[add-one
|
||||
(lambda (name)
|
||||
(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))))]
|
||||
[do-add
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)))))]
|
||||
[do-add-all
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
(let ([name (send name-list get-string n)])
|
||||
(if (and (string? name)
|
||||
(positive? (string-length name)))
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)
|
||||
(loop (add1 n)))))))]
|
||||
[do-remove
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
(if (< n select-counter)
|
||||
(if (send result-list selected? n)
|
||||
(begin
|
||||
(send result-list delete n)
|
||||
(set! select-counter (sub1 select-counter))
|
||||
(loop n))
|
||||
(loop (add1 n))))))]
|
||||
|
||||
[do-cancel
|
||||
(lambda args
|
||||
(set-box! result-box #f)
|
||||
(show #f))]
|
||||
|
||||
[on-close (lambda () #f)])
|
||||
(sequence
|
||||
|
||||
(super-init () (if save-mode? "Put File" "Get File")
|
||||
#t 300 300 WIDTH HEIGHT)
|
||||
|
||||
(make-object wx:message% this prompt)
|
||||
|
||||
(new-line))
|
||||
[on-close (lambda () #f)])
|
||||
(sequence
|
||||
|
||||
(super-init () (if save-mode? "Put File" "Get File")
|
||||
#t 300 300 WIDTH HEIGHT)
|
||||
|
||||
(make-object wx:message% this prompt)
|
||||
|
||||
(new-line))
|
||||
|
||||
(private
|
||||
[dir-choice (make-object wx:choice%
|
||||
this do-dir '() -1 -1 -1 -1
|
||||
'("XXXXXXXXXXXXXXXXXXXXXXXXXXX"))]
|
||||
|
||||
[name-list (begin
|
||||
(new-line)
|
||||
(private
|
||||
[dir-choice (make-object wx:choice%
|
||||
this do-dir '() -1 -1 -1 -1
|
||||
'("XXXXXXXXXXXXXXXXXXXXXXXXXXX"))]
|
||||
|
||||
[name-list (begin
|
||||
(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%
|
||||
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%
|
||||
this do-result-list
|
||||
()
|
||||
(if (eq? wx:window-system 'motif)
|
||||
wx:const-extended
|
||||
wx:const-multiple)
|
||||
-1 -1
|
||||
(* 1/2 WIDTH) 300
|
||||
() wx:const-needed-sb))])
|
||||
(sequence
|
||||
(new-line))
|
||||
|
||||
(private
|
||||
[name-field
|
||||
(if save-mode?
|
||||
(let ([v (make-object wx:text%
|
||||
this do-name
|
||||
"Name: " ""
|
||||
-1 -1
|
||||
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
|
||||
[(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))))
|
||||
this do-result-list
|
||||
()
|
||||
(if (eq? wx:window-system 'motif)
|
||||
wx:const-extended
|
||||
wx:const-multiple)
|
||||
-1 -1
|
||||
(* 1/2 WIDTH) 300
|
||||
() wx:const-needed-sb))])
|
||||
(sequence
|
||||
(new-line))
|
||||
|
||||
(private
|
||||
[name-field
|
||||
(if save-mode?
|
||||
(let ([v (make-object wx:text%
|
||||
this do-name
|
||||
"Name: " ""
|
||||
-1 -1
|
||||
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
|
||||
[(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))))
|
||||
|
||||
(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
|
||||
(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-get-file
|
||||
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
||||
[filter-msg "Bad name"])
|
||||
(let ([v (box #f)])
|
||||
(make-object finder-dialog% #f #f #f v directory '() prompt
|
||||
filter filter-msg)
|
||||
(unbox v))))
|
||||
(define common-get-file
|
||||
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
||||
[filter-msg "Bad name"])
|
||||
(let ([v (box #f)])
|
||||
(make-object finder-dialog% #f #f #f v directory '() prompt
|
||||
filter filter-msg)
|
||||
(unbox v))))
|
||||
|
||||
(define common-get-file-list
|
||||
(opt-lambda ([directory ()][prompt "Select Files"][filter #f]
|
||||
[filter-msg "Bad name"])
|
||||
(let ([v (box ())])
|
||||
(make-object finder-dialog% #f #f #t v directory '() prompt
|
||||
filter filter-msg)
|
||||
(unbox v))))
|
||||
(define common-get-file-list
|
||||
(opt-lambda ([directory ()][prompt "Select Files"][filter #f]
|
||||
[filter-msg "Bad name"])
|
||||
(let ([v (box ())])
|
||||
(make-object finder-dialog% #f #f #t v directory '() prompt
|
||||
filter filter-msg)
|
||||
(unbox v))))
|
||||
|
||||
(define std-put-file
|
||||
(opt-lambda ([name ()][directory ()][replace? #f][prompt "Select File"]
|
||||
[filter #f]
|
||||
[filter-msg
|
||||
"That filename 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)]
|
||||
[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
|
||||
(opt-lambda ([name ()][directory ()][replace? #f][prompt "Select File"]
|
||||
[filter #f]
|
||||
[filter-msg
|
||||
"That filename 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)]
|
||||
[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-get-file
|
||||
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
||||
[filter-msg
|
||||
"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)))))
|
||||
(define std-get-file
|
||||
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
||||
[filter-msg
|
||||
"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))
|
||||
; 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