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

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

@ -15,32 +15,31 @@
(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) (super-instantiate ())
(unless (is-a? (get-top-level-window) frame:info<%>) (unless (is-a? (get-top-level-window) frame:info<%>)
(error 'canvas:text-info-mixin (error 'canvas:text-info-mixin
@ -48,24 +47,22 @@
(get-top-level-window))) (get-top-level-window)))
(when (has-focus?) (when (has-focus?)
(send (get-top-level-window) update-info))))) (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
[update-snip-size
(lambda (width?) (lambda (width?)
(lambda (s) (lambda (s)
(let* ([width (box 0)] (let* ([width (box 0)]
@ -149,28 +146,26 @@
(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))]
[add-tall-snip [define 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 (override on-size)
[on-size [define 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%))

238
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,9 +82,9 @@
(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
@ -93,41 +92,22 @@
(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])
(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 (lambda () (void))]
[get-top-level-window
(lambda () (lambda ()
(let loop ([text this]) (let loop ([text this])
(let ([editor-admin (send text get-admin)]) (let ([editor-admin (send text get-admin)])
@ -139,29 +119,27 @@
[(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 [define edit-sequence-queue null]
[edit-sequence-queue null] [define edit-sequence-ht (make-hash-table)]
[edit-sequence-ht (make-hash-table)]) [define in-local-edit-sequence? #f]
(public local-edit-sequence? run-after-edit-sequence extend-edit-sequence-queue)
(private-field [define local-edit-sequence? (lambda () in-local-edit-sequence?)]
[in-local-edit-sequence? #f]) [define run-after-edit-sequence
(public
[local-edit-sequence? (lambda () in-local-edit-sequence?)]
[run-after-edit-sequence
(case-lambda (case-lambda
[(t) (run-after-edit-sequence t #f)] [(t) (run-after-edit-sequence t #f)]
[(t sym) [(t sym)
(unless (and (procedure? t) (unless (and (procedure? t)
(= 0 (procedure-arity t))) (= 0 (procedure-arity t)))
(error 'media-buffer::run-after-edit-sequence (error 'editor:basic::run-after-edit-sequence
"expected procedure of arity zero, got: ~s~n" t)) "expected procedure of arity zero, got: ~s~n" t))
(unless (or (symbol? sym) (not sym)) (unless (or (symbol? sym) (not sym))
(error 'media-buffer::run-after-edit-sequence (error 'editor:basic::run-after-edit-sequence
"expected second argument to be a symbol, got: ~s~n" "expected second argument to be a symbol or #f, got: ~s~n"
sym)) sym))
(if (refresh-delayed?) (if (refresh-delayed?)
(if in-local-edit-sequence? (if in-local-edit-sequence?
@ -184,22 +162,22 @@
'(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)
@ -221,74 +199,70 @@
[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?))
(private-field [define remove-callback
[remove-callback
(preferences:add-callback (preferences:add-callback
'framework:auto-set-wrap? 'framework:auto-set-wrap?
(let ([autowrap-mixin-pref-callback (let ([autowrap-mixin-pref-callback
(lambda (p v) (lambda (p v)
(auto-wrap v))]) (auto-wrap v))])
autowrap-mixin-pref-callback))]))) 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,12 +271,11 @@
[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
@ -312,7 +285,7 @@
(file-or-directory-permissions (file-or-directory-permissions
filename))))]) filename))))])
(lock lock?)))] (lock lock?)))]
[update-filename [define 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))
@ -321,21 +294,21 @@
(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 (override after-save-file after-load-file set-filename get-keymaps)
[after-save-file [define 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<%>)
@ -358,29 +330,27 @@
; 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
[file-old?
(lambda (filename) (lambda (filename)
(if (and filename (if (and filename
(file-exists? filename)) (file-exists? filename))
(let ([modified-seconds (file-or-directory-modify-seconds filename)] (let ([modified-seconds (file-or-directory-modify-seconds filename)]
[old-seconds (- (current-seconds) (* 7 24 60 60))]) [old-seconds (- (current-seconds) (* 7 24 60 60))])
(< modified-seconds old-seconds)) (< modified-seconds old-seconds))
#t))]) #t))]
(public (public backup?)
[backup? (lambda () #t)]) [define backup? (lambda () #t)]
(override (override on-save-file on-close on-change set-modified)
[on-save-file [define 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,27 +364,26 @@
(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?)
@ -439,23 +408,22 @@
"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))))))]
[remove-autosave [define 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)))]
(sequence (super-instantiate ())
(apply super-init args) (autosave:register this)))
(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
@ -464,5 +432,5 @@
(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 ()))))))

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

File diff suppressed because it is too large Load Diff

114
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,58 +63,57 @@
(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)])]))
@ -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))

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

@ -26,38 +26,38 @@
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
@ -69,10 +69,9 @@
(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%))

17
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
(apply super-init args) (super-instantiate ())
(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%)))))

128
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,12 +61,12 @@
(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)
@ -76,17 +76,16 @@
(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,25 +106,22 @@
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%
(public
[get-editor-canvas%
(lambda () (lambda ()
editor-canvas%)] editor-canvas%)]
[get-vertical% [define get-vertical%
(lambda () (lambda ()
vertical-panel%)] vertical-panel%)]
[get-horizontal% [define get-horizontal%
(lambda () (lambda ()
horizontal-panel%)]) horizontal-panel%)]
(public split-vertically split-horizontally)
(private [define split
[split
(lambda (p%) (lambda (p%)
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
[ec% (get-editor-canvas%)]) [ec% (get-editor-canvas%)])
@ -137,10 +132,16 @@
(send p change-children (lambda (x) null)) (send p change-children (lambda (x) null))
(let ([pc (make-object p% p)]) (let ([pc (make-object p% p)])
(send (make-object ec% (make-object vertical-panel% pc) editor) focus) (send (make-object ec% (make-object vertical-panel% pc) editor) focus)
(make-object ec% (make-object vertical-panel% pc) editor))))))]) (make-object ec% (make-object vertical-panel% pc) editor))))))]
[define split-vertically
(lambda ()
(split (get-vertical%)))]
[define split-horizontally
(lambda ()
(split (get-horizontal%)))]
(public (public collapse)
[collapse (define collapse
(lambda () (lambda ()
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
[ec% (get-editor-canvas%)]) [ec% (get-editor-canvas%)])
@ -153,18 +154,11 @@
(let* ([sp (send p get-parent)] (let* ([sp (send p get-parent)]
[p-to-remain (send sp get-parent)]) [p-to-remain (send sp get-parent)])
(send p-to-remain change-children (lambda (x) null)) (send p-to-remain change-children (lambda (x) null))
(send (make-object ec% p-to-remain editor) focus)))))))]) (send (make-object ec% p-to-remain editor) focus))))))))
(public
[split-vertically (super-instantiate () (parent parent))
(lambda () (make-object (get-editor-canvas%) this editor)))
(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,7 +424,7 @@
(+ (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]
@ -471,19 +464,18 @@
(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%)))))

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

