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

no message

Browse Source 
original commit: 758d95bd56d2716bd3c1404bd94efc222b22d2da
This commit is contained in:
Robby Findler 2001-06-27 13:45:36 +00:00
parent 7561d5face
commit 88df9a66f3
12 changed files with 2336 additions and 2451 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

211
collects/framework/private/canvas.ss
View File

@ -15,81 +15,78 @@
(define basic<%> (interface ((class->interface editor-canvas%)))) (define basic<%> (interface ((class->interface editor-canvas%))))
(define basic-mixin (define basic-mixin
(mixin ((class->interface editor-canvas%)) (basic<%>) args (mixin ((class->interface editor-canvas%)) (basic<%>)
(sequence (super-instantiate ())))
(apply super-init args))))
(define info<%> (interface (basic<%>))) (define info<%> (interface (basic<%>)))
;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>))) ;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>)))
(define info-mixin (define info-mixin
(mixin (basic<%>) (info<%>) (parent [editor #f] . args) (mixin (basic<%>) (info<%>)
(inherit has-focus? get-top-level-window) (inherit has-focus? get-top-level-window)
(rename [super-on-focus on-focus] (rename [super-on-focus on-focus]
[super-set-editor set-editor]) [super-set-editor set-editor])
(override (override on-focus)
[on-focus [define on-focus
(lambda (on?) (lambda (on?)
(super-on-focus on?) (super-on-focus on?)
(send (get-top-level-window) set-info-canvas (and on? this)) (send (get-top-level-window) set-info-canvas (and on? this))
(when on? (when on?
(send (get-top-level-window) update-info)))] (send (get-top-level-window) update-info)))]
[set-editor [define set-editor
(lambda (m) (lambda (m)
(super-set-editor m) (super-set-editor m)
(let ([tlw (get-top-level-window)]) (let ([tlw (get-top-level-window)])
(when (eq? this (send tlw get-info-canvas)) (when (eq? this (send tlw get-info-canvas))
(send tlw update-info))))]) (send tlw update-info))))]
(sequence
(apply super-init parent editor args)
(unless (is-a? (get-top-level-window) frame:info<%>) (super-instantiate ())
(error 'canvas:text-info-mixin
"expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e"
(get-top-level-window)))
(when (has-focus?) (unless (is-a? (get-top-level-window) frame:info<%>)
(send (get-top-level-window) update-info))))) (error 'canvas:text-info-mixin
"expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e"
(get-top-level-window)))
(when (has-focus?)
(send (get-top-level-window) update-info))))
(define wide-snip<%> (interface (basic<%>) (define wide-snip<%> (interface (basic<%>)
recalc-snips recalc-snips
add-wide-snip add-wide-snip
add-tall-snip)) add-tall-snip))
;; wx: this need to collude with ;; wx: this needs to collude with
;; the edit, since the edit has the right callbacks. ;; the edit, since the edit has the right callbacks.
(define wide-snip-mixin (define wide-snip-mixin
(mixin (basic<%>) (wide-snip<%>) args (mixin (basic<%>) (wide-snip<%>)
(inherit get-editor) (inherit get-editor)
(rename [super-on-size on-size]) (rename [super-on-size on-size])
(private-field [define wide-snips null]
[wide-snips null] [define tall-snips null]
[tall-snips null]) [define update-snip-size
(private (lambda (width?)
[update-snip-size (lambda (s)
(lambda (width?) (let* ([width (box 0)]
(lambda (s) [height (box 0)]
(let* ([width (box 0)] [leftm (box 0)]
[height (box 0)] [rightm (box 0)]
[leftm (box 0)] [topm (box 0)]
[rightm (box 0)] [bottomm (box 0)]
[topm (box 0)] [left-edge-box (box 0)]
[bottomm (box 0)] [top-edge-box (box 0)]
[left-edge-box (box 0)] [snip-media (send s get-editor)]
[top-edge-box (box 0)] [edit (get-editor)]
[snip-media (send s get-editor)] [get-width
[edit (get-editor)] (let ([bl (box 0)]
[get-width [br (box 0)])
(let ([bl (box 0)] (lambda (s)
[br (box 0)]) (send edit get-snip-location s bl #f #f)
(lambda (s) (send edit get-snip-location s br #f #t)
(send edit get-snip-location s bl #f #f) (- (unbox br) (unbox bl))))]
(send edit get-snip-location s br #f #t) [calc-after-width
(- (unbox br) (unbox bl))))] (lambda (s)
[calc-after-width (+ 4 ;; this is compensate for an autowrapping bug
(lambda (s) (let loop ([s s])
(+ 4 ;; this is compensate for an autowrapping bug (cond
(let loop ([s s])
(cond
[(not s) 0] [(not s) 0]
[(member 'hard-newline (send s get-flags)) 0] [(member 'hard-newline (send s get-flags)) 0]
[(member 'newline (send s get-flags)) 0] [(member 'newline (send s get-flags)) 0]
@ -99,78 +96,76 @@
2 ;; for the caret 2 ;; for the caret
(loop (send s next))) (loop (send s next)))
0)]))))]) 0)]))))])
(when edit (when edit
(send edit (send edit
run-after-edit-sequence run-after-edit-sequence
(lambda () (lambda ()
(let ([admin (send edit get-admin)]) (let ([admin (send edit get-admin)])
(send admin get-view #f #f width height) (send admin get-view #f #f width height)
(send s get-margin leftm topm rightm bottomm) (send s get-margin leftm topm rightm bottomm)
;; when the width is to be maximized and there is a ;; when the width is to be maximized and there is a
;; newline just behind the snip, we know that the left ;; newline just behind the snip, we know that the left
;; edge is zero. Special case for efficiency in the ;; edge is zero. Special case for efficiency in the
;; console printer ;; console printer
(let ([fallback (let ([fallback
(lambda () (lambda ()
(send edit get-snip-location (send edit get-snip-location
s left-edge-box top-edge-box))]) s left-edge-box top-edge-box))])
(cond (cond
[(not width?) (fallback)] [(not width?) (fallback)]
[(let ([prev (send s previous)]) [(let ([prev (send s previous)])
(and prev (and prev
(member 'hard-newline (send prev get-flags)))) (member 'hard-newline (send prev get-flags))))
(set-box! left-edge-box 0)] (set-box! left-edge-box 0)]
[else (fallback)])) [else (fallback)]))
(if width? (if width?
(let* ([after-width (calc-after-width (send s next))] (let* ([after-width (calc-after-width (send s next))]
[snip-width (max 0 (- (unbox width) [snip-width (max 0 (- (unbox width)
(unbox left-edge-box) (unbox left-edge-box)
(unbox leftm) (unbox leftm)
(unbox rightm) (unbox rightm)
after-width after-width
;; this two is the space that ;; this two is the space that
;; the caret needs at the right of ;; the caret needs at the right of
;; a buffer. ;; a buffer.
2))]) 2))])
(send* s (send* s
(set-min-width snip-width) (set-min-width snip-width)
(set-max-width snip-width)) (set-max-width snip-width))
(when snip-media (when snip-media
(send snip-media set-max-width (send snip-media set-max-width
(if (send snip-media auto-wrap) (if (send snip-media auto-wrap)
snip-width snip-width
0)))) 0))))
(let ([snip-height (max 0 (- (unbox height) (let ([snip-height (max 0 (- (unbox height)
(unbox top-edge-box) (unbox top-edge-box)
(unbox topm) (unbox topm)
(unbox bottomm)))]) (unbox bottomm)))])
(send* s (send* s
(set-min-height snip-height) (set-min-height snip-height)
(set-max-height snip-height)))))))))))]) (set-max-height snip-height)))))))))))]
(public (public recalc-snips add-wide-snip add-tall-snip)
[recalc-snips [define recalc-snips
(lambda () (lambda ()
(for-each (update-snip-size #t) wide-snips) (for-each (update-snip-size #t) wide-snips)
(for-each (update-snip-size #f) tall-snips))]) (for-each (update-snip-size #f) tall-snips))]
(public [define add-wide-snip
[add-wide-snip (lambda (snip)
(lambda (snip) (set! wide-snips (cons snip wide-snips))
(set! wide-snips (cons snip wide-snips)) ((update-snip-size #t) snip))]
((update-snip-size #t) snip))] [define add-tall-snip
[add-tall-snip (lambda (snip)
(lambda (snip) (set! tall-snips (cons snip tall-snips))
(set! tall-snips (cons snip tall-snips)) ((update-snip-size #f) snip))]
((update-snip-size #f) snip))]) (override on-size)
(override [define on-size
[on-size
(lambda (width height) (lambda (width height)
(recalc-snips) (recalc-snips)
(super-on-size width height))]) (super-on-size width height))]
(sequence (super-instantiate ())))
(apply super-init args))))
(define basic% (basic-mixin editor-canvas%)) (define basic% (basic-mixin editor-canvas%))
(define info% (info-mixin basic%)) (define info% (info-mixin basic%))

518
collects/framework/private/editor.ss
View File

@ -38,15 +38,15 @@
save-file-out-of-date?)) save-file-out-of-date?))
(define basic-mixin (define basic-mixin
(mixin (editor<%>) (basic<%>) args (mixin (editor<%>) (basic<%>)
(inherit get-filename save-file (inherit get-filename save-file
refresh-delayed? refresh-delayed?
get-canvas get-canvas
get-max-width get-admin) get-max-width get-admin)
(rename [super-can-save-file? can-save-file?]) (rename [super-can-save-file? can-save-file?])
(override (override can-save-file?)
[can-save-file? [define can-save-file?
(lambda (filename format) (lambda (filename format)
(and (if (equal? filename (get-filename)) (and (if (equal? filename (get-filename))
(if (save-file-out-of-date?) (if (save-file-out-of-date?)
@ -59,14 +59,13 @@
(get-top-level-focus-window)) (get-top-level-focus-window))
#t) #t)
#t) #t)
(super-can-save-file? filename format)))]) (super-can-save-file? filename format)))]
(rename [super-after-save-file after-save-file] (rename [super-after-save-file after-save-file]
[super-after-load-file after-load-file]) [super-after-load-file after-load-file])
(private-field [define last-saved-file-time #f]
[last-saved-file-time #f]) (override after-save-file after-load-file)
(override [define after-save-file
[after-save-file
(lambda (sucess?) (lambda (sucess?)
(when sucess? (when sucess?
(let ([filename (get-filename)]) (let ([filename (get-filename)])
@ -75,7 +74,7 @@
(file-exists? filename) (file-exists? filename)
(file-or-directory-modify-seconds filename))))) (file-or-directory-modify-seconds filename)))))
(super-after-save-file sucess?))] (super-after-save-file sucess?))]
[after-load-file [define after-load-file
(lambda (sucess?) (lambda (sucess?)
(when sucess? (when sucess?
(let ([filename (get-filename)]) (let ([filename (get-filename)])
@ -83,55 +82,36 @@
(and filename (and filename
(file-exists? filename) (file-exists? filename)
(file-or-directory-modify-seconds filename))))) (file-or-directory-modify-seconds filename)))))
(super-after-load-file sucess?))]) (super-after-load-file sucess?))]
(public (public save-file-out-of-date?)
[save-file-out-of-date? [define save-file-out-of-date?
(lambda () (lambda ()
(and (and
last-saved-file-time last-saved-file-time
(let ([fn (get-filename)]) (let ([fn (get-filename)])
(and fn (and fn
(file-exists? fn) (file-exists? fn)
(let ([ms (file-or-directory-modify-seconds fn)]) (let ([ms (file-or-directory-modify-seconds fn)])
(< last-saved-file-time ms))))))]) (< last-saved-file-time ms))))))]
(private-field [define has-focus #f]
[has-focus #f])
(rename [super-on-focus on-focus]) (rename [super-on-focus on-focus])
(override (override on-focus)
[on-focus [define on-focus
(lambda (x) (lambda (x)
(set! has-focus x))]) (set! has-focus x))]
(public (public has-focus?)
[has-focus? [define has-focus?
(lambda () (lambda ()
has-focus)]) has-focus)]
(rename [super-begin-edit-sequence begin-edit-sequence] (public on-close get-top-level-window)
[super-end-edit-sequence end-edit-sequence]) [define on-close (lambda () (void))]
(private-field [define get-top-level-window
[edit-sequence-count 0]) (lambda ()
(override (let loop ([text this])
[begin-edit-sequence (let ([editor-admin (send text get-admin)])
(case-lambda (cond
[() (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 (lambda () (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<%>) [(is-a? editor-admin editor-snip-editor-admin<%>)
(let* ([snip (send editor-admin get-snip)] (let* ([snip (send editor-admin get-snip)]
[snip-admin (send snip get-admin)]) [snip-admin (send snip get-admin)])
@ -139,39 +119,37 @@
[(send text get-canvas) => (lambda (canvas) [(send text get-canvas) => (lambda (canvas)
(send canvas get-top-level-window))] (send canvas get-top-level-window))]
[else [else
#f]))))]) #f]))))]
(public [editing-this-file? (lambda () #f)]) (public editing-this-file?)
[define editing-this-file? (lambda () #f)]
(private-field
[edit-sequence-queue null] [define edit-sequence-queue null]
[edit-sequence-ht (make-hash-table)]) [define edit-sequence-ht (make-hash-table)]
[define in-local-edit-sequence? #f]
(private-field (public local-edit-sequence? run-after-edit-sequence extend-edit-sequence-queue)
[in-local-edit-sequence? #f]) [define local-edit-sequence? (lambda () in-local-edit-sequence?)]
(public [define run-after-edit-sequence
[local-edit-sequence? (lambda () in-local-edit-sequence?)] (case-lambda
[run-after-edit-sequence [(t) (run-after-edit-sequence t #f)]
(case-lambda [(t sym)
[(t) (run-after-edit-sequence t #f)] (unless (and (procedure? t)
[(t sym) (= 0 (procedure-arity t)))
(unless (and (procedure? t) (error 'editor:basic::run-after-edit-sequence
(= 0 (procedure-arity t))) "expected procedure of arity zero, got: ~s~n" t))
(error 'media-buffer::run-after-edit-sequence (unless (or (symbol? sym) (not sym))
"expected procedure of arity zero, got: ~s~n" t)) (error 'editor:basic::run-after-edit-sequence
(unless (or (symbol? sym) (not sym)) "expected second argument to be a symbol or #f, got: ~s~n"
(error 'media-buffer::run-after-edit-sequence sym))
"expected second argument to be a symbol, got: ~s~n" (if (refresh-delayed?)
sym)) (if in-local-edit-sequence?
(if (refresh-delayed?) (cond
(if in-local-edit-sequence?
(cond
[(symbol? sym) [(symbol? sym)
(hash-table-put! edit-sequence-ht sym t)] (hash-table-put! edit-sequence-ht sym t)]
[else (set! edit-sequence-queue [else (set! edit-sequence-queue
(cons t edit-sequence-queue))]) (cons t edit-sequence-queue))])
(let ([snip-admin (get-admin)]) (let ([snip-admin (get-admin)])
(cond (cond
[(not snip-admin) [(not snip-admin)
(t)] ;; refresh-delayed? is always #t when there is no admin. (t)] ;; refresh-delayed? is always #t when there is no admin.
[(is-a? snip-admin editor-snip-editor-admin<%>) [(is-a? snip-admin editor-snip-editor-admin<%>)
@ -182,113 +160,109 @@
(format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>" (format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>"
snip-admin)) snip-admin))
'(t)]))) '(t)])))
(t)) (t))
(void)])] (void)])]
[extend-edit-sequence-queue [define extend-edit-sequence-queue
(lambda (l ht) (lambda (l ht)
(hash-table-for-each ht (lambda (k t) (hash-table-for-each ht (lambda (k t)
(hash-table-put! (hash-table-put!
edit-sequence-ht edit-sequence-ht
k t))) k t)))
(set! edit-sequence-queue (append l edit-sequence-queue)))]) (set! edit-sequence-queue (append l edit-sequence-queue)))]
(rename (rename
[super-after-edit-sequence after-edit-sequence] [super-after-edit-sequence after-edit-sequence]
[super-on-edit-sequence on-edit-sequence]) [super-on-edit-sequence on-edit-sequence])
(override (override on-edit-sequence after-edit-sequence)
[on-edit-sequence [define on-edit-sequence
(lambda () (lambda ()
(super-on-edit-sequence) (super-on-edit-sequence)
(set! in-local-edit-sequence? #t))] (set! in-local-edit-sequence? #t))]
[after-edit-sequence [define after-edit-sequence
(lambda () (lambda ()
(set! in-local-edit-sequence? #f) (set! in-local-edit-sequence? #f)
(super-after-edit-sequence) (super-after-edit-sequence)
(let ([queue edit-sequence-queue] (let ([queue edit-sequence-queue]
[ht edit-sequence-ht] [ht edit-sequence-ht]
[find-enclosing-edit [find-enclosing-edit
(lambda (edit) (lambda (edit)
(let ([admin (send edit get-admin)]) (let ([admin (send edit get-admin)])
(cond (cond
[(is-a? admin editor-snip-editor-admin<%>) [(is-a? admin editor-snip-editor-admin<%>)
(send (send (send admin get-snip) get-admin) get-editor)] (send (send (send admin get-snip) get-admin) get-editor)]
[else #f])))]) [else #f])))])
(set! edit-sequence-queue null) (set! edit-sequence-queue null)
(set! edit-sequence-ht (make-hash-table)) (set! edit-sequence-ht (make-hash-table))
(let loop ([edit (find-enclosing-edit this)]) (let loop ([edit (find-enclosing-edit this)])
(cond (cond
[(and edit (not (send edit local-edit-sequence?))) [(and edit (not (send edit local-edit-sequence?)))
(loop (find-enclosing-edit edit))] (loop (find-enclosing-edit edit))]
[edit (send edit extend-edit-sequence-queue queue ht)] [edit (send edit extend-edit-sequence-queue queue ht)]
[else [else
(hash-table-for-each ht (lambda (k t) (t))) (hash-table-for-each ht (lambda (k t) (t)))
(for-each (lambda (t) (t)) queue)]))))]) (for-each (lambda (t) (t)) queue)]))))]
(override (override on-new-box)
[on-new-box [define on-new-box
(lambda (type) (lambda (type)
(cond (cond
[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
[else (make-object editor-snip% (make-object pasteboard:basic%))]))]) [else (make-object editor-snip% (make-object pasteboard:basic%))]))]
(override (override get-file put-file)
[get-file (lambda (d) [define get-file (lambda (d)
(parameterize ([finder:dialog-parent-parameter (parameterize ([finder:dialog-parent-parameter
(get-top-level-window)]) (get-top-level-window)])
(finder:get-file d)))] (finder:get-file d)))]
[put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter [define put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter
(get-top-level-window)]) (get-top-level-window)])
(finder:put-file f d)))]) (finder:put-file f d)))]
(sequence (super-instantiate ())))
(apply super-init args))))
(define -keymap<%> (interface (basic<%>) get-keymaps)) (define -keymap<%> (interface (basic<%>) get-keymaps))
(define keymap-mixin (define keymap-mixin
(mixin (basic<%>) (-keymap<%>) args (mixin (basic<%>) (-keymap<%>)
(public (public get-keymaps)
[get-keymaps [define get-keymaps
(lambda () (lambda ()
(list (keymap:get-global)))]) (list (keymap:get-global)))]
(inherit set-keymap) (inherit set-keymap)
(sequence
(apply super-init args) (super-instantiate ())
(let ([keymap (make-object keymap:aug-keymap%)]) (let ([keymap (make-object keymap:aug-keymap%)])
(set-keymap keymap) (set-keymap keymap)
(for-each (lambda (k) (send keymap chain-to-keymap k #f)) (for-each (lambda (k) (send keymap chain-to-keymap k #f))
(get-keymaps)))))) (get-keymaps)))))
(define autowrap<%> (interface (basic<%>))) (define autowrap<%> (interface (basic<%>)))
(define autowrap-mixin (define autowrap-mixin
(mixin (basic<%>) (autowrap<%>) args (mixin (basic<%>) (autowrap<%>)
(rename [super-on-close on-close]) (rename [super-on-close on-close])
(override (override on-close)
[on-close [define on-close
(lambda () (lambda ()
(remove-callback) (remove-callback)
(super-on-close))]) (super-on-close))]
(inherit auto-wrap) (inherit auto-wrap)
(sequence (super-instantiate ())
(apply super-init args) (auto-wrap
(auto-wrap (preferences:get
(preferences:get 'framework:auto-set-wrap?))
'framework:auto-set-wrap?))) [define remove-callback
(private-field (preferences:add-callback
[remove-callback 'framework:auto-set-wrap?
(preferences:add-callback (let ([autowrap-mixin-pref-callback
'framework:auto-set-wrap? (lambda (p v)
(let ([autowrap-mixin-pref-callback (auto-wrap v))])
(lambda (p v) autowrap-mixin-pref-callback))]))
(auto-wrap v))])
autowrap-mixin-pref-callback))])))
(define file<%> (interface (-keymap<%>))) (define file<%> (interface (-keymap<%>)))
(define file-mixin (define file-mixin
(mixin (-keymap<%>) (file<%>) args (mixin (-keymap<%>) (file<%>)
(inherit get-filename lock get-style-list (inherit get-filename lock get-style-list
is-modified? change-style set-modified is-modified? change-style set-modified
get-top-level-window) get-top-level-window)
@ -297,45 +271,44 @@
[super-get-keymaps get-keymaps] [super-get-keymaps get-keymaps]
[super-set-filename set-filename]) [super-set-filename set-filename])
(override (override editing-this-file?)
[editing-this-file? (lambda () #t)]) [define editing-this-file? (lambda () #t)]
(inherit get-canvases) (inherit get-canvases)
(private [define check-lock
[check-lock (lambda ()
(lambda () (let* ([filename (get-filename)]
(let* ([filename (get-filename)] [lock? (and filename
[lock? (and filename (file-exists? filename)
(file-exists? filename) (not (member
(not (member 'write
'write (file-or-directory-permissions
(file-or-directory-permissions filename))))])
filename))))]) (lock lock?)))]
(lock lock?)))] [define update-filename
[update-filename (lambda (name)
(lambda (name) (let ([filename (if name
(let ([filename (if name (file-name-from-path (normalize-path name))
(file-name-from-path (normalize-path name)) "")])
"")]) (for-each (lambda (canvas)
(for-each (lambda (canvas) (let ([tlw (send canvas get-top-level-window)])
(let ([tlw (send canvas get-top-level-window)]) (when (is-a? tlw frame:editor<%>)
(when (is-a? tlw frame:editor<%>) (send tlw set-label filename))))
(send tlw set-label filename)))) (get-canvases))))]
(get-canvases))))]) (override after-save-file after-load-file set-filename get-keymaps)
(override [define after-save-file
[after-save-file
(lambda (success) (lambda (success)
(when success (when success
(check-lock)) (check-lock))
(super-after-save-file success))] (super-after-save-file success))]
[after-load-file [define after-load-file
(lambda (sucessful?) (lambda (sucessful?)
(when sucessful? (when sucessful?
(check-lock)) (check-lock))
(super-after-load-file sucessful?))] (super-after-load-file sucessful?))]
[set-filename [define set-filename
(case-lambda (case-lambda
[(name) (set-filename name #f)] [(name) (set-filename name #f)]
[(name temp?) [(name temp?)
@ -343,11 +316,10 @@
(unless temp? (unless temp?
(update-filename name))])] (update-filename name))])]
[get-keymaps [define get-keymaps
(lambda () (lambda ()
(cons (keymap:get-file) (super-get-keymaps)))]) (cons (keymap:get-file) (super-get-keymaps)))]
(sequence (super-instantiate ())))
(apply super-init args))))
(define backup-autosave<%> (define backup-autosave<%>
(interface (basic<%>) (interface (basic<%>)
@ -356,31 +328,29 @@
do-autosave do-autosave
remove-autosave)) remove-autosave))
; what about checking the autosave files when a file is opened? ; what about checking the autosave files when a file is opened?
(define backup-autosave-mixin (define backup-autosave-mixin
(mixin (basic<%>) (backup-autosave<%>) args (mixin (basic<%>) (backup-autosave<%>)
(inherit is-modified? get-filename save-file) (inherit is-modified? get-filename save-file)
(rename [super-on-save-file on-save-file] (rename [super-on-save-file on-save-file]
[super-on-change on-change] [super-on-change on-change]
[super-on-close on-close] [super-on-close on-close]
[super-set-modified set-modified]) [super-set-modified set-modified])
(private-field [define auto-saved-name #f]
[auto-saved-name #f] [define auto-save-out-of-date? #t]
[auto-save-out-of-date? #t] [define auto-save-error? #f]
[auto-save-error? #f]) [define file-old?
(private (lambda (filename)
[file-old? (if (and filename
(lambda (filename) (file-exists? filename))
(if (and filename (let ([modified-seconds (file-or-directory-modify-seconds filename)]
(file-exists? filename)) [old-seconds (- (current-seconds) (* 7 24 60 60))])
(let ([modified-seconds (file-or-directory-modify-seconds filename)] (< modified-seconds old-seconds))
[old-seconds (- (current-seconds) (* 7 24 60 60))]) #t))]
(< modified-seconds old-seconds)) (public backup?)
#t))]) [define backup? (lambda () #t)]
(public (override on-save-file on-close on-change set-modified)
[backup? (lambda () #t)]) [define on-save-file
(override
[on-save-file
(lambda (name format) (lambda (name format)
(super-on-save-file name format) (super-on-save-file name format)
(set! auto-save-error? #f) (set! auto-save-error? #f)
@ -394,75 +364,73 @@
(delete-file back-name)) (delete-file back-name))
(with-handlers ([(lambda (x) #t) void]) (with-handlers ([(lambda (x) #t) void])
(copy-file name back-name))))))] (copy-file name back-name))))))]
[on-close [define on-close
(lambda () (lambda ()
(super-on-close) (super-on-close)
(remove-autosave) (remove-autosave)
(set! do-autosave? #f))] (set! do-autosave? #f))]
[on-change [define on-change
(lambda () (lambda ()
(super-on-change) (super-on-change)
(set! auto-save-out-of-date? #t))] (set! auto-save-out-of-date? #t))]
[set-modified [define set-modified
(lambda (modified?) (lambda (modified?)
(when auto-saved-name (when auto-saved-name
(if modified? (if modified?
(set! auto-save-out-of-date? #t) (set! auto-save-out-of-date? #t)
(remove-autosave))) (remove-autosave)))
(super-set-modified modified?))]) (super-set-modified modified?))]
(private-field [define do-autosave? #t]
[do-autosave? #t]) (public autosave? do-autosave remove-autosave)
(public [define autosave? (lambda () do-autosave?)]
[autosave? (lambda () do-autosave?)] [define do-autosave
[do-autosave (lambda ()
(lambda () (when (and (autosave?)
(when (and (autosave?) (not auto-save-error?)
(not auto-save-error?) (is-modified?)
(is-modified?) (or (not auto-saved-name)
(or (not auto-saved-name) auto-save-out-of-date?))
auto-save-out-of-date?)) (let* ([orig-name (get-filename)]
(let* ([orig-name (get-filename)] [old-auto-name auto-saved-name]
[old-auto-name auto-saved-name] [auto-name (path-utils:generate-autosave-name orig-name)]
[auto-name (path-utils:generate-autosave-name orig-name)] [success (save-file auto-name 'copy)])
[success (save-file auto-name 'copy)]) (if success
(if success (begin
(begin (when old-auto-name
(when old-auto-name (delete-file old-auto-name))
(delete-file old-auto-name)) (set! auto-saved-name auto-name)
(set! auto-saved-name auto-name) (set! auto-save-out-of-date? #f))
(set! auto-save-out-of-date? #f)) (begin
(begin (message-box
(message-box "Warning"
"Warning" (format "Error autosaving ~s.~n~a~n~a"
(format "Error autosaving ~s.~n~a~n~a" (or orig-name "Untitled")
(or orig-name "Untitled") "Autosaving is turned off"
"Autosaving is turned off" "until the file is saved."))
"until the file is saved.")) (set! auto-save-error? #t))))))]
(set! auto-save-error? #t))))))] [define remove-autosave
[remove-autosave (lambda ()
(lambda () (when auto-saved-name
(when auto-saved-name (when (file-exists? auto-saved-name)
(when (file-exists? auto-saved-name) (delete-file auto-saved-name))
(delete-file auto-saved-name)) (set! auto-saved-name #f)))]
(set! auto-saved-name #f)))]) (super-instantiate ())
(sequence (autosave:register this)))
(apply super-init args)
(autosave:register this))))
(define info<%> (interface (basic<%>))) (define info<%> (interface (basic<%>)))
(define info-mixin (define info-mixin
(mixin (basic<%>) (info<%>) args (mixin (basic<%>) (info<%>)
(inherit get-top-level-window run-after-edit-sequence) (inherit get-top-level-window run-after-edit-sequence)
(rename [super-lock lock]) (rename [super-lock lock])
(override (override lock)
[lock [define lock
(lambda (x) (lambda (x)
(super-lock x) (super-lock x)
(run-after-edit-sequence (run-after-edit-sequence
(rec send-frame-update-lock-icon (rec send-frame-update-lock-icon
(lambda () (lambda ()
(let ([frame (get-top-level-window)]) (let ([frame (get-top-level-window)])
(when (is-a? frame frame:info<%>) (when (is-a? frame frame:info<%>)
(send frame lock-status-changed))))) (send frame lock-status-changed)))))
'framework:update-lock-icon))]) 'framework:update-lock-icon))]
(sequence (apply super-init args))))))) (super-instantiate ()))))))

1456
collects/framework/private/frame.ss
View File

File diff suppressed because it is too large Load Diff

152
collects/framework/private/gen-standard-menus.ss
View File

@ -1,44 +1,54 @@
(module gen-standard-menus mzscheme (module gen-standard-menus mzscheme
(require (lib "pretty.ss")) (require (lib "pretty.ss"))
(require (lib "list.ss")) (require (lib "list.ss"))
(require (lib "standard-menus-items.ss" "framework" "private")) (require "standard-menus-items.ss")
;; build-before-super-item-clause : an-item -> sexp ;; build-before-super-item-clause : an-item -> (listof clause)
;; calculates a `public' class expression
(define build-before-super-item-clause (define build-before-super-item-clause
(lambda (item) (lambda (item)
`(public (list
[,(an-item->callback-name item) `(public ,(an-item->callback-name item)
,(an-item->get-item-name item)
,(an-item->string-name item)
,(an-item->help-string-name item)
,(an-item->on-demand-name item)
,(an-item->create-menu-item-name item))
`[define ,(an-item->callback-name item)
,(or (an-item-proc item) `(lambda (x y) (void)))] ,(or (an-item-proc item) `(lambda (x y) (void)))]
[,(an-item->get-item-name item) `[define ,(an-item->get-item-name item)
(lambda () ,(an-item->item-name item))] (lambda () ,(an-item->item-name item))]
[,(an-item->string-name item) `[define ,(an-item->string-name item)
(lambda () "")] (lambda () "")]
[,(an-item->help-string-name item) `[define ,(an-item->help-string-name item)
(lambda () ,(an-item-help-string item))] (lambda () ,(an-item-help-string item))]
[,(an-item->on-demand-name item) `[define ,(an-item->on-demand-name item)
,(an-item-on-demand item)] ,(an-item-on-demand item)]
[,(an-item->create-menu-item-name item) `[define ,(an-item->create-menu-item-name item)
(lambda () ,(not (not (an-item-proc item))))]))) (lambda () ,(not (not (an-item-proc item))))])))
;; build-before-super-clause : ((X -> sym) (X sexp) -> X -> (listof clause))
(define build-before-super-clause (define build-before-super-clause
(lambda (->name -procedure) (lambda (->name -procedure)
(lambda (obj) (lambda (obj)
`(public (list `(public ,(->name obj))
[,(->name obj) `[define ,(->name obj)
,(case (-procedure obj) ,(case (-procedure obj)
[(nothing) '(lambda (menu) (void))] [(nothing) '(lambda (menu) (void))]
[(separator) '(lambda (menu) (make-object separator-menu-item% menu))])])))) [(separator) '(lambda (menu) (make-object separator-menu-item% menu))])]))))
;; build-before-super-between-clause : between -> (listof clause)
(define build-before-super-between-clause (define build-before-super-between-clause
(build-before-super-clause (build-before-super-clause
between->name between->name
between-procedure)) between-procedure))
;; build-before-super-before/after-clause : before/after -> (listof clause)
(define build-before-super-before/after-clause (define build-before-super-before/after-clause
(build-before-super-clause (build-before-super-clause
before/after->name before/after->name
before/after-procedure)) before/after-procedure))
;; build-after-super-item-clause : an-item -> (list clause)
(define (build-after-super-item-clause item) (define (build-after-super-item-clause item)
(let* ([callback-name (an-item->callback-name item)] (let* ([callback-name (an-item->callback-name item)]
[create-menu-item-name (an-item->create-menu-item-name item)] [create-menu-item-name (an-item->create-menu-item-name item)]
@ -53,59 +63,58 @@
(if (string=? special "") (if (string=? special "")
(string-append base suffix) (string-append base suffix)
(string-append base " " special suffix))))]) (string-append base " " special suffix))))])
`(private-field (list `(define
[,(an-item->item-name item) ,(an-item->item-name item)
(and (,create-menu-item-name) (and (,create-menu-item-name)
(make-object (class100 (get-menu-item%) args (instantiate (get-menu-item%) ()
(rename [super-on-demand on-demand]) (label ,(join menu-before-string menu-after-string
(override `(,(an-item->string-name item))))
[on-demand (parent ,(menu-item-menu-name item))
(lambda () (callback (let ([,callback-name (lambda (item evt) (,callback-name item evt))])
(,(an-item->on-demand-name item) this) ,callback-name))
(super-on-demand))]) (shortcut ,key)
(sequence (help (,(an-item->help-string-name item)))
(apply super-init args))) (demand-callback (lambda (menu-item) (,(an-item->on-demand-name item) menu-item)))))))))
,(join menu-before-string menu-after-string
`(,(an-item->string-name item)))
,(menu-item-menu-name item)
(let ([,callback-name (lambda (item evt) (,callback-name item evt))])
,callback-name)
,key
(,(an-item->help-string-name item))))])))
;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause))
(define build-after-super-clause (define build-after-super-clause
(lambda (->name) (lambda (->name)
(lambda (between/after) (lambda (between/after)
`(sequence (list
(,(->name between/after) `(,(->name between/after)
(,(menu-name->get-menu-name between/after))))))) (,(menu-name->get-menu-name between/after)))))))
;; build-after-super-between-clause : between -> (listof clause)
(define build-after-super-between-clause (build-after-super-clause between->name)) (define build-after-super-between-clause (build-after-super-clause between->name))
;; build-after-super-before/after-clause : before/after -> (listof clause)
(define build-after-super-before/after-clause (build-after-super-clause before/after->name)) (define build-after-super-before/after-clause (build-after-super-clause before/after->name))
;; build-after-super-generic-clause : generic -> (listof clause)
(define (build-after-super-generic-clause x) (define (build-after-super-generic-clause x)
(cond (cond
[(generic-private-field? x) [(generic-private-field? x)
`(private-field (list `(define
[,(generic-name x) ,(generic-name x)
,(generic-initializer x)])] ,(generic-initializer x)))]
[(generic-override? x) [(generic-override? x)
`(rename [,(string->symbol (format "super-~a" (generic-name x))) (list `(rename [,(string->symbol (format "super-~a" (generic-name x)))
,(generic-name x)])] ,(generic-name x)]))]
[(generic-method? x) [(generic-method? x)
`(sequence (void))])) null]))
;; build-before-super-generic-clause : generic -> (listof clause)
(define (build-before-super-generic-clause generic) (define (build-before-super-generic-clause generic)
(cond (cond
[(generic-private-field? generic) [(generic-private-field? generic)
`(sequence (void))] null]
[(generic-override? generic) [(generic-override? generic)
`(override (list `(override ,(generic-name generic))
[,(generic-name generic) `[define ,(generic-name generic)
,(generic-initializer generic)])] ,(generic-initializer generic)])]
[(generic-method? generic) [(generic-method? generic)
`(public (list `(public ,(generic-name generic) )
[,(generic-name generic) `[define ,(generic-name generic)
,(generic-initializer generic)])])) ,(generic-initializer generic)])]))
(define standard-menus.ss-filename (build-path (collection-path "framework" "private") "standard-menus.ss")) (define standard-menus.ss-filename (build-path (collection-path "framework" "private") "standard-menus.ss"))
@ -141,10 +150,9 @@
(pretty-print (pretty-print
`(define standard-menus-mixin `(define standard-menus-mixin
(mixin (basic<%>) (standard-menus<%>) args (mixin (basic<%>) (standard-menus<%>)
(inherit on-menu-char on-traverse-char) (inherit on-menu-char on-traverse-char)
(private-field (define remove-prefs-callback
[remove-prefs-callback
(preferences:add-callback (preferences:add-callback
'framework:menu-bindings 'framework:menu-bindings
(lambda (p v) (lambda (p v)
@ -157,26 +165,26 @@
(when (is-a? menu menu:can-restore<%>) (when (is-a? menu menu:can-restore<%>)
(if v (if v
(send menu restore-keybinding) (send menu restore-keybinding)
(send menu set-shortcut #f)))])))))]) (send menu set-shortcut #f)))]))))))
(inherit get-menu-bar show can-close? get-edit-target-object) (inherit get-menu-bar show can-close? get-edit-target-object)
,@(map (lambda (x) ,@(apply append (map (lambda (x)
(cond (cond
[(between? x) (build-before-super-between-clause x)] [(between? x) (build-before-super-between-clause x)]
[(or (after? x) (before? x)) (build-before-super-before/after-clause x)] [(or (after? x) (before? x)) (build-before-super-before/after-clause x)]
[(an-item? x) (build-before-super-item-clause x)] [(an-item? x) (build-before-super-item-clause x)]
[(generic? x) (build-before-super-generic-clause x)] [(generic? x) (build-before-super-generic-clause x)]
[else (printf "~a~n" x)])) [else (printf "~a~n" x)]))
items) items))
(sequence (apply super-init args)) (super-instantiate ())
,@(map (lambda (x) ,@(apply append (map (lambda (x)
(cond (cond
[(between? x) (build-after-super-between-clause x)] [(between? x) (build-after-super-between-clause x)]
[(an-item? x) (build-after-super-item-clause x)] [(an-item? x) (build-after-super-item-clause x)]
[(or (after? x) (before? x)) (build-after-super-before/after-clause x)] [(or (after? x) (before? x)) (build-after-super-before/after-clause x)]
[(generic? x) (build-after-super-generic-clause x)])) [(generic? x) (build-after-super-generic-clause x)]))
items) items))
(sequence (reorder-menus this)))) (reorder-menus this)))
port)) port))
'text 'text
'truncate)) 'truncate))

71
collects/framework/private/keymap.ss
View File

@ -26,53 +26,52 @@
get-map-function-table/ht)) get-map-function-table/ht))
(define aug-keymap-mixin (define aug-keymap-mixin
(mixin ((class->interface keymap%)) (aug-keymap<%>) args (mixin ((class->interface keymap%)) (aug-keymap<%>)
(private-field (define chained-keymaps null)
[chained-keymaps null]) (public get-chained-keymaps)
(public [define get-chained-keymaps
[get-chained-keymaps (lambda ()
(lambda () chained-keymaps)]
chained-keymaps)])
(rename [super-chain-to-keymap chain-to-keymap]) (rename [super-chain-to-keymap chain-to-keymap])
(override (override chain-to-keymap)
[chain-to-keymap [define chain-to-keymap
(lambda (keymap prefix?) (lambda (keymap prefix?)
(super-chain-to-keymap keymap prefix?) (super-chain-to-keymap keymap prefix?)
(set! chained-keymaps (set! chained-keymaps
(if prefix? (if prefix?
(cons keymap chained-keymaps) (cons keymap chained-keymaps)
(append chained-keymaps (list keymap)))))]) (append chained-keymaps (list keymap)))))]
(private-field [function-table (make-hash-table)]) [define function-table (make-hash-table)]
(public [get-function-table (lambda () function-table)]) (public get-function-table)
[define get-function-table (lambda () function-table)]
(rename [super-map-function map-function]) (rename [super-map-function map-function])
(override (override map-function)
[map-function [define map-function
(lambda (keyname fname) (lambda (keyname fname)
(super-map-function (canonicalize-keybinding-string keyname) fname) (super-map-function (canonicalize-keybinding-string keyname) fname)
(hash-table-put! function-table (string->symbol keyname) fname))]) (hash-table-put! function-table (string->symbol keyname) fname))]
(public (public get-map-function-table get-map-function-table/ht)
[get-map-function-table [define get-map-function-table
(lambda () (lambda ()
(get-map-function-table/ht (make-hash-table)))] (get-map-function-table/ht (make-hash-table)))]
[get-map-function-table/ht [define get-map-function-table/ht
(lambda (table) (lambda (table)
(hash-table-for-each (hash-table-for-each
function-table function-table
(lambda (keyname fname) (lambda (keyname fname)
(unless (hash-table-get table keyname (lambda () #f)) (unless (hash-table-get table keyname (lambda () #f))
(hash-table-put! table keyname fname)))) (hash-table-put! table keyname fname))))
(for-each (for-each
(lambda (chained-keymap) (lambda (chained-keymap)
(when (is-a? chained-keymap aug-keymap<%>) (when (is-a? chained-keymap aug-keymap<%>)
(send chained-keymap get-map-function-table/ht table))) (send chained-keymap get-map-function-table/ht table)))
chained-keymaps) chained-keymaps)
table)]) table)]
(sequence (super-instantiate ())))
(apply super-init args))))
(define aug-keymap% (aug-keymap-mixin keymap%)) (define aug-keymap% (aug-keymap-mixin keymap%))

25
collects/framework/private/menu.ss
View File

@ -18,20 +18,19 @@
restore-keybinding)) restore-keybinding))
(define can-restore-mixin (define can-restore-mixin
(mixin (selectable-menu-item<%>) (can-restore<%>) args (mixin (selectable-menu-item<%>) (can-restore<%>)
(inherit set-shortcut get-shortcut) (inherit set-shortcut get-shortcut)
(private-field [define saved-shortcut 'not-yet]
[saved-shortcut 'not-yet]) (public restore-keybinding)
(public [define restore-keybinding
[restore-keybinding (lambda ()
(lambda () (unless (eq? saved-shortcut 'not-yet)
(unless (eq? saved-shortcut 'not-yet) (set-shortcut saved-shortcut)))]
(set-shortcut saved-shortcut)))])
(sequence (super-instantiate ())
(apply super-init args) (set! saved-shortcut (get-shortcut))
(set! saved-shortcut (get-shortcut)) (unless (preferences:get 'framework:menu-bindings)
(unless (preferences:get 'framework:menu-bindings) (set-shortcut #f))))
(set-shortcut #f)))))
(define can-restore-menu-item% (can-restore-mixin menu-item%)) (define can-restore-menu-item% (can-restore-mixin menu-item%))
(define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%))))) (define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%)))))

310
collects/framework/private/panel.ss
View File

@ -27,21 +27,21 @@
(define single<%> (interface (area-container<%>) active-child)) (define single<%> (interface (area-container<%>) active-child))
(define single-mixin (define single-mixin
(mixin (area-container<%>) (single<%>) args (mixin (area-container<%>) (single<%>)
(inherit get-alignment) (inherit get-alignment)
(rename [super-after-new-child after-new-child]) (rename [super-after-new-child after-new-child])
(override (override after-new-child container-size place-children)
[after-new-child [define after-new-child
(lambda (c) (lambda (c)
(if current-active-child (if current-active-child
(send c show #f) (send c show #f)
(set! current-active-child c)))] (set! current-active-child c)))]
[container-size [define container-size
(lambda (l) (lambda (l)
(if (null? l) (if (null? l)
(values 0 0) (values 0 0)
(values (apply max (map car l)) (apply max (map cadr l)))))] (values (apply max (map car l)) (apply max (map cadr l)))))]
[place-children [define place-children
(lambda (l width height) (lambda (l width height)
(let-values ([(h-align-spec v-align-spec) (get-alignment)]) (let-values ([(h-align-spec v-align-spec) (get-alignment)])
(let ([align (let ([align
@ -61,32 +61,31 @@
(values 0 height) (values 0 height)
(values (align height v-align-spec min-height) min-height))]) (values (align height v-align-spec min-height) min-height))])
(list x y this-width this-height))) (list x y this-width this-height)))
l))))]) l))))]
(inherit get-children) (inherit get-children)
(private-field [current-active-child #f]) [define current-active-child #f]
(public (public active-child)
[active-child [define active-child
(case-lambda (case-lambda
[() current-active-child] [() current-active-child]
[(x) [(x)
(unless (memq x (get-children)) (unless (memq x (get-children))
(error 'active-child "got a panel that is not a child: ~e" x)) (error 'active-child "got a panel that is not a child: ~e" x))
(unless (eq? x current-active-child) (unless (eq? x current-active-child)
(for-each (lambda (x) (send x show #f)) (for-each (lambda (x) (send x show #f))
(get-children)) (get-children))
(set! current-active-child x) (set! current-active-child x)
(send current-active-child show #t))])]) (send current-active-child show #t))])]
(sequence (super-instantiate ())))
(apply super-init args))))
(define single-window<%> (interface (single<%> window<%>))) (define single-window<%> (interface (single<%> window<%>)))
(define single-window-mixin (define single-window-mixin
(mixin (single<%> window<%>) (single-window<%>) args (mixin (single<%> window<%>) (single-window<%>)
(inherit get-client-size get-size) (inherit get-client-size get-size)
(rename [super-container-size container-size]) (rename [super-container-size container-size])
(override (override container-size)
[container-size [define container-size
(lambda (l) (lambda (l)
(let-values ([(super-width super-height) (super-container-size l)] (let-values ([(super-width super-height) (super-container-size l)]
[(client-width client-height) (get-client-size)] [(client-width client-height) (get-client-size)]
@ -97,9 +96,8 @@
(values (values
(calc-size super-width client-width window-width) (calc-size super-width client-width window-width)
(calc-size super-height client-height window-height))))]) (calc-size super-height client-height window-height))))]
(sequence (super-instantiate ())))
(apply super-init args))))
(define multi-view<%> (define multi-view<%>
(interface (area-container<%>) (interface (area-container<%>)
@ -108,63 +106,59 @@
collapse)) collapse))
(define multi-view-mixin (define multi-view-mixin
(mixin (area-container<%>) (multi-view<%>) (_parent _editor) (mixin (area-container<%>) (multi-view<%>)
(init-field parent editor)
(private-field [parent _parent] (public get-editor-canvas% get-vertical% get-horizontal%)
[editor _editor]) [define get-editor-canvas%
(lambda ()
(public editor-canvas%)]
[get-editor-canvas% [define get-vertical%
(lambda () (lambda ()
editor-canvas%)] vertical-panel%)]
[get-vertical% [define get-horizontal%
(lambda () (lambda ()
vertical-panel%)] horizontal-panel%)]
[get-horizontal%
(lambda ()
horizontal-panel%)])
(private (public split-vertically split-horizontally)
[split
(lambda (p%) [define split
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] (lambda (p%)
[ec% (get-editor-canvas%)]) (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
(when (and canvas [ec% (get-editor-canvas%)])
(is-a? canvas ec%) (when (and canvas
(eq? (send canvas get-editor) editor)) (is-a? canvas ec%)
(let ([p (send canvas get-parent)]) (eq? (send canvas get-editor) editor))
(send p change-children (lambda (x) null)) (let ([p (send canvas get-parent)])
(let ([pc (make-object p% p)]) (send p change-children (lambda (x) null))
(send (make-object ec% (make-object vertical-panel% pc) editor) focus) (let ([pc (make-object p% p)])
(make-object ec% (make-object vertical-panel% pc) editor))))))]) (send (make-object ec% (make-object vertical-panel% pc) editor) focus)
(make-object ec% (make-object vertical-panel% pc) editor))))))]
[define split-vertically
(lambda ()
(split (get-vertical%)))]
[define split-horizontally
(lambda ()
(split (get-horizontal%)))]
(public collapse)
(define collapse
(lambda ()
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
[ec% (get-editor-canvas%)])
(when (and canvas
(is-a? canvas ec%)
(eq? (send canvas get-editor) editor))
(let ([p (send canvas get-parent)])
(if (eq? p this)
(bell)
(let* ([sp (send p get-parent)]
[p-to-remain (send sp get-parent)])
(send p-to-remain change-children (lambda (x) null))
(send (make-object ec% p-to-remain editor) focus))))))))
(public
[collapse
(lambda ()
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
[ec% (get-editor-canvas%)])
(when (and canvas
(is-a? canvas ec%)
(eq? (send canvas get-editor) editor))
(let ([p (send canvas get-parent)])
(if (eq? p this)
(bell)
(let* ([sp (send p get-parent)]
[p-to-remain (send sp get-parent)])
(send p-to-remain change-children (lambda (x) null))
(send (make-object ec% p-to-remain editor) focus)))))))])
(public (super-instantiate () (parent parent))
[split-vertically (make-object (get-editor-canvas%) this editor)))
(lambda ()
(split (get-vertical%)))]
[split-horizontally
(lambda ()
(split (get-horizontal%)))])
(sequence
(super-init parent)
(make-object (get-editor-canvas%) this editor))))
(define single% (single-window-mixin (single-mixin panel%))) (define single% (single-window-mixin (single-mixin panel%)))
(define single-pane% (single-mixin pane%)) (define single-pane% (single-mixin pane%))
@ -377,30 +371,29 @@
set-percentages)) set-percentages))
(define vertical-resizable-mixin (define vertical-resizable-mixin
(mixin (area-container<%>) (vertical-resizable<%>) args (mixin (area-container<%>) (vertical-resizable<%>)
(inherit get-children) (inherit get-children)
(private-field [thumb-canvas #f]) (define thumb-canvas #f)
(public (public on-between-click)
[on-between-click [define on-between-click
(lambda (num pct) (lambda (num pct)
(void))]) (void))]
;; preserve the invariant that the thumb-canvas is ;; preserve the invariant that the thumb-canvas is
;; the first child and that the thumb-canvas percentages ;; the first child and that the thumb-canvas percentages
;; match up with the children ;; match up with the children
(private [define fix-percentage-length
[fix-percentage-length (lambda (children)
(lambda (children) (let ([len (length children)])
(let ([len (length children)]) (unless (= (- len 1) (length (send thumb-canvas get-percentages)))
(unless (= (- len 1) (length (send thumb-canvas get-percentages))) (send thumb-canvas set-percentages
(send thumb-canvas set-percentages (build-list
(build-list (- len 1)
(- len 1) (lambda (i) (/ 1 (- len 1))))))))]
(lambda (i) (/ 1 (- len 1))))))))])
(rename [super-change-children change-children]) (rename [super-change-children change-children])
(override (override change-children after-new-child)
[change-children [define change-children
(lambda (f) (lambda (f)
(super-change-children (super-change-children
(lambda (l) (lambda (l)
@ -413,13 +406,13 @@
(fix-percentage-length res) (fix-percentage-length res)
res) res)
(f l)))))] (f l)))))]
[after-new-child [define after-new-child
(lambda (child) (lambda (child)
(when thumb-canvas (when thumb-canvas
(fix-percentage-length (get-children))))]) (fix-percentage-length (get-children))))]
(override (override container-size place-children)
[container-size [define container-size
(lambda (_lst) (lambda (_lst)
;; remove the thumb canvas from the computation ;; remove the thumb canvas from the computation
(let ([lst (if (null? _lst) null (cdr _lst))]) (let ([lst (if (null? _lst) null (cdr _lst))])
@ -431,59 +424,58 @@
(+ (send thumb-canvas min-width) (+ (send thumb-canvas min-width)
(apply max (map car lst)))]) (apply max (map car lst)))])
(apply + (map cadr lst)))))] (apply + (map cadr lst)))))]
[place-children [define place-children
(lambda (_infos width height) (lambda (_infos width height)
(cond (cond
[(null? _infos) null] [(null? _infos) null]
[(null? (cdr _infos)) (list (list 0 0 0 0))] [(null? (cdr _infos)) (list (list 0 0 0 0))]
[(null? (cdr (cdr _infos))) [(null? (cdr (cdr _infos)))
(list (list 0 0 0 0) (list (list 0 0 0 0)
(list 0 0 width height))] (list 0 0 width height))]
[else [else
(fix-percentage-length (get-children)) (fix-percentage-length (get-children))
(cons (cons
(list (- width (send thumb-canvas min-width)) 0 (list (- width (send thumb-canvas min-width)) 0
(send thumb-canvas min-width) (send thumb-canvas min-width)
height) height)
(let ([main-width (- width (send thumb-canvas min-width))] (let ([main-width (- width (send thumb-canvas min-width))]
[show-error [show-error
(lambda () (lambda ()
(error 'panel:vertical-resizable-mixin:place-children (error 'panel:vertical-resizable-mixin:place-children
"expected children list(~a) to be one longer than percentage list(~a), info: ~e percentages ~e" "expected children list(~a) to be one longer than percentage list(~a), info: ~e percentages ~e"
(length _infos) (length (send thumb-canvas get-percentages)) (length _infos) (length (send thumb-canvas get-percentages))
_infos (send thumb-canvas get-percentages)))]) _infos (send thumb-canvas get-percentages)))])
(let loop ([percentages (send thumb-canvas get-percentages)] (let loop ([percentages (send thumb-canvas get-percentages)]
[infos (cdr _infos)] [infos (cdr _infos)]
[y 0]) [y 0])
(cond (cond
[(null? percentages) [(null? percentages)
(unless (null? infos) (show-error)) (unless (null? infos) (show-error))
null] null]
[(null? (cdr percentages)) [(null? (cdr percentages))
(when (null? infos) (show-error)) (when (null? infos) (show-error))
(unless (null? (cdr infos)) (show-error)) (unless (null? (cdr infos)) (show-error))
(list (list 0 y main-width (- height y)))] (list (list 0 y main-width (- height y)))]
[else [else
(when (null? infos) (show-error)) (when (null? infos) (show-error))
(let* ([info (car infos)] (let* ([info (car infos)]
[percentage (car percentages)] [percentage (car percentages)]
[this-space (floor (* percentage height))]) [this-space (floor (* percentage height))])
(cons (list 0 y main-width this-space) (cons (list 0 y main-width this-space)
(loop (cdr percentages) (loop (cdr percentages)
(cdr infos) (cdr infos)
(+ y this-space))))]))))]))]) (+ y this-space))))]))))]))]
(inherit reflow-container get-top-level-window set-alignment get-alignment) (inherit reflow-container get-top-level-window set-alignment get-alignment)
(public (public on-percentage-change get-percentages set-percentages)
[on-percentage-change (lambda () (void))] [define on-percentage-change (lambda () (void))]
[get-percentages (lambda () (send thumb-canvas get-percentages))] [define get-percentages (lambda () (send thumb-canvas get-percentages))]
[set-percentages [define set-percentages
(lambda (p) (lambda (p)
(send thumb-canvas set-percentages p) (send thumb-canvas set-percentages p)
(refresh-panel this))]) (refresh-panel this))]
(sequence (super-instantiate ())
(apply super-init args) (set! thumb-canvas (make-object thumb-canvas% this))))
(set! thumb-canvas (make-object thumb-canvas% this)))))
(define vertical-resizable% (vertical-resizable-mixin panel%)) (define vertical-resizable% (vertical-resizable-mixin panel%))
(define vertical-resizable-pane% (vertical-resizable-mixin pane%))))) (define vertical-resizable-pane% (vertical-resizable-mixin pane%)))))

1344
collects/framework/private/scheme.ss
View File

File diff suppressed because it is too large Load Diff

3
collects/framework/private/sig.ss
View File

@ -131,18 +131,21 @@
(define-signature framework:text^ (define-signature framework:text^
(basic<%> (basic<%>
hide/selection<%>
searching<%> searching<%>
return<%> return<%>
info<%> info<%>
clever-file-format<%> clever-file-format<%>
basic-mixin basic-mixin
hide/selection-mixin
searching-mixin searching-mixin
return-mixin return-mixin
info-mixin info-mixin
clever-file-format-mixin clever-file-format-mixin
basic% basic%
hide/selection%
keymap% keymap%
return% return%
autowrap% autowrap%

35
collects/framework/private/standard-menus-items.ss
View File

@ -1,36 +1,23 @@
(module standard-menus-items mzscheme (module standard-menus-items mzscheme
(provide (provide
;(struct generic (name initializer)) (struct generic (name initializer))
generic? generic-name generic-initializer
;(generic/docs (documentation)) (struct generic/docs (documentation))
generic/docs? generic/docs-documentation
;(struct generic-override ()) (struct generic-override ())
generic-override? (struct generic-method ())
;(struct generic-method ()) (struct generic-private-field ())
generic-method?
;(struct generic-private-field ())
generic-private-field?
;(struct menu-item (menu-name)) (struct menu-item (menu-name))
menu-item-menu-name
menu-name->get-menu-name ;; : menu-item -> symbol menu-name->get-menu-name ;; : menu-item -> symbol
;(struct before/after (name procedure)) (struct before/after (name procedure))
;(struct before ()) (struct before ())
;(struct after ()) (struct after ())
before? after?
before/after-name before/after-procedure
;(struct between (before after procedure)) (struct between (before after procedure))
between?
between-before between-after between-procedure
;(struct an-item (item-name help-string proc key menu-string-before menu-string-after on-demand)) (struct an-item (item-name help-string proc key menu-string-before menu-string-after on-demand))
an-item?
an-item-item-name an-item-help-string an-item-proc an-item-key
an-item-menu-string-before an-item-menu-string-after an-item-on-demand
;; an-item -> symbol ;; an-item -> symbol
;; calcualates the names of various identifiers associated with the item. ;; calcualates the names of various identifiers associated with the item.

656
collects/framework/private/text.ss
View File

@ -25,7 +25,7 @@
(define-struct range (start end b/w-bitmap color caret-space?)) (define-struct range (start end b/w-bitmap color caret-space?))
(define-struct rectangle (left top right bottom b/w-bitmap color)) (define-struct rectangle (left top right bottom b/w-bitmap color))
;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap, ;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap,
;; unless matthew makes it primitive ;; unless matthew makes it primitive
@ -36,9 +36,12 @@
set-styles-fixed set-styles-fixed
move/copy-to-edit move/copy-to-edit
initial-autowrap-bitmap)) initial-autowrap-bitmap))
(define highlight-pen (make-object pen% "BLACK" 0 'solid))
(define highlight-brush (make-object brush% "black" 'solid))
(define basic-mixin (define basic-mixin
(mixin (editor:basic<%> (class->interface text%)) (basic<%>) args (mixin (editor:basic<%> (class->interface text%)) (basic<%>)
(inherit get-canvases get-admin split-snip get-snip-position (inherit get-canvases get-admin split-snip get-snip-position
begin-edit-sequence end-edit-sequence begin-edit-sequence end-edit-sequence
set-autowrap-bitmap set-autowrap-bitmap
@ -46,89 +49,85 @@
set-file-format get-file-format set-file-format get-file-format
get-style-list is-modified? change-style set-modified get-style-list is-modified? change-style set-modified
position-location get-extent) position-location get-extent)
(private-field (define range-rectangles null)
[b1 (box 0)] (define ranges null)
[b2 (box 0)]
[b3 (box 0)] (define (invalidate-rectangles rectangles)
[b4 (box 0)] (let ([b1 (box 0)]
[range-rectangles null] [b2 (box 0)]
[ranges null] [b3 (box 0)]
[pen (make-object pen% "BLACK" 0 'solid)] [b4 (box 0)])
[brush (make-object brush% "black" 'solid)]) (let-values ([(min-left max-right)
(private (let loop ([left #f]
[invalidate-rectangles [right #f]
(lambda (rectangles) [canvases (get-canvases)])
(let-values (cond
([(min-left max-right) [(null? canvases)
(let loop ([left #f] (values left right)]
[right #f] [else
[canvases (get-canvases)]) (let-values ([(this-left this-right)
(cond (send (car canvases)
[(null? canvases) call-as-primary-owner
(values left right)] (lambda ()
[else (send (get-admin) get-view b1 b2 b3 b4)
(let-values ([(this-left this-right) (let* ([this-left (unbox b1)]
(send (car canvases) [this-width (unbox b3)]
call-as-primary-owner [this-right (+ this-left this-width)])
(lambda () (values this-left
(send (get-admin) get-view b1 b2 b3 b4) this-right))))])
(let* ([this-left (unbox b1)] (if (and left right)
[this-width (unbox b3)] (loop (min this-left left)
[this-right (+ this-left this-width)]) (max this-right right)
(values this-left (cdr canvases))
this-right))))]) (loop this-left
(if (and left right) this-right
(loop (min this-left left) (cdr canvases))))]))])
(max this-right right) (when (and min-left max-right)
(cdr canvases)) (let loop ([left #f]
(loop this-left [top #f]
this-right [right #f]
(cdr canvases))))]))]) [bottom #f]
(when (and min-left max-right) [rectangles rectangles])
(let loop ([left #f] (cond
[top #f] [(null? rectangles)
[right #f] (when left
[bottom #f] (let ([width (- right left)]
[rectangles rectangles]) [height (- bottom top)])
(cond (when (and (> width 0)
[(null? rectangles) (> height 0))
(when left (invalidate-bitmap-cache left top width height))))]
(let ([width (- right left)] [else (let* ([r (car rectangles)]
[height (- bottom top)])
(when (and (> width 0) [rleft (rectangle-left r)]
(> height 0)) [rright (rectangle-right r)]
(invalidate-bitmap-cache left top width height))))] [rtop (rectangle-top r)]
[else (let* ([r (car rectangles)] [rbottom (rectangle-bottom r)]
[rleft (rectangle-left r)] [this-left (if (number? rleft)
[rright (rectangle-right r)] rleft
[rtop (rectangle-top r)] min-left)]
[rbottom (rectangle-bottom r)] [this-right (if (number? rright)
rright
[this-left (if (number? rleft) max-right)]
rleft [this-bottom rbottom]
min-left)] [this-top rtop])
[this-right (if (number? rright) (if (and left top right bottom)
rright (loop (min this-left left)
max-right)] (min this-top top)
[this-bottom rbottom] (max this-right right)
[this-top rtop]) (max this-bottom bottom)
(if (and left top right bottom) (cdr rectangles))
(loop (min this-left left) (loop this-left
(min this-top top) this-top
(max this-right right) this-right
(max this-bottom bottom) this-bottom
(cdr rectangles)) (cdr rectangles))))]))))))
(loop this-left
this-top
this-right
this-bottom
(cdr rectangles))))])))))]
[recompute-range-rectangles (define (recompute-range-rectangles)
(lambda () (let* ([b1 (box 0)]
(let ([new-rectangles [b2 (box 0)]
[new-rectangles
(lambda (range) (lambda (range)
(let* ([start (range-start range)] (let* ([start (range-start range)]
[end (range-end range)] [end (range-end range)]
@ -187,201 +186,197 @@
b/w-bitmap b/w-bitmap
color))]))))] color))]))))]
[old-rectangles range-rectangles]) [old-rectangles range-rectangles])
(set! range-rectangles (set! range-rectangles
(foldl (lambda (x l) (append (new-rectangles x) l)) (foldl (lambda (x l) (append (new-rectangles x) l))
null ranges))))]) null ranges))))
(public
;; the bitmap is used in b/w and the color is used in color. (public highlight-range)
[highlight-range (define highlight-range
(opt-lambda (start end color bitmap [caret-space? #f] [priority 'low]) (opt-lambda (start end color bitmap [caret-space? #f] [priority 'low])
(unless (let ([exact-pos-int? (unless (let ([exact-pos-int?
(lambda (x) (and (integer? x) (exact? x) (x . >= . 0)))]) (lambda (x) (and (integer? x) (exact? x) (x . >= . 0)))])
(and (exact-pos-int? start) (and (exact-pos-int? start)
(exact-pos-int? end))) (exact-pos-int? end)))
(error 'highlight-range "expected first two arguments to be non-negative exact integers, got: ~e ~e" (error 'highlight-range "expected first two arguments to be non-negative exact integers, got: ~e ~e"
start end)) start end))
(unless (or (eq? priority 'high) (eq? priority 'low)) (unless (or (eq? priority 'high) (eq? priority 'low))
(error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e" (error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e"
priority)) priority))
(let ([l (make-range start end bitmap color caret-space?)]) (let ([l (make-range start end bitmap color caret-space?)])
(invalidate-rectangles range-rectangles) (invalidate-rectangles range-rectangles)
(set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l)))) (set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l))))
(recompute-range-rectangles) (recompute-range-rectangles)
(invalidate-rectangles range-rectangles) (invalidate-rectangles range-rectangles)
(lambda () (lambda ()
(let ([old-rectangles range-rectangles]) (let ([old-rectangles range-rectangles])
(set! ranges (set! ranges
(let loop ([r ranges]) (let loop ([r ranges])
(cond (cond
[(null? r) r] [(null? r) r]
[else (if (eq? (car r) l) [else (if (eq? (car r) l)
(cdr r) (cdr r)
(cons (car r) (loop (cdr r))))]))) (cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles) (recompute-range-rectangles)
(invalidate-rectangles old-rectangles)))))]) (invalidate-rectangles old-rectangles))))))
(rename [super-on-paint on-paint]) (rename [super-on-paint on-paint])
(override (override on-paint)
[on-paint (define (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(lambda (before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) (super-on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(super-on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) (recompute-range-rectangles)
(recompute-range-rectangles) (let ([b1 (box 0)]
(for-each [b2 (box 0)]
(lambda (rectangle) [b3 (box 0)]
(let-values ([(view-x view-y view-width view-height) [b4 (box 0)])
(begin (for-each
(send (get-admin) get-view b1 b2 b3 b4) (lambda (rectangle)
(values (unbox b1) (let-values ([(view-x view-y view-width view-height)
(unbox b2) (begin
(unbox b3) (send (get-admin) get-view b1 b2 b3 b4)
(unbox b4)))]) (values (unbox b1)
(let* ([old-pen (send dc get-pen)] (unbox b2)
[old-brush (send dc get-brush)] (unbox b3)
[b/w-bitmap (rectangle-b/w-bitmap rectangle)] (unbox b4)))])
[color (let* ([rc (rectangle-color rectangle)] (let* ([old-pen (send dc get-pen)]
[tmpc (make-object color% 0 0 0)]) [old-brush (send dc get-brush)]
(if rc [b/w-bitmap (rectangle-b/w-bitmap rectangle)]
(begin (send dc try-color rc tmpc) [color (let* ([rc (rectangle-color rectangle)]
(if (<= (color-model:rgb-color-distance [tmpc (make-object color% 0 0 0)])
(send rc red) (if rc
(send rc green) (begin (send dc try-color rc tmpc)
(send rc blue) (if (<= (color-model:rgb-color-distance
(send tmpc red) (send rc red)
(send tmpc green) (send rc green)
(send tmpc blue)) (send rc blue)
18) (send tmpc red)
rc (send tmpc green)
#f)) (send tmpc blue))
rc))] 18)
[first-number (lambda (x y) (if (number? x) x y))] rc
[left (max left-margin (first-number (rectangle-left rectangle) view-x))] #f))
[top (max top-margin (rectangle-top rectangle))] rc))]
[right (min right-margin [first-number (lambda (x y) (if (number? x) x y))]
(if (number? (rectangle-right rectangle)) [left (max left-margin (first-number (rectangle-left rectangle) view-x))]
(rectangle-right rectangle) [top (max top-margin (rectangle-top rectangle))]
(+ view-x view-width)))] [right (min right-margin
[bottom (min bottom-margin (rectangle-bottom rectangle))] (if (number? (rectangle-right rectangle))
[width (max 0 (- right left))] (rectangle-right rectangle)
[height (max 0 (- bottom top))]) (+ view-x view-width)))]
(let/ec k [bottom (min bottom-margin (rectangle-bottom rectangle))]
(cond [width (max 0 (- right left))]
[(and before color) [height (max 0 (- bottom top))])
(send pen set-color color) (let/ec k
(send brush set-color color)] (cond
[(and (not before) (not color) b/w-bitmap) [(and before color)
(send pen set-stipple b/w-bitmap) (send highlight-pen set-color color)
(send brush set-stipple b/w-bitmap)] (send highlight-brush set-color color)]
[else (k (void))]) [(and (not before) (not color) b/w-bitmap)
(send dc set-pen pen) (send highlight-pen set-stipple b/w-bitmap)
(send dc set-brush brush) (send highlight-brush set-stipple b/w-bitmap)]
(send dc draw-rectangle [else (k (void))])
(+ left dx) (send dc set-pen highlight-pen)
(+ top dy) (send dc set-brush highlight-brush)
width (send dc draw-rectangle (+ left dx) (+ top dy) width height)
height) (send dc set-pen old-pen)
(send dc set-pen old-pen) (send dc set-brush old-brush)))))
(send dc set-brush old-brush))))) range-rectangles)))
range-rectangles))])
(define styles-fixed? #f)
(define styles-fixed-edit-modified? #f)
(public get-styles-fixed set-styles-fixed)
(define (get-styles-fixed) styles-fixed?)
(define (set-styles-fixed b) (set! styles-fixed? b))
(private-field
[styles-fixed? #f]
[styles-fixed-edit-modified? #f])
(public
[get-styles-fixed (lambda () styles-fixed?)]
[set-styles-fixed (lambda (b) (set! styles-fixed? b))])
(rename (rename
[super-on-change-style on-change-style] [super-on-change-style on-change-style]
[super-after-change-style after-change-style] [super-after-change-style after-change-style]
[super-on-insert on-insert] [super-on-insert on-insert]
[super-after-insert after-insert]) [super-after-insert after-insert])
(override (override on-change-style on-insert after-insert after-change-style)
[on-change-style (define (on-change-style start len)
(lambda (start len) (when styles-fixed?
(when styles-fixed? (set! styles-fixed-edit-modified? (is-modified?)))
(set! styles-fixed-edit-modified? (is-modified?))) (super-on-change-style start len))
(super-on-change-style start len))] (define (on-insert start len)
[on-insert (begin-edit-sequence)
(lambda (start len) (super-on-insert start len))
(begin-edit-sequence) (define (after-insert start len)
(super-on-insert start len))] (when styles-fixed?
[after-insert (change-style (send (get-style-list) find-named-style "Standard")
(lambda (start len) start
(when styles-fixed? (+ start len)))
(change-style (send (get-style-list) find-named-style "Standard") (super-after-insert start len)
start (end-edit-sequence))
(+ start len))) (define (after-change-style start len)
(super-after-insert start len) (super-after-change-style start len)
(end-edit-sequence))] (when styles-fixed?
[after-change-style (set-modified styles-fixed-edit-modified?)))
(lambda (start len)
(super-after-change-style start len)
(when styles-fixed?
(set-modified styles-fixed-edit-modified?)))])
(public (public move/copy-to-edit)
[move/copy-to-edit (define (move/copy-to-edit dest-edit start end dest-position)
(lambda (dest-edit start end dest-position) (split-snip start)
(split-snip start) (split-snip end)
(split-snip end) (let loop ([snip (find-snip end 'before)])
(let loop ([snip (find-snip end 'before)]) (cond
(cond [(or (not snip) (< (get-snip-position snip) start))
[(or (not snip) (< (get-snip-position snip) start)) (void)]
(void)] [else
[else (let ([prev (send snip previous)]
(let ([prev (send snip previous)] [released/copied (if (send snip release-from-owner)
[released/copied (if (send snip release-from-owner) snip
snip (let* ([copy (send snip copy)]
(let* ([copy (send snip copy)] [snip-start (get-snip-position snip)]
[snip-start (get-snip-position snip)] [snip-end (+ snip-start (send snip get-count))])
[snip-end (+ snip-start (send snip get-count))]) (delete snip-start snip-end)
(delete snip-start snip-end) snip))])
snip))]) (send dest-edit insert released/copied dest-position dest-position)
(send dest-edit insert released/copied dest-position dest-position) (loop prev))])))
(loop prev))])))])
(public (public initial-autowrap-bitmap)
[initial-autowrap-bitmap (lambda () (icon:get-autowrap-bitmap))]) (define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap))
(sequence (super-instantiate ())
(apply super-init args) (set-autowrap-bitmap (initial-autowrap-bitmap))))
(set-autowrap-bitmap (initial-autowrap-bitmap)))))
(define hide/selection<%> (interface (basic<%>)))
(define hide/selection-mixin
(mixin (basic<%>) (hide/selection<%>)
(override after-set-position)
(inherit get-start-position get-end-position hide-caret)
(define (after-set-position)
(hide-caret (= (get-start-position) (get-end-position))))
(super-instantiate ())))
(define searching<%> (interface (editor:keymap<%> basic<%>))) (define searching<%> (interface (editor:keymap<%> basic<%>)))
(define searching-mixin (define searching-mixin
(mixin (editor:keymap<%> basic<%>) (searching<%>) args (mixin (editor:keymap<%> basic<%>) (searching<%>)
(rename [super-get-keymaps get-keymaps]) (rename [super-get-keymaps get-keymaps])
(override (override get-keymaps)
[get-keymaps (define (get-keymaps)
(lambda () (cons (keymap:get-search) (super-get-keymaps)))
(cons (keymap:get-search) (super-get-keymaps)))]) (super-instantiate ())))
(sequence
(apply super-init args))))
(define return<%> (interface ((class->interface text%)))) (define return<%> (interface ((class->interface text%))))
(define return-mixin (define return-mixin
(mixin ((class->interface text%)) (return<%>) (_return . args) (mixin ((class->interface text%)) (return<%>)
(init-field return)
(rename [super-on-local-char on-local-char]) (rename [super-on-local-char on-local-char])
(private-field [return _return]) (override on-local-char)
(override (define (on-local-char key)
[on-local-char (let ([cr-code #\return]
(lambda (key) [lf-code #\newline]
(let ([cr-code #\return] [code (send key get-key-code)])
[lf-code #\newline] (or (and (char? code)
[code (send key get-key-code)]) (or (char=? lf-code code)
(or (and (char? code) (char=? cr-code code))
(or (char=? lf-code code) (return))
(char=? cr-code code)) (super-on-local-char key))))
(return)) (super-instantiate ())))
(super-on-local-char key))))])
(sequence
(apply super-init args))))
(define info<%> (interface (basic<%>))) (define info<%> (interface (basic<%>)))
(define info-mixin (define info-mixin
(mixin (editor:keymap<%> basic<%>) (info<%>) args (mixin (editor:keymap<%> basic<%>) (info<%>)
(inherit get-start-position get-end-position get-canvas (inherit get-start-position get-end-position get-canvas
run-after-edit-sequence) run-after-edit-sequence)
(rename [super-after-set-position after-set-position] (rename [super-after-set-position after-set-position]
@ -391,92 +386,81 @@
[super-after-delete after-delete] [super-after-delete after-delete]
[super-set-overwrite-mode set-overwrite-mode] [super-set-overwrite-mode set-overwrite-mode]
[super-set-anchor set-anchor]) [super-set-anchor set-anchor])
(private (define (enqueue-for-frame call-method tag)
[enqueue-for-frame (run-after-edit-sequence
(lambda (call-method tag) (rec from-enqueue-for-frame
(run-after-edit-sequence (lambda ()
(rec from-enqueue-for-frame (let ([canvas (get-canvas)])
(lambda () (when canvas
(let ([canvas (get-canvas)]) (let ([frame (send canvas get-top-level-window)])
(when canvas (when (is-a? frame frame:text-info<%>)
(let ([frame (send canvas get-top-level-window)]) (call-method frame)))))))
(when (is-a? frame frame:text-info<%>) tag))
(call-method frame))))))) (override set-anchor set-overwrite-mode after-set-position after-insert after-delete)
tag))]) (define (set-anchor x)
(override (super-set-anchor x)
[set-anchor (enqueue-for-frame
(lambda (x) (lambda (x) (send x anchor-status-changed))
(super-set-anchor x) 'framework:anchor-status-changed))
(enqueue-for-frame (define (set-overwrite-mode x)
(lambda (x) (send x anchor-status-changed)) (super-set-overwrite-mode x)
'framework:anchor-status-changed))] (enqueue-for-frame
[set-overwrite-mode (lambda (x) (send x overwrite-status-changed))
(lambda (x) 'framework:overwrite-status-changed))
(super-set-overwrite-mode x) (define (after-set-position)
(enqueue-for-frame (super-after-set-position)
(lambda (x) (send x overwrite-status-changed)) (enqueue-for-frame
'framework:overwrite-status-changed))] (lambda (x) (send x editor-position-changed))
[after-set-position 'framework:editor-position-changed))
(lambda () (define (after-insert start len)
(super-after-set-position) (super-after-insert start len)
(enqueue-for-frame (enqueue-for-frame
(lambda (x) (send x editor-position-changed)) (lambda (x) (send x editor-position-changed))
'framework:editor-position-changed))] 'framework:editor-position-changed))
[after-insert (define (after-delete start len)
(lambda (start len) (super-after-delete start len)
(super-after-insert start len) (enqueue-for-frame
(enqueue-for-frame (lambda (x) (send x editor-position-changed))
(lambda (x) (send x editor-position-changed)) 'framework:editor-position-changed))
'framework:editor-position-changed))] (super-instantiate ())))
[after-delete
(lambda (start len)
(super-after-delete start len)
(enqueue-for-frame
(lambda (x) (send x editor-position-changed))
'framework:editor-position-changed))])
(sequence
(apply super-init args))))
(define clever-file-format<%> (interface ((class->interface text%)))) (define clever-file-format<%> (interface ((class->interface text%))))
(define clever-file-format-mixin (define clever-file-format-mixin
(mixin ((class->interface text%)) (clever-file-format<%>) args (mixin ((class->interface text%)) (clever-file-format<%>)
(inherit get-file-format set-file-format find-first-snip) (inherit get-file-format set-file-format find-first-snip)
(rename [super-on-save-file on-save-file]) (rename [super-on-save-file on-save-file])
(private (define (all-string-snips)
[all-string-snips (let loop ([s (find-first-snip)])
(lambda () (cond
(let loop ([s (find-first-snip)]) [(not s) #t]
(cond [(is-a? s string-snip%)
[(not s) #t] (loop (send s next))]
[(is-a? s string-snip%) [else #f])))
(loop (send s next))] (override on-save-file)
[else #f])))]) (define (on-save-file name format)
(override (let ([all-strings? (all-string-snips)])
[on-save-file (cond
(lambda (name format) [(and all-strings?
(let ([all-strings? (all-string-snips)]) (or (eq? format 'same) (eq? format 'copy))
(cond (eq? 'standard (get-file-format))
[(and all-strings? (or (not (preferences:get 'framework:verify-change-format))
(or (eq? format 'same) (eq? format 'copy)) (gui-utils:get-choice
(eq? 'standard (get-file-format)) "Save this file as plain text?" "Yes" "No")))
(or (not (preferences:get 'framework:verify-change-format)) (set-file-format 'text)]
(gui-utils:get-choice [(and (not all-strings?)
"Save this file as plain text?" "Yes" "No"))) (or (eq? format 'same) (eq? format 'copy))
(set-file-format 'text)] (eq? 'text (get-file-format))
[(and (not all-strings?) (or (not (preferences:get 'framework:verify-change-format))
(or (eq? format 'same) (eq? format 'copy)) (gui-utils:get-choice
(eq? 'text (get-file-format)) "Save this file in drscheme-specific non-text format?" "Yes" "No")))
(or (not (preferences:get 'framework:verify-change-format)) (set-file-format 'standard)]
(gui-utils:get-choice [else (void)]))
"Save this file in drscheme-specific non-text format?" "Yes" "No"))) (super-on-save-file name format))
(set-file-format 'standard)] (super-instantiate ())))
[else (void)]))
(super-on-save-file name format))])
(sequence
(apply super-init args))))
(define basic% (basic-mixin (editor:basic-mixin text%))) (define basic% (basic-mixin (editor:basic-mixin text%)))
(define hide/selection% (hide/selection-mixin basic%))
(define -keymap% (editor:keymap-mixin basic%)) (define -keymap% (editor:keymap-mixin basic%))
(define return% (return-mixin -keymap%)) (define return% (return-mixin -keymap%))
(define autowrap% (editor:autowrap-mixin -keymap%)) (define autowrap% (editor:autowrap-mixin -keymap%))

6
collects/framework/splash.ss
View File

@ -12,7 +12,8 @@
(define (splash filename title width-default) (define (splash filename title width-default)
(let/ec k (let/ec k
(letrec-values (letrec-values
([(no-splash) (lambda () (k void void void))] ([(splash-eventspace) (make-eventspace)]
[(no-splash) (lambda () (k #f #f splash-eventspace void void void))]
[(funny?) (let ([date (seconds->date (current-seconds))]) [(funny?) (let ([date (seconds->date (current-seconds))])
(and (= (date-day date) 25) (and (= (date-day date) 25)
(= (date-month date) 12)))] (= (date-month date) 12)))]
@ -116,7 +117,6 @@
(when quit-on-close? (when quit-on-close?
(exit)))]) (exit)))])
(sequence (super-init title)))] (sequence (super-init title)))]
[(splash-eventspace) (make-eventspace)]
[(frame) (parameterize ([current-eventspace splash-eventspace]) [(frame) (parameterize ([current-eventspace splash-eventspace])
(make-object splash-frame% title))] (make-object splash-frame% title))]
[(_0) (send frame accept-drop-files #t)] [(_0) (send frame accept-drop-files #t)]
@ -133,7 +133,7 @@
[else 'xpm]))))] [else 'xpm]))))]
[(bitmap) (make-object bitmap% filename bitmap-flag)] [(bitmap) (make-object bitmap% filename bitmap-flag)]
[(_2) (unless (send bitmap ok?) [(_2) (unless (send bitmap ok?)
(fprintf (current-error-port) "WARNING: bad bitmap ~s" filename) (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" filename)
(no-splash))] (no-splash))]
[(splash-canvas%) [(splash-canvas%)
(class100 canvas% args (class100 canvas% args