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

.

Browse Source 
original commit: e2d54fe0ecbe08ec07e1ecc47ef0b8453a77cca2
This commit is contained in:
Matthew Flatt 2005-05-25 10:27:48 +00:00
parent 1e1059ac90
commit 950dc56020
4 changed files with 147 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/private/check.ss
View File

@ -43,6 +43,10 @@
(unless (or (not str) (string? str))
(raise-type-error (who->name who) "string or #f" str)))
(define (check-path who str)
(unless (path-string? str)
(raise-type-error (who->name who) "path or string" str)))
(define (check-path/false who str)
(unless (or (not str) (path-string? str))
(raise-type-error (who->name who) "path, string, or #f" str)))

133
collects/mred/private/editor.ss
View File

@ -36,15 +36,23 @@
get-active-canvas set-active-canvas
get-canvas
add-canvas remove-canvas
auto-wrap get-max-view-size))
auto-wrap get-max-view-size
save-file))
(define-local-member-name
-format-filter
-format-filter/save
-get-current-format
-get-file-format
-set-file-format
-set-format)
(define (check-format who format)
(unless (memq format '(guess standard text text-force-cr same copy))
(raise-type-error (who->name who)
"'guess, 'standard, 'text, 'text-force-cr, 'same, or 'copy"
format)))
(define-syntax (augmentize stx)
(syntax-case stx ()
[(_ (result id arg ...) ...)
@ -53,7 +61,7 @@
(and (super id arg ...)
(inner result id arg ...)))
...)]))
(define (make-editor-buffer% % can-wrap? get-editor%)
; >>> This class is instantiated directly by the end-user <<<
(class* % (editor<%> internal-editor<%>)
@ -62,13 +70,15 @@
[super-begin-edit-sequence begin-edit-sequence]
[super-end-edit-sequence end-edit-sequence]
[super-insert-port insert-port]
[super-save-port save-port]
[super-erase erase]
[super-clear-undos clear-undos]
[super-get-load-overwrites-styles get-load-overwrites-styles]
[super-get-filename get-filename])
(inherit get-max-width set-max-width get-admin
get-keymap get-style-list
set-modified set-filename)
set-modified set-filename
get-file put-file)
(define canvases null)
(define active-canvas #f)
(define auto-set-wrap? #f)
@ -92,19 +102,29 @@
(values (unbox wb) (unbox hb))))])
(public*
[-format-filter (lambda (f) f)]
[-format-filter/save (lambda (f) f)]
[-set-file-format (lambda (f) (void))]
[-get-file-format (lambda () 'standard)])
(override*
[insert-file
(opt-lambda ([file #f] [format 'guess] [show-errors? #t])
(dynamic-wind
(lambda () (super-begin-edit-sequence))
(lambda () (super-insert-port file format #f))
(lambda () (super-end-edit-sequence))))]
(opt-lambda (file [format 'guess] [show-errors? #t])
(let ([who '(method editor<%> insert-file)])
(check-path who file)
(check-format who format))
(do-load-file file format #f))]
[load-file
(opt-lambda ([file #f] [format 'guess] [show-errors? #t])
(do-load-file file format #t))])
(private*
[do-load-file
(lambda (file format load?)
(let ([who '(method editor<%> load-file)])
(unless (equal? file "")
(check-path/false who file))
(check-format who format))
(let* ([temp-filename?-box (box #f)]
[old-filename (super-get-filename temp-filename?-box)])
(let* ([file (cond
@ -114,15 +134,17 @@
(let ([path (if old-filename
(path-only old-filename)
#f)])
((get-get-file) path))
(get-file path))
old-filename)]
[(path? file) file]
[else (string->path file)])])
(and
file
(can-load-file? file (-format-filter format))
(or (not load?)
(can-load-file? file (-format-filter format)))
(begin
(on-load-file file (-format-filter format))
(or (not load?)
(on-load-file file (-format-filter format)))
(let ([port (open-input-file file)]
[finished? #f])
(dynamic-wind
@ -133,10 +155,11 @@
(dynamic-wind
void
(lambda ()
(super-erase)
(unless (and (not (unbox temp-filename?-box))
(equal? file old-filename))
(set-filename file #f))
(when load?
(super-erase)
(unless (and (not (unbox temp-filename?-box))
(equal? file old-filename))
(set-filename file #f)))
(let ([format (if (eq? format 'same)
(-get-file-format)
format)])
@ -146,20 +169,83 @@
(raise x))])
(super-insert-port port
(-format-filter format)
(super-get-load-overwrites-styles)))])
(and load?
(super-get-load-overwrites-styles))))])
(close-input-port port) ; close as soon as possible
(-set-file-format new-format)))) ; text% only
(when load?
(-set-file-format new-format))))) ; text% only
(lambda ()
(super-end-edit-sequence)
(wx:end-busy-cursor)))
(super-clear-undos)
(set-modified #f)
(when load?
(super-clear-undos)
(set-modified #f))
(set! finished? #t)
#t)
(lambda ()
(after-load-file finished?)
;; In case it wasn't closed before:
(close-input-port port)))))))))])
(close-input-port port)
(when load?
(after-load-file finished?))))))))))])
(public*
[save-file
(opt-lambda ([file #f] [format 'same] [show-errors? #t])
(let ([who '(method editor<%> save-file)])
(unless (equal? file "")
(check-path/false who file))
(check-format who format))
(let* ([temp-filename?-box (box #f)]
[old-filename (super-get-filename temp-filename?-box)])
(let* ([file (cond
[(or (not (path-string? file))
(equal? file ""))
(if (or (equal? file "") (not old-filename) (unbox temp-filename?-box))
(let ([path (if old-filename
(path-only old-filename)
#f)])
(put-file path (and old-filename
(file-name-from-path old-filename))))
old-filename)]
[(path? file) file]
[else (string->path file)])]
[f-format (-format-filter/save format)]
[actual-format (if (memq f-format '(copy same))
(-get-file-format)
f-format)]
[text? (not (memq actual-format '(text text-force-cr)))])
(and
file
(can-save-file? file f-format)
(begin
(on-save-file file f-format)
(let ([port (open-output-file file (if text? 'text 'binary) 'truncate/replace)]
[finished? #f])
(dynamic-wind
void
(lambda ()
(wx:file-creator-and-type file #"mReD" (if text? #"TEXT" #"WXME"))
(wx:begin-busy-cursor)
(dynamic-wind
void
(lambda ()
(super-save-port port format #t)
(close-output-port port) ; close as soon as possible
(unless (or (eq? format 'copy)
(and (not (unbox temp-filename?-box))
(equal? file old-filename)))
(set-filename file #f))
(unless (eq? format 'copy)
(-set-file-format actual-format))) ; text% only
(lambda ()
(wx:end-busy-cursor)))
(unless (eq? format 'copy)
(set-modified #f))
(set! finished? #t)
#t)
(lambda ()
;; In case it wasn't closed before:
(close-output-port port)
(after-save-file finished?)))))))))])
(public*
[get-canvases (entry-point (lambda () (map wx->mred canvases)))]
@ -316,7 +402,10 @@
(define pasteboard%
(class (es-contract-mixin (make-editor-buffer% wx:pasteboard% #f (lambda () pasteboard%))) ()
(override*
[-format-filter (lambda (f) 'standard)])
[-format-filter (lambda (f) 'standard)]
[-format-filter/save (lambda (f) (if (eq? f 'copy)
f
'standard))])
(augmentize (#t can-insert? s s2 x y)
((void) on-insert s s2 x y)
((void) after-insert s s2 x y)

2
collects/mred/private/kernel.ss
View File

@ -225,7 +225,7 @@
insert-file
load-file
insert-port
save-file
save-port
get-flattened-text
put-file
get-file

37
collects/mred/private/moredialogs.ss
View File

@ -49,6 +49,21 @@
(check-instance 'get-ps-setup-from-user wx:ps-setup% 'ps-setup% #t pss-in)
(check-style 'get-ps-setup-from-user #f null style)))
(define bad-fields null)
(define number-callback
(lambda (f ev)
(let ([e (send f get-editor)]
[ok? (real? (string->number (send f get-value)))])
(send e change-style
(send (make-object wx:style-delta%)
set-delta-background
(if ok? "white" "yellow"))
0 (send e last-position))
(set! bad-fields (remq f bad-fields))
(unless ok?
(set! bad-fields (cons f bad-fields)))
(send ok enable (null? bad-fields)))))
(define pss (or pss-in (wx:current-ps-setup)))
(define f (make-object dialog% "PostScript Setup" parent))
(define papers
@ -67,11 +82,14 @@
(define sp (make-object vertical-pane% ssp))
(define def-scale "0100.000")
(define def-offset "0000.000")
(define xscale (make-object text-field% "Horizontal Scale:" sp void def-scale))
(define xoffset (make-object text-field% "Horizontal Translation:" sp void def-offset))
(define def-margin "0016.000")
(define xscale (make-object text-field% "Horizontal Scale:" sp number-callback def-scale))
(define xoffset (make-object text-field% "Horizontal Translation:" sp number-callback def-offset))
(define xmargin (make-object text-field% "Horizontal Margin:" sp number-callback def-margin))
(define sp2 (make-object vertical-pane% ssp))
(define yscale (make-object text-field% "Vertical Scale:" sp2 void def-scale))
(define yoffset (make-object text-field% "Vertical Translation:" sp2 void def-offset))
(define yscale (make-object text-field% "Vertical Scale:" sp2 number-callback def-scale))
(define yoffset (make-object text-field% "Vertical Translation:" sp2 number-callback def-offset))
(define ymargin (make-object text-field% "Vertical Margin:" sp2 number-callback def-margin))
(define l2 (make-object check-box% "PostScript Level 2" f void))
@ -84,7 +102,8 @@
(send f show #f)
(set! ok? ?))
(define-values (xsb ysb xtb ytb) (values (box 0) (box 0) (box 0) (box 0)))
(define-values (xsb ysb xtb ytb xmb ymb)
(values (box 0) (box 0) (box 0) (box 0) (box 0) (box 0)))
(send paper set-selection (or (find-pos papers (send pss get-paper-name) equal?) 0))
(send orientation set-selection (if (eq? (send pss get-orientation) 'landscape) 1 0))
@ -102,16 +121,21 @@
(send pss get-translation xtb ytb)
(send xoffset set-value (number->string* (unbox xtb)))
(send yoffset set-value (number->string* (unbox ytb)))
(send pss get-margin xmb ymb)
(send xmargin set-value (number->string* (unbox xmb)))
(send ymargin set-value (number->string* (unbox ymb)))
(send xscale stretchable-width #f)
(send yscale stretchable-width #f)
(send xoffset stretchable-width #f)
(send yoffset stretchable-width #f)
(send xmargin stretchable-width #f)
(send ymargin stretchable-width #f)
(send l2 set-value (send pss get-level-2))
(send f set-alignment 'center 'top)
(map no-stretch (list f xscale yscale xoffset yoffset dp))
(map no-stretch (list f xscale yscale xoffset yoffset xmargin ymargin dp))
(send f center)
@ -132,6 +156,7 @@
[(2) 'file])))
(send s set-scaling (gv xscale xsb) (gv yscale ysb))
(send s set-translation (gv xoffset xtb) (gv yoffset ytb))
(send s set-margin (gv xmargin xmb) (gv ymargin ymb))
(send s set-level-2 (send l2 get-value))
(when (eq? (system-type) 'unix)