405 lines
11 KiB
Scheme
405 lines
11 KiB
Scheme
(unit/sig framework:editor^
|
|
(import mred^
|
|
[autosave : framework:autosave^]
|
|
[finder : framework:finder^]
|
|
[path-utils : framework:path-utils^]
|
|
[keymap : framework:keymap^]
|
|
[icon : framework:icon^]
|
|
[preferences : framework:preferences^]
|
|
[text : framework:text^]
|
|
[pasteboard : framework:pasteboard^]
|
|
[frame : framework:frame^]
|
|
[mzlib:file : mzlib:file^])
|
|
|
|
(rename [-keymap<%> keymap<%>])
|
|
|
|
(define basic<%>
|
|
(interface (editor<%>)
|
|
has-focus?
|
|
editing-this-file?
|
|
local-edit-sequence?
|
|
run-after-edit-sequence
|
|
get-top-level-window
|
|
locked?
|
|
on-close))
|
|
|
|
(define basic-mixin
|
|
(mixin (editor<%>) (basic<%>) args
|
|
(inherit get-filename save-file
|
|
refresh-delayed?
|
|
get-canvas
|
|
get-max-width get-admin)
|
|
(private
|
|
[has-focus #f])
|
|
(rename [super-on-focus on-focus])
|
|
(override
|
|
[on-focus
|
|
(lambda (x)
|
|
(set! has-focus x))])
|
|
(public
|
|
[has-focus?
|
|
(lambda ()
|
|
has-focus)])
|
|
|
|
(rename [super-begin-edit-sequence begin-edit-sequence]
|
|
[super-end-edit-sequence end-edit-sequence])
|
|
(private
|
|
[edit-sequence-count 0])
|
|
(override
|
|
[begin-edit-sequence
|
|
(case-lambda
|
|
[() (begin-edit-sequence #t)]
|
|
[(undoable?)
|
|
(set! edit-sequence-count (+ edit-sequence-count 1))
|
|
(super-begin-edit-sequence undoable?)])]
|
|
[end-edit-sequence
|
|
(lambda ()
|
|
(set! edit-sequence-count (- edit-sequence-count 1))
|
|
(when (< edit-sequence-count 0)
|
|
(error 'end-edit-sequence "extra end-edit-sequence"))
|
|
(super-end-edit-sequence))])
|
|
|
|
(public
|
|
[on-close void]
|
|
[get-top-level-window
|
|
(lambda ()
|
|
(let loop ([text this])
|
|
(let ([editor-admin (send text get-admin)])
|
|
(cond
|
|
[(is-a? editor-admin editor-snip-editor-admin<%>)
|
|
(let* ([snip (send editor-admin get-snip)]
|
|
[snip-admin (send snip get-admin)])
|
|
(loop (send snip-admin get-editor)))]
|
|
[(send text get-canvas) => (lambda (canvas)
|
|
(send canvas get-top-level-window))]
|
|
[else
|
|
#f]))))])
|
|
|
|
(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? (lambda () in-local-edit-sequence?)]
|
|
[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?)
|
|
(if in-local-edit-sequence?
|
|
(cond
|
|
[(symbol? sym)
|
|
(hash-table-put! edit-sequence-ht sym t)]
|
|
[else (set! edit-sequence-queue
|
|
(cons t edit-sequence-queue))])
|
|
(let ([snip-admin (get-admin)])
|
|
(cond
|
|
[(not snip-admin)
|
|
(t)] ;; refresh-delayed? is always #t when there is no admin.
|
|
[(is-a? snip-admin editor-snip-editor-admin<%>)
|
|
(send (send (send (send snip-admin get-snip) get-admin) get-editor)
|
|
run-after-edit-sequence t sym)]
|
|
[else
|
|
(message-box "run-after-edit-sequence error"
|
|
(format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>"
|
|
snip-admin))
|
|
'(t)])))
|
|
(t))
|
|
(void)])]
|
|
[extend-edit-sequence-queue
|
|
(lambda (l ht)
|
|
(hash-table-for-each ht (lambda (k t)
|
|
(hash-table-put!
|
|
edit-sequence-ht
|
|
k t)))
|
|
(set! edit-sequence-queue (append l edit-sequence-queue)))])
|
|
(rename
|
|
[super-after-edit-sequence after-edit-sequence]
|
|
[super-on-edit-sequence on-edit-sequence])
|
|
(override
|
|
[on-edit-sequence
|
|
(lambda ()
|
|
(super-on-edit-sequence)
|
|
(set! in-local-edit-sequence? #t))]
|
|
[after-edit-sequence
|
|
(lambda ()
|
|
(set! in-local-edit-sequence? #f)
|
|
(super-after-edit-sequence)
|
|
(let ([queue edit-sequence-queue]
|
|
[ht edit-sequence-ht]
|
|
[find-enclosing-edit
|
|
(lambda (edit)
|
|
(let ([admin (send edit get-admin)])
|
|
(cond
|
|
[(is-a? admin editor-snip-editor-admin<%>)
|
|
(send (send (send admin get-snip) get-admin) get-editor)]
|
|
[else #f])))])
|
|
(set! edit-sequence-queue null)
|
|
(set! edit-sequence-ht (make-hash-table))
|
|
(let loop ([edit (find-enclosing-edit this)])
|
|
(cond
|
|
[(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)]))))])
|
|
|
|
(rename [super-lock lock])
|
|
(private
|
|
[is-locked? #f])
|
|
(public
|
|
[locked? (lambda () is-locked?)])
|
|
(override
|
|
[lock
|
|
(lambda (x)
|
|
(set! is-locked? x)
|
|
(super-lock x))]
|
|
[on-new-box
|
|
(lambda (type)
|
|
(cond
|
|
[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
|
|
[else (make-object editor-snip% (make-object pasteboard:basic%))]))])
|
|
|
|
|
|
(override
|
|
[get-file (lambda (d)
|
|
(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)))])
|
|
|
|
|
|
(sequence
|
|
(apply super-init args))))
|
|
|
|
|
|
(define -keymap<%> (interface (basic<%>) get-keymaps))
|
|
(define keymap-mixin
|
|
(mixin (basic<%>) (-keymap<%>) args
|
|
(public
|
|
[get-keymaps
|
|
(lambda ()
|
|
(list (keymap:get-global)))])
|
|
(inherit set-keymap)
|
|
(sequence
|
|
(apply super-init args)
|
|
(let ([keymap (make-object keymap:aug-keymap%)])
|
|
(set-keymap keymap)
|
|
(for-each (lambda (k) (send keymap chain-to-keymap k #f))
|
|
(get-keymaps))))))
|
|
|
|
(define autowrap<%> (interface (basic<%>)))
|
|
(define autowrap-mixin
|
|
(mixin (basic<%>) (autowrap<%>) args
|
|
|
|
(rename [super-on-close on-close])
|
|
(override
|
|
[on-close
|
|
(lambda ()
|
|
(remove-callback)
|
|
(super-on-close))])
|
|
|
|
(inherit auto-wrap)
|
|
(sequence
|
|
(apply super-init args)
|
|
(auto-wrap
|
|
(preferences:get
|
|
'framework:auto-set-wrap?)))
|
|
(private
|
|
[remove-callback
|
|
(preferences:add-callback
|
|
'framework:auto-set-wrap?
|
|
(let ([autowrap-mixin-pref-callback
|
|
(lambda (p v)
|
|
(auto-wrap v))])
|
|
autowrap-mixin-pref-callback))])))
|
|
|
|
(define file<%> (interface (-keymap<%>)))
|
|
(define file-mixin
|
|
(mixin (-keymap<%>) (file<%>) args
|
|
(inherit get-filename lock get-style-list
|
|
is-modified? change-style set-modified
|
|
get-top-level-window)
|
|
(rename [super-after-save-file after-save-file]
|
|
[super-after-load-file after-load-file]
|
|
[super-get-keymaps get-keymaps]
|
|
[super-set-filename set-filename])
|
|
|
|
(override
|
|
[editing-this-file? (lambda () #t)])
|
|
|
|
(inherit get-canvases)
|
|
(private
|
|
[check-lock
|
|
(lambda ()
|
|
(let* ([filename (get-filename)]
|
|
[lock? (and filename
|
|
(file-exists? filename)
|
|
(not (member
|
|
'write
|
|
(file-or-directory-permissions
|
|
filename))))])
|
|
(lock lock?)))]
|
|
[update-filename
|
|
(lambda (name)
|
|
(let ([filename (if name
|
|
(mzlib:file:file-name-from-path (mzlib:file:normalize-path name))
|
|
"")])
|
|
(for-each (lambda (canvas)
|
|
(let ([tlw (send canvas get-top-level-window)])
|
|
(when (is-a? tlw frame:editor<%>)
|
|
(send tlw set-label filename))))
|
|
(get-canvases))))])
|
|
(override
|
|
[after-save-file
|
|
(lambda (success)
|
|
(when success
|
|
(check-lock))
|
|
(super-after-save-file success))]
|
|
|
|
[after-load-file
|
|
(lambda (sucessful?)
|
|
(when sucessful?
|
|
(check-lock))
|
|
(super-after-load-file sucessful?))]
|
|
|
|
[set-filename
|
|
(case-lambda
|
|
[(name) (set-filename name #f)]
|
|
[(name temp?)
|
|
(super-set-filename name temp?)
|
|
(unless temp?
|
|
(update-filename name))])]
|
|
|
|
[get-keymaps
|
|
(lambda ()
|
|
(cons (keymap:get-file) (super-get-keymaps)))])
|
|
(sequence
|
|
(apply super-init args))))
|
|
|
|
(define backup-autosave<%>
|
|
(interface (basic<%>)
|
|
backup?
|
|
autosave?
|
|
do-autosave
|
|
remove-autosave))
|
|
|
|
; what about checking the autosave files when a file is opened?
|
|
(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-on-close on-close]
|
|
[super-set-modified set-modified])
|
|
(private
|
|
[auto-saved-name #f]
|
|
[auto-save-out-of-date? #t]
|
|
[auto-save-error? #f]
|
|
[file-old?
|
|
(lambda (filename)
|
|
(let ([modified-seconds (file-or-directory-modify-seconds filename)]
|
|
[old-seconds (- (current-seconds) (* 7 24 60 60))])
|
|
(< modified-seconds old-seconds)))])
|
|
(public
|
|
[backup? (lambda () #t)])
|
|
(override
|
|
[on-save-file
|
|
(lambda (name format)
|
|
(super-on-save-file name format)
|
|
(set! auto-save-error? #f)
|
|
(when (and (backup?)
|
|
(not (eq? format 'copy))
|
|
(file-exists? name))
|
|
(let ([back-name (path-utils:generate-backup-name name)])
|
|
(when (or (not (file-exists? back-name))
|
|
(file-old? back-name))
|
|
(when (file-exists? back-name)
|
|
(delete-file back-name))
|
|
(with-handlers ([(lambda (x) #t) void])
|
|
(copy-file name back-name))))))]
|
|
[on-close
|
|
(lambda ()
|
|
(super-on-close)
|
|
(remove-autosave)
|
|
(set! autosave? (lambda () #f)))]
|
|
[on-change
|
|
(lambda ()
|
|
(super-on-change)
|
|
(set! auto-save-out-of-date? #t))]
|
|
[set-modified
|
|
(lambda (modified?)
|
|
(when auto-saved-name
|
|
(if modified?
|
|
(set! auto-save-out-of-date? #t)
|
|
(remove-autosave)))
|
|
(super-set-modified modified?))])
|
|
(public
|
|
[autosave? (lambda () #t)]
|
|
[do-autosave
|
|
(lambda ()
|
|
(when (and (autosave?)
|
|
(not auto-save-error?)
|
|
(is-modified?)
|
|
(or (not auto-saved-name)
|
|
auto-save-out-of-date?))
|
|
(let* ([orig-name (get-filename)]
|
|
[old-auto-name auto-saved-name]
|
|
[auto-name (path-utils:generate-autosave-name orig-name)]
|
|
[success (save-file auto-name 'copy)])
|
|
(if success
|
|
(begin
|
|
(when old-auto-name
|
|
(delete-file old-auto-name))
|
|
(set! auto-saved-name auto-name)
|
|
(set! auto-save-out-of-date? #f))
|
|
(begin
|
|
(message-box
|
|
"Warning"
|
|
(format "Error autosaving ~s.~n~a~n~a"
|
|
(or orig-name "Untitled")
|
|
"Autosaving is turned off"
|
|
"until the file is saved."))
|
|
(set! auto-save-error? #t))))))]
|
|
[remove-autosave
|
|
(lambda ()
|
|
(when auto-saved-name
|
|
(when (file-exists? auto-saved-name)
|
|
(delete-file auto-saved-name))
|
|
(set! auto-saved-name #f)))])
|
|
(sequence
|
|
(apply super-init args)
|
|
(autosave:register this))))
|
|
|
|
(define info<%> (interface (basic<%>)))
|
|
(define info-mixin
|
|
(mixin (basic<%>) (info<%>) args
|
|
(inherit get-top-level-window run-after-edit-sequence)
|
|
(rename [super-lock lock])
|
|
(override
|
|
[lock
|
|
(lambda (x)
|
|
(super-lock x)
|
|
(run-after-edit-sequence
|
|
(rec send-frame-update-lock-icon
|
|
(lambda ()
|
|
(let ([frame (get-top-level-window)])
|
|
(when (is-a? frame frame:info<%>)
|
|
(send frame lock-status-changed)))))
|
|
'framework:update-lock-icon))])
|
|
(sequence (apply super-init args))))) |