...
original commit: added8761de66065677d0ab2f4966ef75bb2d376
This commit is contained in:
Robby Findler
parent
75868b396a
commit
08f0d3cc22
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig framework:application^
|
||||
(dunit/sig framework:application^
|
||||
(import)
|
||||
|
||||
(define current-app-name (make-parameter
|
||||
|
|
|
|||
|
|
@ -1,44 +1,47 @@
|
|||
(unit/sig framework:autosave^
|
||||
(dunit/sig framework:autosave^
|
||||
(import mred-interfaces^
|
||||
[exit : framework:exit^]
|
||||
[preferences : framework:preferences^])
|
||||
|
||||
(define objects null)
|
||||
|
||||
(define autosave-timer%
|
||||
(class timer% ()
|
||||
(inherit start)
|
||||
(override
|
||||
[notify
|
||||
(lambda ()
|
||||
(when (preferences:get 'framework:autosaving-on?)
|
||||
(set! objects
|
||||
(let loop ([list objects])
|
||||
(if (null? list)
|
||||
null
|
||||
(let ([object (weak-box-value (car list))])
|
||||
(if object
|
||||
(begin
|
||||
(send object do-autosave)
|
||||
(cons (car list) (loop (cdr list))))
|
||||
(loop (cdr list))))))))
|
||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t)))])
|
||||
(sequence
|
||||
(super-init)
|
||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t)))))
|
||||
|
||||
(define timer #f)
|
||||
|
||||
(define register
|
||||
(let* ([objects null]
|
||||
[autosave-timer%
|
||||
(class timer% ()
|
||||
(inherit start)
|
||||
(override
|
||||
[notify
|
||||
(lambda ()
|
||||
(when (preferences:get 'framework:autosaving-on?)
|
||||
(set! objects
|
||||
(let loop ([list objects])
|
||||
(if (null? list)
|
||||
null
|
||||
(let ([object (weak-box-value (car list))])
|
||||
(if object
|
||||
(begin
|
||||
(send object do-autosave)
|
||||
(cons (car list) (loop (cdr list))))
|
||||
(loop (cdr list))))))))
|
||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t)))])
|
||||
(sequence
|
||||
(super-init)
|
||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t))))]
|
||||
[timer #f])
|
||||
(lambda (b)
|
||||
(unless timer
|
||||
(set! timer (make-object autosave-timer%)))
|
||||
(set! objects
|
||||
(let loop ([objects objects])
|
||||
(cond
|
||||
[(null? objects) (list (make-weak-box b))]
|
||||
[else (let ([weak-box (car objects)])
|
||||
(if (weak-box-value weak-box)
|
||||
(cons weak-box (loop (cdr objects)))
|
||||
(loop (cdr objects))))])))))))
|
||||
(lambda (b)
|
||||
(unless timer
|
||||
(set! timer (make-object autosave-timer%)))
|
||||
(set! objects
|
||||
(let loop ([objects objects])
|
||||
(cond
|
||||
[(null? objects) (list (make-weak-box b))]
|
||||
[else (let ([weak-box (car objects)])
|
||||
(if (weak-box-value weak-box)
|
||||
(cons weak-box (loop (cdr objects)))
|
||||
(loop (cdr objects))))]))))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,95 +1,100 @@
|
|||
(unit/sig framework:canvas^
|
||||
(dunit/sig framework:canvas^
|
||||
(import mred-interfaces^
|
||||
[preferences : framework:preferences^])
|
||||
|
||||
(define wide-snip<%> (interface (editor-canvas<%>)
|
||||
add-wide-snip
|
||||
add-tall-snip))
|
||||
|
||||
;; wx: this need to collude with
|
||||
;; the edit, since the edit has the right callbacks.
|
||||
|
||||
(define make-wide-snip%
|
||||
(lambda (super%)
|
||||
(class-asi super%
|
||||
(inherit get-media)
|
||||
(rename [super-on-size on-size])
|
||||
(private
|
||||
[wide-snips null]
|
||||
[tall-snips null]
|
||||
[update-snip-size
|
||||
(lambda (width?)
|
||||
(lambda (s)
|
||||
(let* ([width (box 0)]
|
||||
[height (box 0)]
|
||||
[leftm (box 0)]
|
||||
[rightm (box 0)]
|
||||
[topm (box 0)]
|
||||
[bottomm (box 0)]
|
||||
[left-edge-box (box 0)]
|
||||
[top-edge-box (box 0)]
|
||||
[snip-media (send s get-this-media)]
|
||||
[edit (get-media)])
|
||||
(when edit
|
||||
(send edit
|
||||
run-after-edit-sequence
|
||||
(lambda ()
|
||||
(let ([admin (send edit get-admin)])
|
||||
(send admin get-view #f #f width height)
|
||||
(send s get-margin leftm topm rightm bottomm)
|
||||
(define wide-snip-mixin
|
||||
(mixin (editor-canvas<%>) (wide-snip<%>) args
|
||||
(inherit get-editor)
|
||||
(rename [super-on-size on-size])
|
||||
(private
|
||||
[wide-snips null]
|
||||
[tall-snips null]
|
||||
[update-snip-size
|
||||
(lambda (width?)
|
||||
(lambda (s)
|
||||
(let* ([width (box 0)]
|
||||
[height (box 0)]
|
||||
[leftm (box 0)]
|
||||
[rightm (box 0)]
|
||||
[topm (box 0)]
|
||||
[bottomm (box 0)]
|
||||
[left-edge-box (box 0)]
|
||||
[top-edge-box (box 0)]
|
||||
[snip-media (send s get-this-media)]
|
||||
[edit (get-editor)])
|
||||
(when edit
|
||||
(send edit
|
||||
run-after-edit-sequence
|
||||
(lambda ()
|
||||
(let ([admin (send edit get-admin)])
|
||||
(send admin get-view #f #f width height)
|
||||
(send s get-margin leftm topm rightm bottomm)
|
||||
|
||||
|
||||
;; when the width is to be maximized and there is a
|
||||
;; newline just behind the snip, we know that the left
|
||||
;; edge is zero. Special case for efficiency in the
|
||||
;; console printer
|
||||
(let ([fallback
|
||||
(lambda ()
|
||||
(send edit get-snip-position-and-location
|
||||
s #f left-edge-box top-edge-box))])
|
||||
(cond
|
||||
[(not width?) (fallback)]
|
||||
[(let ([prev (send s previous)])
|
||||
(and (not prev
|
||||
(member 'hard-newline (send prev get-flags)))))
|
||||
(set-box! left-edge-box 0)]
|
||||
[else (fallback)]))
|
||||
;; when the width is to be maximized and there is a
|
||||
;; newline just behind the snip, we know that the left
|
||||
;; edge is zero. Special case for efficiency in the
|
||||
;; console printer
|
||||
(let ([fallback
|
||||
(lambda ()
|
||||
(send edit get-snip-position-and-location
|
||||
s #f left-edge-box top-edge-box))])
|
||||
(cond
|
||||
[(not width?) (fallback)]
|
||||
[(let ([prev (send s previous)])
|
||||
(and (not prev
|
||||
(member 'hard-newline (send prev get-flags)))))
|
||||
(set-box! left-edge-box 0)]
|
||||
[else (fallback)]))
|
||||
|
||||
|
||||
(if width?
|
||||
(let ([snip-width (- (unbox width)
|
||||
(unbox left-edge-box)
|
||||
(unbox leftm)
|
||||
(unbox rightm)
|
||||
|
||||
;; this two is the space that
|
||||
;; the caret needs at the right of
|
||||
;; a buffer.
|
||||
2)])
|
||||
(send* s
|
||||
(set-min-width snip-width)
|
||||
(set-max-width snip-width))
|
||||
(when snip-media
|
||||
(send snip-media set-max-width
|
||||
(if (send snip-media auto-wrap)
|
||||
snip-width
|
||||
0))))
|
||||
(let ([snip-height (- (unbox height)
|
||||
(unbox top-edge-box)
|
||||
(unbox topm)
|
||||
(unbox bottomm))])
|
||||
(send* s
|
||||
(set-min-height snip-height)
|
||||
(set-max-height snip-height)))))))))))])
|
||||
(public
|
||||
[add-wide-snip
|
||||
(lambda (snip)
|
||||
(set! wide-snips (cons snip wide-snips))
|
||||
((update-snip-size #t) snip))]
|
||||
[add-tall-snip
|
||||
(lambda (snip)
|
||||
(set! tall-snips (cons snip tall-snips))
|
||||
((update-snip-size #f) snip))]
|
||||
[on-size
|
||||
(lambda (width height)
|
||||
(super-on-size width height)
|
||||
(for-each (update-snip-size #t) wide-snips)
|
||||
(for-each (update-snip-size #f) tall-snips))]))))
|
||||
(if width?
|
||||
(let ([snip-width (- (unbox width)
|
||||
(unbox left-edge-box)
|
||||
(unbox leftm)
|
||||
(unbox rightm)
|
||||
|
||||
;; this two is the space that
|
||||
;; the caret needs at the right of
|
||||
;; a buffer.
|
||||
2)])
|
||||
(send* s
|
||||
(set-min-width snip-width)
|
||||
(set-max-width snip-width))
|
||||
(when snip-media
|
||||
(send snip-media set-max-width
|
||||
(if (send snip-media auto-wrap)
|
||||
snip-width
|
||||
0))))
|
||||
(let ([snip-height (- (unbox height)
|
||||
(unbox top-edge-box)
|
||||
(unbox topm)
|
||||
(unbox bottomm))])
|
||||
(send* s
|
||||
(set-min-height snip-height)
|
||||
(set-max-height snip-height)))))))))))])
|
||||
(public
|
||||
[add-wide-snip
|
||||
(lambda (snip)
|
||||
(set! wide-snips (cons snip wide-snips))
|
||||
((update-snip-size #t) snip))]
|
||||
[add-tall-snip
|
||||
(lambda (snip)
|
||||
(set! tall-snips (cons snip tall-snips))
|
||||
((update-snip-size #f) snip))])
|
||||
(override
|
||||
[on-size
|
||||
(lambda (width height)
|
||||
(super-on-size width height)
|
||||
(for-each (update-snip-size #t) wide-snips)
|
||||
(for-each (update-snip-size #f) tall-snips))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define wide-snip% (make-wide-snip% editor-canvas%)))
|
||||
(define wide-snip% (wide-snip-mixin editor-canvas%)))
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig framework:editor^
|
||||
(dunit/sig framework:editor^
|
||||
(import mred-interfaces^
|
||||
[autosave : framework:autosave^]
|
||||
[finder : framework:finder^]
|
||||
|
|
@ -6,18 +6,20 @@
|
|||
[keymap : framework:keymap^]
|
||||
[icon : framework:icon^]
|
||||
[preferences : framework:preferences^]
|
||||
[gui-utils : framework:gui-utils^])
|
||||
[text : framework:text^]
|
||||
[pasteboard : framework:pasteboard^])
|
||||
|
||||
(define basic<%>
|
||||
(interface (editor<%>)
|
||||
editing-this-file?
|
||||
local-edit-sequence?
|
||||
run-after-edit-sequence
|
||||
get-text-snip
|
||||
get-pasteboard-snip
|
||||
default-auto-wrap?))
|
||||
default-auto-wrap?
|
||||
get-top-level-window
|
||||
locked?
|
||||
on-close))
|
||||
|
||||
(define make-basic%
|
||||
(define basic-mixin
|
||||
(mixin (editor<%>) (basic<%>) args
|
||||
(inherit get-filename save-file
|
||||
refresh-delayed?
|
||||
|
|
@ -25,62 +27,47 @@
|
|||
get-keymap
|
||||
get-max-width get-admin set-filename)
|
||||
(rename [super-set-modified set-modified]
|
||||
[super-on-save-file on-save-file]
|
||||
[super-on-focus on-focus]
|
||||
[super-load-file load-file]
|
||||
[super-lock lock])
|
||||
|
||||
(public [editing-this-file? #f])
|
||||
(public
|
||||
[on-close void]
|
||||
[get-top-level-window
|
||||
(lambda ()
|
||||
(let ([c (get-canvas)])
|
||||
(and c
|
||||
(send c get-top-level-window))))])
|
||||
|
||||
(override
|
||||
[load-file
|
||||
(opt-lambda ([filename #f]
|
||||
[the-format 'guess]
|
||||
[show-dialog? #t])
|
||||
(let ([filename (or filename
|
||||
(parameterize ([finder:dialog-parent-parameter
|
||||
(let ([canvas (get-canvas)])
|
||||
(and canvas
|
||||
(send canvas get-top-level-window)))])
|
||||
(finder:get-file)))])
|
||||
(and filename
|
||||
(if (file-exists? filename)
|
||||
(let ([res (super-load-file filename the-format #f)])
|
||||
(when (and (not res)
|
||||
show-dialog?)
|
||||
(message-box
|
||||
"Error Loading File"
|
||||
(format "Error loading file ~a" filename))
|
||||
res))
|
||||
(set-filename filename)))))])
|
||||
(public [editing-this-file? (lambda () #f)])
|
||||
|
||||
(private
|
||||
[edit-sequence-queue null]
|
||||
[edit-sequence-ht (make-hash-table)])
|
||||
|
||||
(private
|
||||
[in-local-edit-sequence? #f])
|
||||
(public
|
||||
[local-edit-sequence? #f]
|
||||
[local-edit-sequence? (lambda () in-local-edit-sequence?)]
|
||||
[run-after-edit-sequence
|
||||
(rec run-after-edit-sequence
|
||||
(case-lambda
|
||||
[(t) (run-after-edit-sequence t #f)]
|
||||
[(t sym)
|
||||
(unless (and (procedure? t)
|
||||
(= 0 (arity t)))
|
||||
(error 'media-buffer::run-after-edit-sequence
|
||||
"expected procedure of arity zero, got: ~s~n" t))
|
||||
(unless (or (symbol? sym) (not sym))
|
||||
(error 'media-buffer::run-after-edit-sequence
|
||||
"expected second argument to be a symbol, got: ~s~n"
|
||||
sym))
|
||||
(if (refresh-delayed?)
|
||||
(cond
|
||||
[(symbol? sym)
|
||||
(hash-table-put! edit-sequence-ht sym t)]
|
||||
[else (set! edit-sequence-queue
|
||||
(cons t edit-sequence-queue))])
|
||||
(t))
|
||||
(void)]))]
|
||||
(case-lambda
|
||||
[(t) (run-after-edit-sequence t #f)]
|
||||
[(t sym)
|
||||
(unless (and (procedure? t)
|
||||
(= 0 (arity t)))
|
||||
(error 'media-buffer::run-after-edit-sequence
|
||||
"expected procedure of arity zero, got: ~s~n" t))
|
||||
(unless (or (symbol? sym) (not sym))
|
||||
(error 'media-buffer::run-after-edit-sequence
|
||||
"expected second argument to be a symbol, got: ~s~n"
|
||||
sym))
|
||||
(if (refresh-delayed?)
|
||||
(cond
|
||||
[(symbol? sym)
|
||||
(hash-table-put! edit-sequence-ht sym t)]
|
||||
[else (set! edit-sequence-queue
|
||||
(cons t edit-sequence-queue))])
|
||||
(t))
|
||||
(void)])]
|
||||
[extend-edit-sequence-queue
|
||||
(lambda (l ht)
|
||||
(hash-table-for-each ht (lambda (k t)
|
||||
|
|
@ -95,10 +82,10 @@
|
|||
[on-edit-sequence
|
||||
(lambda ()
|
||||
(super-on-edit-sequence)
|
||||
(set! local-edit-sequence? #t))]
|
||||
(set! in-local-edit-sequence? #t))]
|
||||
[after-edit-sequence
|
||||
(lambda ()
|
||||
(set! local-edit-sequence? #f)
|
||||
(set! in-local-edit-sequence? #f)
|
||||
(super-after-edit-sequence)
|
||||
(let ([queue edit-sequence-queue]
|
||||
[ht edit-sequence-ht]
|
||||
|
|
@ -115,67 +102,56 @@
|
|||
(set! edit-sequence-ht (make-hash-table))
|
||||
(let loop ([edit (find-enclosing-edit this)])
|
||||
(cond
|
||||
[(and edit (not (ivar edit local-edit-sequence?)))
|
||||
[(and edit (not (send edit local-edit-sequence?)))
|
||||
(loop (find-enclosing-edit edit))]
|
||||
[edit (send edit extend-edit-sequence-queue queue ht)]
|
||||
[else
|
||||
(hash-table-for-each ht (lambda (k t) (t)))
|
||||
(for-each (lambda (t) (t)) queue)]))))])
|
||||
(private
|
||||
[is-locked? #f])
|
||||
(public
|
||||
[locked? #f])
|
||||
[locked? (lambda () is-locked?)])
|
||||
(override
|
||||
[lock
|
||||
[lock
|
||||
(lambda (x)
|
||||
(set! locked? x)
|
||||
(super-lock x))])
|
||||
|
||||
(public
|
||||
[get-text-snip (lambda () (make-object editor-snip% (make-object text%)))]
|
||||
[get-pasteboard-snip (lambda () (make-object editor-snip% (make-object pasteboard%)))])
|
||||
(override
|
||||
(set! is-locked? x)
|
||||
(super-lock x))]
|
||||
[on-new-box
|
||||
(lambda (type)
|
||||
(cond
|
||||
[(eq? type 'text) (get-text-snip)]
|
||||
[else (get-pasteboard-snip)]))])
|
||||
[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
|
||||
[else (make-object editor-snip% (make-object pasteboard:basic%))]))])
|
||||
|
||||
|
||||
(public
|
||||
(override
|
||||
[get-file (lambda (d)
|
||||
(let ([v (parameterize ([finder:dialog-parent-parameter
|
||||
(and (get-canvas)
|
||||
(send (get-canvas) get-top-level-window))])
|
||||
(finder:get-file d))])
|
||||
(if v
|
||||
v
|
||||
null)))]
|
||||
[put-file (lambda (d f) (let ([v (parameterize ([finder:dialog-parent-parameter
|
||||
(and (get-canvas)
|
||||
(send (get-canvas) get-top-level-window))])
|
||||
(finder:put-file f d))])
|
||||
(if v
|
||||
v
|
||||
null)))])
|
||||
(parameterize ([finder:dialog-parent-parameter
|
||||
(get-top-level-window)])
|
||||
(finder:get-file d)))]
|
||||
[put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter
|
||||
(get-top-level-window)])
|
||||
(finder:put-file f d)))])
|
||||
|
||||
(public
|
||||
[default-auto-wrap? #t])
|
||||
[default-auto-wrap? (lambda () #t)])
|
||||
(inherit auto-wrap)
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(auto-wrap default-auto-wrap?))))
|
||||
(auto-wrap (default-auto-wrap?)))))
|
||||
|
||||
|
||||
(define file<%> (interface (basic<%>)))
|
||||
(define make-file%
|
||||
(define file-mixin
|
||||
(mixin (basic<%>) (file<%>) args
|
||||
(inherit get-keymap
|
||||
get-filename lock get-style-list
|
||||
is-modified? change-style set-modified
|
||||
get-frame)
|
||||
get-top-level-window)
|
||||
(rename [super-after-save-file after-save-file]
|
||||
[super-after-load-file after-load-file])
|
||||
|
||||
(override [editing-this-file? #t])
|
||||
(override [editing-this-file? (lambda () #t)])
|
||||
(private
|
||||
[check-lock
|
||||
(lambda ()
|
||||
|
|
@ -213,15 +189,14 @@
|
|||
do-autosave
|
||||
remove-autosave))
|
||||
|
||||
; wx: when should autosave files be removed?
|
||||
; also, what about checking the autosave files when a file is
|
||||
; wx: what about checking the autosave files when a file is
|
||||
; opened?
|
||||
(define make-backup-autosave%
|
||||
(define backup-autosave-mixin
|
||||
(mixin (basic<%>) (backup-autosave<%>) args
|
||||
(inherit is-modified? get-filename save-file)
|
||||
(rename [super-on-save-file on-save-file]
|
||||
[super-on-change on-change]
|
||||
[super-do-close do-close]
|
||||
[super-on-close on-close]
|
||||
[super-set-modified set-modified])
|
||||
(private
|
||||
[freshen-backup? #t]
|
||||
|
|
@ -229,30 +204,29 @@
|
|||
[auto-save-out-of-date? #t]
|
||||
[auto-save-error? #f])
|
||||
(public
|
||||
[auto-save? #t]
|
||||
[backup? #t])
|
||||
[backup? (lambda () #t)])
|
||||
(override
|
||||
[on-save-file
|
||||
(lambda (name format)
|
||||
(set! auto-save-error? #f)
|
||||
(and (super-on-save-file name format)
|
||||
(begin
|
||||
(when (and backup?
|
||||
(when (and (backup?)
|
||||
freshen-backup?
|
||||
(not (eq? format 'copy))
|
||||
(file-exists? name))
|
||||
(let ([back-name (path-utils:generate-backup-name name)])
|
||||
(when freshen-backup?
|
||||
(set! freshen-backup? #f)
|
||||
(when (file-exists? back-name)
|
||||
(delete-file back-name)))
|
||||
(set! freshen-backup? #f)
|
||||
(when (file-exists? back-name)
|
||||
(delete-file back-name))
|
||||
(with-handlers ([(lambda (x) #t) void])
|
||||
(copy-file name back-name))))
|
||||
#t)))]
|
||||
[do-close
|
||||
[on-close
|
||||
(lambda ()
|
||||
(super-do-close)
|
||||
(super-on-close)
|
||||
(remove-autosave)
|
||||
(set! auto-save? #f))]
|
||||
(set! autosave? (lambda () #f)))]
|
||||
[on-change
|
||||
(lambda ()
|
||||
(super-on-change)
|
||||
|
|
@ -267,10 +241,10 @@
|
|||
(set! auto-saved-name #f))))
|
||||
(super-set-modified modified?))])
|
||||
(public
|
||||
[autosave? #t]
|
||||
[autosave? (lambda () #t)]
|
||||
[do-autosave
|
||||
(lambda ()
|
||||
(when (and auto-save?
|
||||
(when (and (autosave?)
|
||||
(not auto-save-error?)
|
||||
(is-modified?)
|
||||
(or (not auto-saved-name)
|
||||
|
|
@ -302,9 +276,9 @@
|
|||
(autosave:register this))))
|
||||
|
||||
(define info<%> (interface (basic<%>)))
|
||||
(define make-info%
|
||||
(define info-mixin
|
||||
(mixin (basic<%>) (info<%>) args
|
||||
(inherit get-frame run-after-edit-sequence)
|
||||
(inherit get-top-level-window run-after-edit-sequence)
|
||||
(rename [super-lock lock])
|
||||
(override
|
||||
[lock
|
||||
|
|
@ -313,57 +287,8 @@
|
|||
(run-after-edit-sequence
|
||||
(rec send-frame-update-lock-icon
|
||||
(lambda ()
|
||||
(let ([frame (get-frame)])
|
||||
(let ([frame (get-top-level-window)])
|
||||
(when frame
|
||||
(send frame lock-status-changed)))))
|
||||
'framework:update-lock-icon))])
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
(define make-clever-file-format%
|
||||
(mixin (editor<%>) (editor<%>) args
|
||||
(inherit get-file-format set-file-format ;find-first-snip wx:
|
||||
)
|
||||
(rename [super-on-save-file on-save-file]
|
||||
[super-after-save-file after-save-file])
|
||||
|
||||
(private [restore-file-format void])
|
||||
|
||||
(override
|
||||
[after-save-file
|
||||
(lambda (success)
|
||||
(restore-file-format)
|
||||
(super-after-save-file success))]
|
||||
[on-save-file
|
||||
(let ([has-non-string-snips
|
||||
(lambda ()
|
||||
(let loop ([s (if (is-a? this pasteboard%)
|
||||
(send this find-first-snip)
|
||||
(send this find-snip 0 'after))]) ;; wx:
|
||||
(cond
|
||||
[(null? s) #f]
|
||||
[(is-a? s string-snip%)
|
||||
(loop (send s next))]
|
||||
[else #t])))])
|
||||
(lambda (name format)
|
||||
(when (and (or (eq? format 'same)
|
||||
(eq? format 'copy))
|
||||
(not (eq? (get-file-format)
|
||||
'std)))
|
||||
(cond
|
||||
[(eq? format 'copy)
|
||||
(set! restore-file-format
|
||||
(let ([f (get-file-format)])
|
||||
(lambda ()
|
||||
(set! restore-file-format void)
|
||||
(set-file-format f))))
|
||||
(set-file-format 'std)]
|
||||
[(and (has-non-string-snips)
|
||||
(or (not (preferences:get 'framework:verify-change-format))
|
||||
(gui-utils:get-choice "Save this file as plain text?" "No" "Yes")))
|
||||
(set-file-format 'std)]
|
||||
[else (void)]))
|
||||
(or (super-on-save-file name format)
|
||||
(begin
|
||||
(restore-file-format)
|
||||
#f))))])
|
||||
(sequence (apply super-init args)))))
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig framework:exit^
|
||||
(dunit/sig framework:exit^
|
||||
(import [preferences : framework:preferences^]
|
||||
[gui-utils : framework:gui-utils^])
|
||||
(rename (-exit exit))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
(unit/sig framework:path-utils^
|
||||
(dunit/sig framework:path-utils^
|
||||
(import)
|
||||
|
||||
(define generate-autosave-name
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
;;; Authors: Matthew Flatt, Robby Findler, Paul Steckler
|
||||
|
||||
(unit/sig framework:finder^
|
||||
(dunit/sig framework:finder^
|
||||
(import mred-interfaces^
|
||||
[preferences : framework:preferences^]
|
||||
[gui-utils : framework:gui-utils^]
|
||||
|
|
@ -62,8 +62,7 @@
|
|||
file-filter
|
||||
file-filter-msg)
|
||||
|
||||
(inherit new-line tab fit center
|
||||
popup-menu show)
|
||||
(inherit center show)
|
||||
|
||||
(private
|
||||
[WIDTH 500]
|
||||
|
|
@ -310,8 +309,9 @@
|
|||
[do-cancel
|
||||
(lambda args
|
||||
(set-box! result-box #f)
|
||||
(show #f))]
|
||||
(show #f))])
|
||||
|
||||
(override
|
||||
[on-close (lambda () #f)])
|
||||
|
||||
(sequence
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,199 +1,200 @@
|
|||
(unit/sig framework:group^
|
||||
(dunit/sig framework:group^
|
||||
(import mred-interfaces^
|
||||
[exit : framework:exit^]
|
||||
[frame : framework:frame^]
|
||||
[mzlib:function : mzlib:function^]
|
||||
[mzlib:file : mzlib:file^])
|
||||
|
||||
(define-struct frame (frame id))
|
||||
|
||||
(define %
|
||||
(let-struct frame (frame id)
|
||||
(class null ()
|
||||
(private
|
||||
[active-frame #f]
|
||||
[frame-counter 0]
|
||||
[frames null]
|
||||
[todo-to-new-frames void]
|
||||
[empty-close-down (lambda () (void))]
|
||||
[empty-test (lambda () #t)]
|
||||
|
||||
[windows-menus null])
|
||||
(class null ()
|
||||
(private
|
||||
[active-frame #f]
|
||||
[frame-counter 0]
|
||||
[frames null]
|
||||
[todo-to-new-frames void]
|
||||
[empty-close-down (lambda () (void))]
|
||||
[empty-test (lambda () #t)]
|
||||
|
||||
(private
|
||||
[get-windows-menu
|
||||
(lambda (frame)
|
||||
(and (ivar-in-class? 'windows-menu (object-class frame))
|
||||
(ivar frame windows-menu)))]
|
||||
[insert-windows-menu
|
||||
(lambda (frame)
|
||||
(let ([menu (get-windows-menu frame)])
|
||||
(when menu
|
||||
(set! windows-menus (cons (list menu) windows-menus)))))]
|
||||
[remove-windows-menu
|
||||
(lambda (frame)
|
||||
(let* ([menu (get-windows-menu frame)])
|
||||
(set! windows-menus
|
||||
(mzlib:function:remove
|
||||
menu
|
||||
windows-menus
|
||||
(lambda (x y)
|
||||
(eq? x (car y)))))))]
|
||||
[windows-menus null])
|
||||
|
||||
(private
|
||||
[get-windows-menu
|
||||
(lambda (frame)
|
||||
(and (ivar-in-class? 'windows-menu (object-class frame))
|
||||
(ivar frame windows-menu)))]
|
||||
[insert-windows-menu
|
||||
(lambda (frame)
|
||||
(let ([menu (get-windows-menu frame)])
|
||||
(when menu
|
||||
(set! windows-menus (cons (list menu) windows-menus)))))]
|
||||
[remove-windows-menu
|
||||
(lambda (frame)
|
||||
(let* ([menu (get-windows-menu frame)])
|
||||
(set! windows-menus
|
||||
(mzlib:function:remove
|
||||
menu
|
||||
windows-menus
|
||||
(lambda (x y)
|
||||
(eq? x (car y)))))))]
|
||||
|
||||
[update-windows-menus
|
||||
(lambda ()
|
||||
(let* ([windows (length windows-menus)]
|
||||
[get-name (lambda (frame) (send (frame-frame frame) get-label))]
|
||||
[sorted-frames
|
||||
(mzlib:function:quicksort
|
||||
frames
|
||||
(lambda (f1 f2)
|
||||
(string-ci<=? (get-name f1)
|
||||
(get-name f2))))])
|
||||
(set!
|
||||
windows-menus
|
||||
(map
|
||||
(lambda (menu-list)
|
||||
(let ([menu (car menu-list)]
|
||||
[old-ids (cdr menu-list)])
|
||||
(for-each (lambda (id) (send menu delete id))
|
||||
old-ids)
|
||||
(let ([new-ids
|
||||
(map
|
||||
(lambda (frame)
|
||||
(let ([frame (frame-frame frame)]
|
||||
[default-name "Untitled"])
|
||||
(send menu append-item
|
||||
(let ([label (send frame get-label)])
|
||||
(if (string=? label "")
|
||||
(if (ivar-in-class? 'get-entire-label (object-class frame))
|
||||
(let ([label (send frame get-entire-label)])
|
||||
(if (string=? label "")
|
||||
default-name
|
||||
label))
|
||||
default-name)
|
||||
label))
|
||||
(lambda ()
|
||||
(send frame show #t)))))
|
||||
sorted-frames)])
|
||||
(cons menu new-ids))))
|
||||
windows-menus))))])
|
||||
|
||||
(private
|
||||
[update-close-menu-item-state
|
||||
(lambda ()
|
||||
(let* ([set-close-menu-item-state!
|
||||
(lambda (frame state)
|
||||
(when (is-a? frame frame:standard-menus<%>)
|
||||
(let ([close-menu-item (ivar frame file-menu:close-menu)])
|
||||
(when close-menu-item
|
||||
(send close-menu-item enable state)))))])
|
||||
[update-windows-menus
|
||||
(lambda ()
|
||||
(let* ([windows (length windows-menus)]
|
||||
[get-name (lambda (frame) (send (frame-frame frame) get-label))]
|
||||
[sorted-frames
|
||||
(mzlib:function:quicksort
|
||||
frames
|
||||
(lambda (f1 f2)
|
||||
(string-ci<=? (get-name f1)
|
||||
(get-name f2))))])
|
||||
(set!
|
||||
windows-menus
|
||||
(map
|
||||
(lambda (menu-list)
|
||||
(let ([menu (car menu-list)]
|
||||
[old-ids (cdr menu-list)])
|
||||
(for-each (lambda (id) (send menu delete id))
|
||||
old-ids)
|
||||
(let ([new-ids
|
||||
(map
|
||||
(lambda (frame)
|
||||
(let ([frame (frame-frame frame)]
|
||||
[default-name "Untitled"])
|
||||
(send menu append-item
|
||||
(let ([label (send frame get-label)])
|
||||
(if (string=? label "")
|
||||
(if (ivar-in-class? 'get-entire-label (object-class frame))
|
||||
(let ([label (send frame get-entire-label)])
|
||||
(if (string=? label "")
|
||||
default-name
|
||||
label))
|
||||
default-name)
|
||||
label))
|
||||
(lambda ()
|
||||
(send frame show #t)))))
|
||||
sorted-frames)])
|
||||
(cons menu new-ids))))
|
||||
windows-menus))))])
|
||||
|
||||
(private
|
||||
[update-close-menu-item-state
|
||||
(lambda ()
|
||||
(let* ([set-close-menu-item-state!
|
||||
(lambda (frame state)
|
||||
(when (is-a? frame frame:standard-menus<%>)
|
||||
(let ([close-menu-item (ivar frame file-menu:close-menu)])
|
||||
(when close-menu-item
|
||||
(send close-menu-item enable state)))))])
|
||||
(if (eq? (length frames) 1)
|
||||
(set-close-menu-item-state! (car frames) #f)
|
||||
(for-each (lambda (a-frame)
|
||||
(set-close-menu-item-state! a-frame #t))
|
||||
frames))))])
|
||||
(public
|
||||
[set-empty-callbacks
|
||||
(lambda (test close-down)
|
||||
(set! empty-test test)
|
||||
(set! empty-close-down close-down))]
|
||||
[get-frames (lambda () (map frame-frame frames))]
|
||||
|
||||
[frame-label-changed
|
||||
(lambda (frame)
|
||||
(when (member frame (map frame-frame frames))
|
||||
(update-windows-menus)))]
|
||||
|
||||
[for-each-frame
|
||||
(lambda (f)
|
||||
(for-each (lambda (x) (f (frame-frame x))) frames)
|
||||
(set! todo-to-new-frames
|
||||
(let ([old todo-to-new-frames])
|
||||
(lambda (frame) (old frame) (f frame)))))]
|
||||
[get-active-frame
|
||||
(lambda ()
|
||||
(cond
|
||||
[active-frame active-frame]
|
||||
[(null? frames) #f]
|
||||
[else (frame-frame (car frames))]))]
|
||||
[set-active-frame
|
||||
(lambda (f)
|
||||
(set! active-frame f))]
|
||||
[insert-frame
|
||||
(lambda (f)
|
||||
(set! frame-counter (add1 frame-counter))
|
||||
(let ([new-frames (cons (make-frame f frame-counter)
|
||||
frames)])
|
||||
(set! frames new-frames)
|
||||
(update-close-menu-item-state)
|
||||
(insert-windows-menu f)
|
||||
(update-windows-menus))
|
||||
(todo-to-new-frames f))]
|
||||
|
||||
[can-remove-frame?
|
||||
(opt-lambda (f)
|
||||
(let ([new-frames
|
||||
(mzlib:function:remove
|
||||
f frames
|
||||
(lambda (f fr) (eq? f (frame-frame fr))))])
|
||||
(if (null? new-frames)
|
||||
(empty-test)
|
||||
#t)))]
|
||||
[remove-frame
|
||||
(opt-lambda (f)
|
||||
(when (eq? f active-frame)
|
||||
(set! active-frame #f))
|
||||
(let ([new-frames
|
||||
(mzlib:function:remove
|
||||
f frames
|
||||
(lambda (f fr) (eq? f (frame-frame fr))))])
|
||||
(set! frames new-frames)
|
||||
(update-close-menu-item-state)
|
||||
(remove-windows-menu f)
|
||||
(update-windows-menus)
|
||||
(when (null? frames)
|
||||
(empty-close-down))))]
|
||||
[clear
|
||||
(lambda ()
|
||||
(and (empty-test)
|
||||
(begin (set! frames null)
|
||||
(empty-close-down)
|
||||
#t)))]
|
||||
[close-all
|
||||
(lambda ()
|
||||
(let/ec escape
|
||||
(for-each (lambda (f)
|
||||
(let ([frame (frame-frame f)])
|
||||
(if (send frame on-close)
|
||||
(send frame show #f)
|
||||
(escape #f))))
|
||||
frames)
|
||||
#t))]
|
||||
[locate-file
|
||||
(lambda (name)
|
||||
(let* ([normalized
|
||||
;; allow for the possiblity of filenames that are urls
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x) name)])
|
||||
(mzlib:file:normalize-path name))]
|
||||
[test-frame
|
||||
(lambda (frame)
|
||||
(and (ivar-in-class? 'get-edit (object-class frame))
|
||||
(let* ([edit (send frame get-edit)]
|
||||
[filename (send edit get-filename)])
|
||||
(and (ivar edit editing-this-file?)
|
||||
(string? filename)
|
||||
(string=? normalized
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x) filename)])
|
||||
(mzlib:file:normalize-path
|
||||
filename)))))))])
|
||||
(let loop ([frames frames])
|
||||
(cond
|
||||
[(null? frames) #f]
|
||||
[else
|
||||
(let* ([frame (frame-frame (car frames))])
|
||||
(if (test-frame frame)
|
||||
frame
|
||||
(loop (cdr frames))))]))))]))))
|
||||
(public
|
||||
[set-empty-callbacks
|
||||
(lambda (test close-down)
|
||||
(set! empty-test test)
|
||||
(set! empty-close-down close-down))]
|
||||
[get-frames (lambda () (map frame-frame frames))]
|
||||
|
||||
[frame-label-changed
|
||||
(lambda (frame)
|
||||
(when (member frame (map frame-frame frames))
|
||||
(update-windows-menus)))]
|
||||
|
||||
[for-each-frame
|
||||
(lambda (f)
|
||||
(for-each (lambda (x) (f (frame-frame x))) frames)
|
||||
(set! todo-to-new-frames
|
||||
(let ([old todo-to-new-frames])
|
||||
(lambda (frame) (old frame) (f frame)))))]
|
||||
[get-active-frame
|
||||
(lambda ()
|
||||
(cond
|
||||
[active-frame active-frame]
|
||||
[(null? frames) #f]
|
||||
[else (frame-frame (car frames))]))]
|
||||
[set-active-frame
|
||||
(lambda (f)
|
||||
(set! active-frame f))]
|
||||
[insert-frame
|
||||
(lambda (f)
|
||||
(set! frame-counter (add1 frame-counter))
|
||||
(let ([new-frames (cons (make-frame f frame-counter)
|
||||
frames)])
|
||||
(set! frames new-frames)
|
||||
(update-close-menu-item-state)
|
||||
(insert-windows-menu f)
|
||||
(update-windows-menus))
|
||||
(todo-to-new-frames f))]
|
||||
|
||||
[can-remove-frame?
|
||||
(opt-lambda (f)
|
||||
(let ([new-frames
|
||||
(mzlib:function:remove
|
||||
f frames
|
||||
(lambda (f fr) (eq? f (frame-frame fr))))])
|
||||
(if (null? new-frames)
|
||||
(empty-test)
|
||||
#t)))]
|
||||
[remove-frame
|
||||
(opt-lambda (f)
|
||||
(when (eq? f active-frame)
|
||||
(set! active-frame #f))
|
||||
(let ([new-frames
|
||||
(mzlib:function:remove
|
||||
f frames
|
||||
(lambda (f fr) (eq? f (frame-frame fr))))])
|
||||
(set! frames new-frames)
|
||||
(update-close-menu-item-state)
|
||||
(remove-windows-menu f)
|
||||
(update-windows-menus)
|
||||
(when (null? frames)
|
||||
(empty-close-down))))]
|
||||
[clear
|
||||
(lambda ()
|
||||
(and (empty-test)
|
||||
(begin (set! frames null)
|
||||
(empty-close-down)
|
||||
#t)))]
|
||||
[close-all
|
||||
(lambda ()
|
||||
(let/ec escape
|
||||
(for-each (lambda (f)
|
||||
(let ([frame (frame-frame f)])
|
||||
(if (send frame on-close)
|
||||
(send frame show #f)
|
||||
(escape #f))))
|
||||
frames)
|
||||
#t))]
|
||||
[locate-file
|
||||
(lambda (name)
|
||||
(let* ([normalized
|
||||
;; allow for the possiblity of filenames that are urls
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x) name)])
|
||||
(mzlib:file:normalize-path name))]
|
||||
[test-frame
|
||||
(lambda (frame)
|
||||
(and (ivar-in-class? 'get-edit (object-class frame))
|
||||
(let* ([edit (send frame get-edit)]
|
||||
[filename (send edit get-filename)])
|
||||
(and (send edit editing-this-file?)
|
||||
(string? filename)
|
||||
(string=? normalized
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x) filename)])
|
||||
(mzlib:file:normalize-path
|
||||
filename)))))))])
|
||||
(let loop ([frames frames])
|
||||
(cond
|
||||
[(null? frames) #f]
|
||||
[else
|
||||
(let* ([frame (frame-frame (car frames))])
|
||||
(if (test-frame frame)
|
||||
frame
|
||||
(loop (cdr frames))))]))))])))
|
||||
|
||||
(define the-frame-group (make-object %)))
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig framework:gui-utils^
|
||||
(dunit/sig framework:gui-utils^
|
||||
(import mred-interfaces^)
|
||||
|
||||
(define cursor-delay
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig framework:handler^
|
||||
(dunit/sig framework:handler^
|
||||
(import mred-interfaces^
|
||||
[gui-utils : framework:gui-utils^]
|
||||
[finder : framework:finder^]
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig framework:icon^
|
||||
(dunit/sig framework:icon^
|
||||
(import mred-interfaces^)
|
||||
|
||||
(define icon-path
|
||||
|
|
@ -16,16 +16,16 @@
|
|||
(begin (set! bitmap (make-object % p type))
|
||||
bitmap)))))
|
||||
|
||||
(define (load-bitmap/mdc % name type)
|
||||
(define (load-bitmap/bdc % name type)
|
||||
(let* ([p (build-path icon-path name)]
|
||||
[bitmap #f]
|
||||
[memory-dc #f]
|
||||
[bitmap-dc #f]
|
||||
[force
|
||||
(lambda ()
|
||||
(set! bitmap (make-object % p type))
|
||||
(set! memory-dc (make-object memory-dc%))
|
||||
(set! bitmap-dc (make-object bitmap-dc%))
|
||||
(when (send bitmap ok?)
|
||||
(send memory-dc select-object bitmap)))])
|
||||
(send bitmap-dc select-object bitmap)))])
|
||||
(unless (file-exists? p)
|
||||
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
||||
(values
|
||||
|
|
@ -34,16 +34,16 @@
|
|||
(begin (force)
|
||||
bitmap)))
|
||||
(lambda ()
|
||||
(or memory-dc
|
||||
(or bitmap-dc
|
||||
(begin (force)
|
||||
memory-dc))))))
|
||||
bitmap-dc))))))
|
||||
|
||||
(define-values (get-anchor-bitmap get-anchor-mdc)
|
||||
(load-bitmap/mdc bitmap% "anchor.gif" 'gif))
|
||||
(define-values (get-lock-bitmap get-lock-mdc)
|
||||
(load-bitmap/mdc bitmap% "lock.gif" 'gif))
|
||||
(define-values (get-unlock-bitmap get-unlock-mdc)
|
||||
(load-bitmap/mdc bitmap% "unlock.gif" 'gif))
|
||||
(define-values (get-anchor-bitmap get-anchor-bdc)
|
||||
(load-bitmap/bdc bitmap% "anchor.gif" 'gif))
|
||||
(define-values (get-lock-bitmap get-lock-bdc)
|
||||
(load-bitmap/bdc bitmap% "lock.gif" 'gif))
|
||||
(define-values (get-unlock-bitmap get-unlock-bdc)
|
||||
(load-bitmap/bdc bitmap% "unlock.gif" 'gif))
|
||||
|
||||
(define get-autowrap-bitmap (load-icon bitmap% "return.xbm" 'xbm))
|
||||
(define get-paren-highlight-bitmap (load-icon bitmap% "paren.xbm" 'xbm))
|
||||
|
|
@ -57,7 +57,7 @@
|
|||
(lambda ()
|
||||
(or icon
|
||||
(begin
|
||||
(set! icon (make-object icon% p 'xbm))
|
||||
(set! icon (make-object bitmap% p 'xbm))
|
||||
icon)))))
|
||||
|
||||
(define-values (get-gc-on-dc get-gc-width get-gc-height)
|
||||
|
|
@ -65,14 +65,14 @@
|
|||
"recycle.gif"
|
||||
'gif)]
|
||||
[bitmap #f]
|
||||
[mdc #f]
|
||||
[bdc #f]
|
||||
[fetch
|
||||
(lambda ()
|
||||
(unless mdc
|
||||
(set! mdc (make-object memory-dc%))
|
||||
(unless bdc
|
||||
(set! bdc (make-object bitmap-dc%))
|
||||
(set! bitmap (get-bitmap))
|
||||
(send mdc select-object bitmap)))])
|
||||
(values (lambda () (fetch) mdc)
|
||||
(send bdc select-object bitmap)))])
|
||||
(values (lambda () (fetch) bdc)
|
||||
(lambda () (fetch) (if (send bitmap ok?)
|
||||
(send bitmap get-width)
|
||||
10))
|
||||
|
|
@ -81,15 +81,15 @@
|
|||
10)))))
|
||||
|
||||
(define get-gc-off-dc
|
||||
(let ([mdc #f])
|
||||
(let ([bdc #f])
|
||||
(lambda ()
|
||||
(if mdc
|
||||
mdc
|
||||
(if bdc
|
||||
bdc
|
||||
(begin
|
||||
(set! mdc (make-object memory-dc%))
|
||||
(send mdc select-object
|
||||
(set! bdc (make-object bitmap-dc%))
|
||||
(send bdc select-object
|
||||
(make-object bitmap%
|
||||
(get-gc-width)
|
||||
(get-gc-height)))
|
||||
(send mdc clear)
|
||||
mdc))))))
|
||||
(send bdc clear)
|
||||
bdc))))))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig framework:keymap^
|
||||
(dunit/sig framework:keymap^
|
||||
(import mred-interfaces^
|
||||
[preferences : framework:preferences^]
|
||||
[finder : framework:finder^]
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig ()
|
||||
(dunit/sig framework:main^
|
||||
(import mred-interfaces^
|
||||
[preferences : framework:preferences^]
|
||||
[exit : framework:exit^]
|
||||
|
|
@ -16,14 +16,10 @@
|
|||
(preferences:set-default 'framework:show-status-line #t boolean?)
|
||||
(preferences:set-default 'framework:line-offsets #t boolean?)
|
||||
|
||||
|
||||
|
||||
|
||||
(preferences:set 'framework:print-output-mode
|
||||
'standard
|
||||
(lambda (x) (or (eq? x 'standard) (eq? x 'postscript))))
|
||||
|
||||
|
||||
(preferences:set-default
|
||||
'framework:print-output-mode
|
||||
'standard
|
||||
(lambda (x) (or (eq? x 'standard) (eq? x 'postscript))))
|
||||
|
||||
(preferences:set-default 'framework:highlight-parens #t boolean?)
|
||||
(preferences:set-default 'framework:fixup-parens #t boolean?)
|
||||
|
|
@ -75,14 +71,15 @@
|
|||
(preferences:set-default 'framework:delete-forward?
|
||||
(not (eq? (system-type) 'unix))
|
||||
boolean?)
|
||||
(preferences:set 'framework:show-periods-in-dirlist #f boolean?)
|
||||
(preferences:set 'framework:file-dialogs
|
||||
(if (eq? (system-type) 'unix)
|
||||
'common
|
||||
'std)
|
||||
(lambda (x)
|
||||
(or (eq? x 'common)
|
||||
(eq? x 'std))))
|
||||
(preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
|
||||
(preferences:set-default
|
||||
'framework:file-dialogs
|
||||
(if (eq? (system-type) 'unix)
|
||||
'common
|
||||
'std)
|
||||
(lambda (x)
|
||||
(or (eq? x 'common)
|
||||
(eq? x 'std))))
|
||||
|
||||
(preferences:add-panel
|
||||
"Indenting"
|
||||
|
|
|
|||
|
|
@ -1,24 +1,26 @@
|
|||
(unit/sig framework:panel^
|
||||
(dunit/sig framework:panel^
|
||||
(import mred-interfaces^
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
||||
(define single<%> (interface (panel%)))
|
||||
(define make-single%
|
||||
(rename [-editor<%> editor<%>])
|
||||
|
||||
(define single<%> (interface (panel<%>)))
|
||||
(define single-mixin
|
||||
(mixin (panel<%>) (single<%>) args
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(define single% vertical-panel%)
|
||||
(define single% (single-mixin vertical-panel%))
|
||||
|
||||
(define edit<%>
|
||||
(define -editor<%>
|
||||
(interface ()
|
||||
get-canvas%
|
||||
collapse
|
||||
split))
|
||||
|
||||
(define make-edit%
|
||||
(mixin (panel<%>) (edit<%>) args
|
||||
(define editor-mixin
|
||||
(mixin (panel<%>) (-editor<%>) args
|
||||
(rename [super-change-children change-children])
|
||||
(inherit get-parent change-children children)
|
||||
(inherit get-parent change-children get-children)
|
||||
(public [get-canvas% (lambda () editor-canvas%)])
|
||||
(private
|
||||
[split-edits null])
|
||||
|
|
@ -30,26 +32,27 @@
|
|||
(letrec ([helper
|
||||
(lambda (canvas/panel)
|
||||
(if (eq? canvas/panel this)
|
||||
(begin (cond
|
||||
[(and (= (length children) 1)
|
||||
(eq? canvas (car children)))
|
||||
(void)]
|
||||
[(member canvas children)
|
||||
(change-children (lambda (l) (list canvas)))]
|
||||
[else
|
||||
(change-children
|
||||
(lambda (l)
|
||||
(let ([c (make-object (object-class canvas) this)])
|
||||
(send c set-media media)
|
||||
(list c))))])
|
||||
(let ([children (get-children)])
|
||||
(cond
|
||||
[(and (= (length children) 1)
|
||||
(eq? canvas (car children)))
|
||||
(void)]
|
||||
[(member canvas children)
|
||||
(change-children (lambda (l) (list canvas)))]
|
||||
[else
|
||||
(change-children
|
||||
(lambda (l)
|
||||
(let ([c (make-object (object-class canvas) this)])
|
||||
(send c set-media media)
|
||||
(list c))))])
|
||||
(bell))
|
||||
(let* ([parent (send canvas/panel get-parent)]
|
||||
[parents-children (ivar parent children)]
|
||||
[parents-children (send parent get-children)]
|
||||
[num-children (length parents-children)])
|
||||
(if (<= num-children 1)
|
||||
(helper parent)
|
||||
(begin (send parent delete-child canvas/panel)
|
||||
(send (car (ivar parent children)) focus))))))])
|
||||
(send (car (send parent get-children)) focus))))))])
|
||||
(send media remove-canvas canvas)
|
||||
(helper canvas))
|
||||
(bell))))]
|
||||
|
|
@ -87,7 +90,7 @@
|
|||
(send* right-split (set-media media))))])
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
(define horizontal-edit%
|
||||
(make-edit% horizontal-panel%))
|
||||
(define vertical-edit%
|
||||
(make-edit% vertical-panel%)))
|
||||
(define horizontal-editor%
|
||||
(editor-mixin horizontal-panel%))
|
||||
(define vertical-editor%
|
||||
(editor-mixin vertical-panel%)))
|
||||
Loading…
Reference in New Issue
Block a user