@ -30,6 +30,8 @@
(rename [-text% text%] (rename [-text% text%]
[-text<%> text<%>]) [-text<%> text<%>])
(define-struct string/pos (string pos))
(define -text<%> (define -text<%>
(interface () (interface ()
highlight-parens highlight-parens
@ -98,7 +100,7 @@
(define mismatch-color (make-object color% "PINK")) (define mismatch-color (make-object color% "PINK"))
(define text-mixin (define text-mixin
(mixin (text:basic<%> editor:keymap<%>) (-text<%>) args (mixin (text:basic<%> editor:keymap<%>) (-text<%>)
(inherit begin-edit-sequence (inherit begin-edit-sequence
delete delete
end-edit-sequence end-edit-sequence
@ -127,9 +129,7 @@
set-styles-fixed) set-styles-fixed)
(rename [super-on-char on-char]) (rename [super-on-char on-char])
(private (define (in-single-line-comment? position)
[in-single-line-comment?
(lambda (position)
(let ([line (position-line position)]) (let ([line (position-line position)])
(ormap (ormap
(lambda (comment-start) (lambda (comment-start)
@ -149,21 +149,16 @@
[else [else
#f]) #f])
#f))) #f)))
(scheme-paren:get-comments))))]) (scheme-paren:get-comments))))
(private-field (define remove-indents-callback
[remove-indents-callback
(preferences:add-callback (preferences:add-callback
'framework:tabify 'framework:tabify
(lambda (p value) (lambda (p value)
(set! indents value)))] (set! indents value))))
[indents (preferences:get 'framework:tabify)] (define indents (preferences:get 'framework:tabify))
[backward-cache (make-object match-cache:%)] [define backward-cache (make-object match-cache:%)]
[forward-cache (make-object match-cache:%)] [define forward-cache (make-object match-cache:%)]
[in-highlight-parens? #f]) [define in-highlight-parens? #f]
(private
[delay-highlight? (lambda () (local-edit-sequence?))])
(inherit get-styles-fixed) (inherit get-styles-fixed)
(rename [super-on-focus on-focus] (rename [super-on-focus on-focus]
@ -174,63 +169,55 @@
[super-after-set-size-constraint after-set-size-constraint] [super-after-set-size-constraint after-set-size-constraint]
[super-after-set-position after-set-position]) [super-after-set-position after-set-position])
(inherit has-focus? find-snip split-snip) (inherit has-focus? find-snip split-snip)
(override (override on-focus after-change-style after-edit-sequence
[on-focus after-insert after-delete
(lambda (on?) after-set-size-constraint after-set-position)
(define (on-focus on?)
(super-on-focus on?) (super-on-focus on?)
(highlight-parens (not on?)))] (highlight-parens (not on?)))
[after-change-style (define (after-change-style start len)
(lambda (start len) (unless (local-edit-sequence?)
(unless (delay-highlight?)
(unless (get-styles-fixed) (unless (get-styles-fixed)
(when (has-focus?) (when (has-focus?)
(highlight-parens)))) (highlight-parens))))
(super-after-change-style start len))] (super-after-change-style start len))
[after-edit-sequence (define (after-edit-sequence)
(lambda ()
(super-after-edit-sequence) (super-after-edit-sequence)
(unless (delay-highlight?) (unless (local-edit-sequence?)
(when (has-focus?) (when (has-focus?)
(unless in-highlight-parens? (unless in-highlight-parens?
(highlight-parens)))))] (highlight-parens)))))
[after-insert (define (after-insert start size)
(lambda (start size)
(send backward-cache invalidate start) (send backward-cache invalidate start)
(send forward-cache forward-invalidate start size) (send forward-cache forward-invalidate start size)
(unless (delay-highlight?) (unless (local-edit-sequence?)
(when (has-focus?) (when (has-focus?)
(highlight-parens))) (highlight-parens)))
(super-after-insert start size))] (super-after-insert start size))
[after-delete (define (after-delete start size)
(lambda (start size)
(super-after-delete start size) (super-after-delete start size)
(send backward-cache invalidate start) (send backward-cache invalidate start)
(send forward-cache forward-invalidate (+ start size) (- size)) (send forward-cache forward-invalidate (+ start size) (- size))
(unless (delay-highlight?) (unless (local-edit-sequence?)
(when (has-focus?) (when (has-focus?)
(highlight-parens))))] (highlight-parens))))
[after-set-size-constraint (define (after-set-size-constraint)
(lambda () (unless (local-edit-sequence?)
(unless (delay-highlight?)
(when (has-focus?) (when (has-focus?)
(highlight-parens))) (highlight-parens)))
(super-after-set-size-constraint))] (super-after-set-size-constraint))
[after-set-position (define (after-set-position )
(lambda () (unless (local-edit-sequence?)
(unless (delay-highlight?)
(when (has-focus?) (when (has-focus?)
(highlight-parens))) (highlight-parens)))
(super-after-set-position))]) (super-after-set-position))
(private-field [define highlight-parens? (preferences:get 'framework:highlight-parens)]
[highlight-parens? (preferences:get 'framework:highlight-parens)] [define remove-paren-callback (preferences:add-callback
[remove-paren-callback (preferences:add-callback
'framework:highlight-parens 'framework:highlight-parens
(lambda (p value) (lambda (p value)
(set! highlight-parens? value)))]) (set! highlight-parens? value)))]
(private (define (find-enclosing-paren pos)
[find-enclosing-paren
(lambda (pos)
(let loop ([pos pos]) (let loop ([pos pos])
(let ([paren-pos (let ([paren-pos
(let loop ([pairs (scheme-paren:get-paren-pairs)] (let loop ([pairs (scheme-paren:get-paren-pairs)]
@ -253,11 +240,13 @@
(< semi-pos (paragraph-start-position (< semi-pos (paragraph-start-position
(position-paragraph paren-pos)))) (position-paragraph paren-pos))))
paren-pos] paren-pos]
[else (loop (- semi-pos 1))]))]))))]) [else (loop (- semi-pos 1))]))]))))
(private-field
[clear-old-locations void]) [define clear-old-locations 'dummy]
(public (set! clear-old-locations void)
[highlight-parens
(public highlight-parens)
(define highlight-parens
(opt-lambda ([just-clear? #f]) (opt-lambda ([just-clear? #f])
(when highlight-parens? (when highlight-parens?
(set! in-highlight-parens? #t) (set! in-highlight-parens? #t)
@ -341,12 +330,16 @@
[before (handle-single before)] [before (handle-single before)]
[else (void)]))))) [else (void)])))))
(end-edit-sequence) (end-edit-sequence)
(set! in-highlight-parens? #f)))] (set! in-highlight-parens? #f))))
[get-limit (lambda (pos) 0)] (public get-limit balance-quotes balance-parens tabify-on-return? tabify tabify-selection
tabify-all insert-return calc-last-para comment-out-selection uncomment-selection
get-forward-sexp remove-sexp forward-sexp flash-forward-sexp get-backward-sexp
flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
remove-parens-forward)
(define (get-limit pos) 0)
[balance-quotes (define (balance-quotes key)
(lambda (key)
(let* ([char (send key get-key-code)]) ;; must be a character because of the mapping setup (let* ([char (send key get-key-code)]) ;; must be a character because of the mapping setup
;; this function is only bound to ascii-returning keys ;; this function is only bound to ascii-returning keys
(insert char) (insert char)
@ -355,10 +348,9 @@
[match (scheme-paren:backward-match [match (scheme-paren:backward-match
this start-pos limit backward-cache)]) this start-pos limit backward-cache)])
(when match (when match
(flash-on match (add1 match))))))] (flash-on match (add1 match))))))
[balance-parens
(lambda (key-event) (define (balance-parens key-event)
(let-struct string/pos (string pos)
(letrec ([char (send key-event get-key-code)] ;; must be a character. See above. (letrec ([char (send key-event get-key-code)] ;; must be a character. See above.
[here (get-start-position)] [here (get-start-position)]
[limit (get-limit here)] [limit (get-limit here)]
@ -401,9 +393,10 @@
(insert char)]))] (insert char)]))]
[else (insert char)]))] [else (insert char)]))]
[else (insert char)]) [else (insert char)])
#t)))] #t))
[tabify-on-return? (lambda () #t)]
[tabify (define (tabify-on-return?) #t)
(define tabify
(opt-lambda ([pos (get-start-position)]) (opt-lambda ([pos (get-start-position)])
(let* ([last-pos (last-position)] (let* ([last-pos (last-position)]
[para (position-paragraph pos)] [para (position-paragraph pos)]
@ -528,8 +521,9 @@
(indent-first-arg (+ contains (indent-first-arg (+ contains
name-length)))))] name-length)))))]
[else [else
(do-indent (indent-first-arg (paragraph-start-position last-para)))]))))] (do-indent (indent-first-arg (paragraph-start-position last-para)))])))))
[tabify-selection
(define tabify-selection
(opt-lambda ([start-pos (get-start-position)] (opt-lambda ([start-pos (get-start-position)]
[end-pos (get-end-position)]) [end-pos (get-end-position)])
(let ([first-para (position-paragraph start-pos)] (let ([first-para (position-paragraph start-pos)]
@ -561,10 +555,10 @@
(lambda () (lambda ()
(end-edit-sequence) (end-edit-sequence)
(when (< first-para end-para) (when (< first-para end-para)
(end-busy-cursor)))))))] (end-busy-cursor))))))))
[tabify-all (lambda () (tabify-selection 0 (last-position)))]
[insert-return (define (tabify-all) (tabify-selection 0 (last-position)))
(lambda () (define (insert-return)
(if (tabify-on-return?) (if (tabify-on-return?)
(begin (begin
(begin-edit-sequence) (begin-edit-sequence)
@ -578,11 +572,9 @@
(loop (add1 new-pos)) (loop (add1 new-pos))
new-pos))) new-pos)))
(end-edit-sequence)) (end-edit-sequence))
(insert #\newline)))] (insert #\newline)))
(define (calc-last-para last-pos)
[calc-last-para
(lambda (last-pos)
(let ([last-para (position-paragraph last-pos #t)]) (let ([last-para (position-paragraph last-pos #t)])
(if (and (> last-pos 0) (if (and (> last-pos 0)
(> last-para 0)) (> last-para 0))
@ -591,8 +583,9 @@
(if (member 'hard-newline (send snip get-flags)) (if (member 'hard-newline (send snip get-flags))
(- last-para 1) (- last-para 1)
last-para))) last-para)))
last-para)))] last-para)))
[comment-out-selection
(define comment-out-selection
(opt-lambda ([start-pos (get-start-position)] (opt-lambda ([start-pos (get-start-position)]
[end-pos (get-end-position)]) [end-pos (get-end-position)])
(begin-edit-sequence) (begin-edit-sequence)
@ -611,8 +604,9 @@
(paragraph-start-position (position-paragraph (get-start-position))) (paragraph-start-position (position-paragraph (get-start-position)))
(get-end-position)))) (get-end-position))))
(end-edit-sequence) (end-edit-sequence)
#t)] #t))
[uncomment-selection
(define uncomment-selection
(opt-lambda ([start-pos (get-start-position)] (opt-lambda ([start-pos (get-start-position)]
[end-pos (get-end-position)]) [end-pos (get-end-position)])
(begin-edit-sequence) (begin-edit-sequence)
@ -631,35 +625,36 @@
(delete first-on-para (+ first-on-para 1))) (delete first-on-para (+ first-on-para 1)))
(para-loop (add1 curr-para)))))) (para-loop (add1 curr-para))))))
(end-edit-sequence) (end-edit-sequence)
#t)] #t))
[get-forward-sexp
[define get-forward-sexp
(lambda (start-pos) (lambda (start-pos)
(scheme-paren:forward-match (scheme-paren:forward-match
this start-pos this start-pos
(last-position) (last-position)
forward-cache))] forward-cache))]
[remove-sexp [define remove-sexp
(lambda (start-pos) (lambda (start-pos)
(let ([end-pos (get-forward-sexp start-pos)]) (let ([end-pos (get-forward-sexp start-pos)])
(if end-pos (if end-pos
(kill 0 start-pos end-pos) (kill 0 start-pos end-pos)
(bell)) (bell))
#t))] #t))]
[forward-sexp [define forward-sexp
(lambda (start-pos) (lambda (start-pos)
(let ([end-pos (get-forward-sexp start-pos)]) (let ([end-pos (get-forward-sexp start-pos)])
(if end-pos (if end-pos
(set-position end-pos) (set-position end-pos)
(bell)) (bell))
#t))] #t))]
[flash-forward-sexp [define flash-forward-sexp
(lambda (start-pos) (lambda (start-pos)
(let ([end-pos (get-forward-sexp start-pos)]) (let ([end-pos (get-forward-sexp start-pos)])
(if end-pos (if end-pos
(flash-on end-pos (add1 end-pos)) (flash-on end-pos (add1 end-pos))
(bell)) (bell))
#t))] #t))]
[get-backward-sexp [define get-backward-sexp
(lambda (start-pos) (lambda (start-pos)
(let* ([limit (get-limit start-pos)] (let* ([limit (get-limit start-pos)]
[end-pos [end-pos
@ -675,21 +670,21 @@
end-pos end-pos
#f)]) #f)])
ans))] ans))]
[flash-backward-sexp [define flash-backward-sexp
(lambda (start-pos) (lambda (start-pos)
(let ([end-pos (get-backward-sexp start-pos)]) (let ([end-pos (get-backward-sexp start-pos)])
(if end-pos (if end-pos
(flash-on end-pos (add1 end-pos)) (flash-on end-pos (add1 end-pos))
(bell)) (bell))
#t))] #t))]
[backward-sexp [define backward-sexp
(lambda (start-pos) (lambda (start-pos)
(let ([end-pos (get-backward-sexp start-pos)]) (let ([end-pos (get-backward-sexp start-pos)])
(if end-pos (if end-pos
(set-position end-pos) (set-position end-pos)
(bell)) (bell))
#t))] #t))]
[find-up-sexp [define find-up-sexp
(lambda (start-pos) (lambda (start-pos)
(let* ([exp-pos (let* ([exp-pos
(scheme-paren:backward-containing-sexp (scheme-paren:backward-containing-sexp
@ -716,14 +711,14 @@
#f #f
(- (apply max poss) 1))) ;; subtract one to move outside the paren (- (apply max poss) 1))) ;; subtract one to move outside the paren
#f)))] #f)))]
[up-sexp [define up-sexp
(lambda (start-pos) (lambda (start-pos)
(let ([exp-pos (find-up-sexp start-pos)]) (let ([exp-pos (find-up-sexp start-pos)])
(if exp-pos (if exp-pos
(set-position exp-pos) (set-position exp-pos)
(bell)) (bell))
#t))] #t))]
[find-down-sexp [define find-down-sexp
(lambda (start-pos) (lambda (start-pos)
(let ([last (last-position)]) (let ([last (last-position)])
(let loop ([pos start-pos]) (let loop ([pos start-pos])
@ -739,14 +734,14 @@
back-pos back-pos
(loop next-pos))) (loop next-pos)))
#f)))))] #f)))))]
[down-sexp [define down-sexp
(lambda (start-pos) (lambda (start-pos)
(let ([pos (find-down-sexp start-pos)]) (let ([pos (find-down-sexp start-pos)])
(if pos (if pos
(set-position pos) (set-position pos)
(bell)) (bell))
#t))] #t))]
[remove-parens-forward [define remove-parens-forward
(lambda (start-pos) (lambda (start-pos)
(let* ([pos (paren:skip-whitespace this start-pos 'forward)] (let* ([pos (paren:skip-whitespace this start-pos 'forward)]
[first-char (get-character pos)] [first-char (get-character pos)]
@ -762,10 +757,9 @@
(delete (- closer 2) (- closer 1)) (delete (- closer 2) (- closer 1))
(end-edit-sequence)) (end-edit-sequence))
(bell)) (bell))
#t))]) #t))]
(private [define select-text
[select-text
(lambda (f forward?) (lambda (f forward?)
(let* ([start-pos (get-start-position)] (let* ([start-pos (get-start-position)]
[end-pos (get-end-position)]) [end-pos (get-end-position)])
@ -776,14 +770,16 @@
(if (and new-start new-end) (if (and new-start new-end)
(set-position new-start new-end) (set-position new-start new-end)
(bell)) (bell))
#t)))]) #t)))]
(public (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp
[select-forward-sexp (lambda () (select-text (lambda (x) (get-forward-sexp x)) #t))] transpose-sexp)
[select-backward-sexp (lambda () (select-text (lambda (x) (get-backward-sexp x)) #f))]
[select-up-sexp (lambda () (select-text (lambda (x) (find-up-sexp x)) #f))]
[select-down-sexp (lambda () (select-text (lambda (x) (find-down-sexp x)) #t))]
[transpose-sexp [define select-forward-sexp (lambda () (select-text (lambda (x) (get-forward-sexp x)) #t))]
[define select-backward-sexp (lambda () (select-text (lambda (x) (get-backward-sexp x)) #f))]
[define select-up-sexp (lambda () (select-text (lambda (x) (find-up-sexp x)) #f))]
[define select-down-sexp (lambda () (select-text (lambda (x) (find-down-sexp x)) #t))]
[define transpose-sexp
(lambda (pos) (lambda (pos)
(let ([start-1 (get-backward-sexp pos)]) (let ([start-1 (get-backward-sexp pos)])
(if (not start-1) (if (not start-1)
@ -806,28 +802,26 @@
(insert text-1 start-2 end-2) (insert text-1 start-2 end-2)
(insert text-2 start-1 end-1) (insert text-2 start-1 end-1)
(set-position end-2) (set-position end-2)
(end-edit-sequence)))))))))))]) (end-edit-sequence)))))))))))]
(private-field [define tab-size 8]
[tab-size 8]) (public get-tab-size set-tab-size)
(public [define get-tab-size (lambda () tab-size)]
[get-tab-size (lambda () tab-size)] [define set-tab-size (lambda (s) (set! tab-size s))]
[set-tab-size (lambda (s) (set! tab-size s))])
(rename [super-get-keymaps get-keymaps]) (rename [super-get-keymaps get-keymaps])
(override (override get-keymaps)
[get-keymaps [define get-keymaps
(lambda () (lambda ()
(cons keymap (super-get-keymaps)))]) (cons keymap (super-get-keymaps)))]
(sequence (super-instantiate ())
(apply super-init args)
(highlight-parens #t) (highlight-parens #t)
(set-load-overwrites-styles #f) (set-load-overwrites-styles #f)
(set-wordbreak-map wordbreak-map) (set-wordbreak-map wordbreak-map)
(set-tabs null tab-size #f) (set-tabs null tab-size #f)
(set-style-list style-list) (set-style-list style-list)
(set-styles-fixed #t)))) (set-styles-fixed #t)))
(define -text% (text-mixin text:info%)) (define -text% (text-mixin text:info%))

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.

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

@ -37,8 +37,11 @@
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
@ -47,20 +50,15 @@
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)
(define (invalidate-rectangles rectangles)
(let ([b1 (box 0)]
[b2 (box 0)] [b2 (box 0)]
[b3 (box 0)] [b3 (box 0)]
[b4 (box 0)] [b4 (box 0)])
[range-rectangles null] (let-values ([(min-left max-right)
[ranges null]
[pen (make-object pen% "BLACK" 0 'solid)]
[brush (make-object brush% "black" 'solid)])
(private
[invalidate-rectangles
(lambda (rectangles)
(let-values
([(min-left max-right)
(let loop ([left #f] (let loop ([left #f]
[right #f] [right #f]
[canvases (get-canvases)]) [canvases (get-canvases)])
@ -124,11 +122,12 @@
this-top this-top
this-right this-right
this-bottom this-bottom
(cdr rectangles))))])))))] (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)]
@ -190,10 +189,10 @@
(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)))])
@ -219,13 +218,16 @@
(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)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)])
(for-each (for-each
(lambda (rectangle) (lambda (rectangle)
(let-values ([(view-x view-y view-width view-height) (let-values ([(view-x view-y view-width view-height)
@ -266,61 +268,52 @@
(let/ec k (let/ec k
(cond (cond
[(and before color) [(and before color)
(send pen set-color color) (send highlight-pen set-color color)
(send brush set-color color)] (send highlight-brush set-color color)]
[(and (not before) (not color) b/w-bitmap) [(and (not before) (not color) b/w-bitmap)
(send pen set-stipple b/w-bitmap) (send highlight-pen set-stipple b/w-bitmap)
(send brush set-stipple b/w-bitmap)] (send highlight-brush set-stipple b/w-bitmap)]
[else (k (void))]) [else (k (void))])
(send dc set-pen pen) (send dc set-pen highlight-pen)
(send dc set-brush brush) (send dc set-brush highlight-brush)
(send dc draw-rectangle (send dc draw-rectangle (+ left dx) (+ top dy) width height)
(+ left dx)
(+ top dy)
width
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))
[on-insert (define (on-insert start len)
(lambda (start len)
(begin-edit-sequence) (begin-edit-sequence)
(super-on-insert start len))] (super-on-insert start len))
[after-insert (define (after-insert start len)
(lambda (start len)
(when styles-fixed? (when styles-fixed?
(change-style (send (get-style-list) find-named-style "Standard") (change-style (send (get-style-list) find-named-style "Standard")
start start
(+ start len))) (+ start len)))
(super-after-insert start len) (super-after-insert start len)
(end-edit-sequence))] (end-edit-sequence))
[after-change-style (define (after-change-style start len)
(lambda (start len)
(super-after-change-style start len) (super-after-change-style start len)
(when styles-fixed? (when styles-fixed?
(set-modified styles-fixed-edit-modified?)))]) (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)])
@ -337,36 +330,39 @@
(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
(lambda (key)
(let ([cr-code #\return] (let ([cr-code #\return]
[lf-code #\newline] [lf-code #\newline]
[code (send key get-key-code)]) [code (send key get-key-code)])
@ -374,14 +370,13 @@
(or (char=? lf-code code) (or (char=? lf-code code)
(char=? cr-code code)) (char=? cr-code code))
(return)) (return))
(super-on-local-char key))))]) (super-on-local-char key))))
(sequence (super-instantiate ())))
(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,9 +386,7 @@
[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
(lambda (call-method tag)
(run-after-edit-sequence (run-after-edit-sequence
(rec from-enqueue-for-frame (rec from-enqueue-for-frame
(lambda () (lambda ()
@ -402,59 +395,50 @@
(let ([frame (send canvas get-top-level-window)]) (let ([frame (send canvas get-top-level-window)])
(when (is-a? frame frame:text-info<%>) (when (is-a? frame frame:text-info<%>)
(call-method frame))))))) (call-method frame)))))))
tag))]) tag))
(override (override set-anchor set-overwrite-mode after-set-position after-insert after-delete)
[set-anchor (define (set-anchor x)
(lambda (x)
(super-set-anchor x) (super-set-anchor x)
(enqueue-for-frame (enqueue-for-frame
(lambda (x) (send x anchor-status-changed)) (lambda (x) (send x anchor-status-changed))
'framework:anchor-status-changed))] 'framework:anchor-status-changed))
[set-overwrite-mode (define (set-overwrite-mode x)
(lambda (x)
(super-set-overwrite-mode x) (super-set-overwrite-mode x)
(enqueue-for-frame (enqueue-for-frame
(lambda (x) (send x overwrite-status-changed)) (lambda (x) (send x overwrite-status-changed))
'framework:overwrite-status-changed))] 'framework:overwrite-status-changed))
[after-set-position (define (after-set-position)
(lambda ()
(super-after-set-position) (super-after-set-position)
(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-insert start len)
(lambda (start len)
(super-after-insert 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))
[after-delete (define (after-delete start len)
(lambda (start len)
(super-after-delete start len) (super-after-delete 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))
(sequence (super-instantiate ())))
(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
(lambda ()
(let loop ([s (find-first-snip)]) (let loop ([s (find-first-snip)])
(cond (cond
[(not s) #t] [(not s) #t]
[(is-a? s string-snip%) [(is-a? s string-snip%)
(loop (send s next))] (loop (send s next))]
[else #f])))]) [else #f])))
(override (override on-save-file)
[on-save-file (define (on-save-file name format)
(lambda (name format)
(let ([all-strings? (all-string-snips)]) (let ([all-strings? (all-string-snips)])
(cond (cond
[(and all-strings? [(and all-strings?
@ -472,11 +456,11 @@
"Save this file in drscheme-specific non-text format?" "Yes" "No"))) "Save this file in drscheme-specific non-text format?" "Yes" "No")))
(set-file-format 'standard)] (set-file-format 'standard)]
[else (void)])) [else (void)]))
(super-on-save-file name format))]) (super-on-save-file name format))
(sequence (super-instantiate ())))
(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