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

...

Browse Source 
original commit: 1389fe8a579adaeebe66e5501f45334f99bbe239
This commit is contained in:
Robby Findler 2001-11-09 03:56:55 +00:00
parent 42e5229de7
commit a5a81a079e
5 changed files with 252 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -204,7 +204,7 @@
(stretchable-height #t)
(min-width (inexact->exact (floor (max w1 w2))))
(min-height (inexact->exact (floor (+ 4 (max h1 h2))))))))))
(define info<%> (interface (basic<%>)
determine-width
lock-status-changed
@ -702,15 +702,20 @@
(when file
(send (get-editor) save-file file format))))]
(inherit get-checkable-menu-item% get-menu-item%)
(override file-menu:revert-callback file-menu:create-revert? file-menu:save-callback
(override file-menu:save-callback
file-menu:create-save? file-menu:save-as-callback file-menu:create-save-as?
file-menu:print-callback file-menu:create-print?)
[define file-menu:revert-callback
[define/override (file-menu:revert-on-demand item)
(send item enable (not (send (get-editor) is-locked?)))]
[define/override file-menu:revert-callback
(lambda (item control)
(let* ([b (box #f)]
[edit (get-editor)]
(let* ([edit (get-editor)]
[b (box #f)]
[filename (send edit get-filename b)])
(if (or (not filename) (unbox b))
(if (or (not filename)
(unbox b))
(bell)
(let ([start
(if (is-a? edit text%)
@ -730,9 +735,10 @@
(send edit end-edit-sequence)
(message-box
(string-constant error-reverting)
(format (string-constant could-not-read) filename)))))))
#t))]
[define file-menu:create-revert? (lambda () #t)]
(format (string-constant could-not-read) filename)
this)))))))
#t)]
[define/override file-menu:create-revert? (lambda () #t)]
[define file-menu:save-callback (lambda (item control)
(send (get-editor) save-file)
#t)]
@ -860,6 +866,104 @@
[define get-editor% (lambda () pasteboard:keymap%)]
(super-instantiate ())))
(define delegate<%>
(interface (text<%>)
get-delegated-text
delegated-text-shown?
hide-delegated-text
show-delegated-text))
(define delegate-editor-canvas%
(class editor-canvas%
(rename [super-on-event on-event])
(init-field delegate-frame)
(inherit get-editor)
(define/override (on-event evt)
(super-on-event evt)
(when (and delegate-frame
(send evt button-down?))
(let ([text (get-editor)])
(when (is-a? text text%)
(let-values ([(editor-x editor-y)
(send text dc-location-to-editor-location
(send evt get-x)
(send evt get-y))])
(send delegate-frame click-in-overview
(send text find-position editor-x editor-y)))))))
(super-instantiate ())))
(define delegate-mixin
(mixin (text<%>) (delegate<%>)
(define/public (get-delegated-text) (get-editor))
(rename [super-make-root-area-container make-root-area-container])
[define rest-panel 'uninitialized-root]
[define super-root 'uninitialized-super-root]
(override make-root-area-container)
[define make-root-area-container
(lambda (% parent)
(let* ([s-root (super-make-root-area-container
horizontal-panel%
parent)]
[r-root (make-object % s-root)])
(set! super-root s-root)
(set! rest-panel r-root)
r-root))]
(rename [super-get-editor% get-editor%])
(define/override (get-editor%)
(text:delegate-mixin (super-get-editor%)))
(field (shown? (preferences:get 'framework:show-delegate?)))
(define/public (delegated-text-shown?)
shown?)
(define/public (hide-delegated-text)
(set! shown? #f)
(send (get-delegated-text) set-delegate #f)
(send super-root change-children
(lambda (l) (list rest-panel))))
(define/public (show-delegated-text)
(set! shown? #t)
(send (get-delegated-text) set-delegate delegatee)
(send super-root change-children
(lambda (l) (list rest-panel delegate-ec))))
(define/public (click-in-overview pos)
(when shown?
(let* ([d-text (get-delegated-text)]
[d-canvas (send d-text get-canvas)]
[bx (box 0)]
[by (box 0)])
(let-values ([(cw ch) (send d-canvas get-client-size)])
(send d-text position-location pos bx by)
(send d-canvas scroll-to
(- (unbox bx) (/ cw 2))
(- (unbox by) (/ ch 2))
cw
ch
#t)))))
(super-instantiate ())
(define delegatee (instantiate text:basic% ()))
(define delegate-ec (instantiate delegate-editor-canvas% ()
(editor delegatee)
(parent super-root)
(delegate-frame this)
(min-width 150)
(stretchable-width #f)))
(inherit get-editor)
(if (preferences:get 'framework:show-delegate?)
(begin
(send (get-delegated-text) set-delegate delegatee)
(send super-root change-children
(lambda (l) (list rest-panel delegate-ec))))
(begin
(send (get-delegated-text) set-delegate #f)
(send super-root change-children (lambda (l) (list rest-panel)))))))
(define (search-dialog frame)
(init-find/replace-edits)
(keymap:call/text-keymap-initializer
@ -1585,6 +1689,7 @@
(define -text% (text-mixin editor%))
(define text-info-file% (file-mixin -text%))
(define searchable% (searchable-text-mixin (searchable-mixin text-info-file%)))
(define delegate% (delegate-mixin searchable%))
(define -pasteboard% (pasteboard-mixin editor%))
(define pasteboard-info-file% (file-mixin -pasteboard%)))))

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

@ -160,6 +160,8 @@
;; split-out : char (listof char) -> (listof (listof char))
;; splits a list of characters at its first argument
;; if the last character is the same as the first character,
;; it is not split into an empty list, but returned.
(define (split-out split-char chars)
(let loop ([chars chars]
[this-split null]
@ -170,9 +172,13 @@
[else (let ([char (car chars)])
(cond
[(char=? split-char char)
(loop (cdr chars)
null
(cons (reverse this-split) all-split))]
(if (null? (cdr chars))
(loop null
(cons char this-split)
all-split)
(loop (cdr chars)
null
(cons (reverse this-split) all-split)))]
[else
(loop (cdr chars)
(cons char this-split)

16
collects/framework/private/main.ss
View File

@ -15,22 +15,16 @@
[group : framework:group^])
;; preferences
(preferences:set-default 'framework:show-delegate? #f boolean?)
(preferences:set-default 'framework:recently-opened-files null
(lambda (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:search-using-dialog? #t boolean?)
(preferences:set-default 'framework:windows-mdi #f boolean?)
(preferences:set-default 'framework:menu-bindings #t boolean?)
(preferences:set-default 'framework:verify-change-format #f boolean?)
(preferences:set-default 'framework:auto-set-wrap? #t boolean?)
(preferences:set-default 'framework:display-line-numbers #t boolean?)
(preferences:set-default 'framework:show-status-line #t boolean?)
(preferences:set-default 'framework:line-offsets #t boolean?)
@ -39,22 +33,17 @@
'standard
(lambda (x) (or (eq? x 'standard) (eq? x 'postscript))))
(define (add-#% x)
(string->symbol (string-append "#%" (symbol->string x))))
(preferences:set-default 'framework:highlight-parens #t boolean?)
(preferences:set-default 'framework:fixup-parens #t boolean?)
(preferences:set-default 'framework:paren-match #t boolean?)
(let ([hash-table (make-hash-table)])
(for-each (lambda (x)
(hash-table-put! hash-table (add-#% x) 'define)
(hash-table-put! hash-table x 'define))
'(define defmacro define-macro
define-values
define/public define/override define/private define/field
define-signature define-syntax define-schema))
(for-each (lambda (x)
(hash-table-put! hash-table (add-#% x) 'begin)
(hash-table-put! hash-table x 'begin))
'(cond case-lambda
begin begin0 delay
@ -62,7 +51,6 @@
public private override
inherit sequence))
(for-each (lambda (x)
(hash-table-put! hash-table (add-#% x) 'lambda)
(hash-table-put! hash-table x 'lambda))
'(
instantiate super-instantiate

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

@ -133,6 +133,7 @@
(define-signature framework:text^
(basic<%>
hide-caret/selection<%>
delegate<%>
searching<%>
return<%>
info<%>
@ -140,6 +141,7 @@
basic-mixin
hide-caret/selection-mixin
delegate-mixin
searching-mixin
return-mixin
info-mixin
@ -147,6 +149,7 @@
basic%
hide-caret/selection%
delegate%
keymap%
return%
autowrap%
@ -188,6 +191,9 @@
pasteboard<%>
pasteboard-mixin
delegate<%>
delegate-mixin
searchable<%>
searchable-mixin
@ -216,6 +222,7 @@
text%
text-info-file%
searchable%
delegate%
pasteboard%
pasteboard-info-file%))

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

@ -375,6 +375,124 @@
(super-on-local-char key))))
(super-instantiate ())))
(define delegate<%> (interface (basic<%>)
get-delegate
get-delegate-style-delta
set-delegate-style-delta))
(define small-style-delta (make-object style-delta% 'change-size 2))
(define delegate-mixin
(mixin (basic<%>) (delegate<%>)
(inherit split-snip find-snip get-snip-position
find-first-snip get-style-list)
(field (delegate #f))
(define/public (get-delegate) delegate)
(define/public (set-delegate _d)
(set! delegate _d)
(when delegate
(send delegate begin-edit-sequence)
(send delegate lock #f)
(send delegate hide-caret #t)
(send delegate erase)
(send delegate set-style-list (get-style-list))
(let loop ([snip (find-first-snip)])
(when snip
(send delegate insert
(send snip copy)
(send delegate last-position)
(send delegate last-position))
(loop (send snip next))))
(send delegate change-style
delegate-style-delta
0
(send delegate last-position))
(send delegate lock #t)
(send delegate end-edit-sequence)))
(define delegate-style-delta (make-object style-delta% 'change-size 1))
(define/public (get-delegate-style-delta)
delegate-style-delta)
(define/public (set-delegate-style-delta _sd)
(set! delegate-style-delta _sd))
(rename [super-on-edit-sequence on-edit-sequence])
(define/override (on-edit-sequence)
(super-on-edit-sequence)
(when delegate
(send delegate begin-edit-sequence)))
(rename [super-after-edit-sequence after-edit-sequence])
(define/override (after-edit-sequence)
(super-after-edit-sequence)
(when delegate
(send delegate end-edit-sequence)))
(rename [super-after-insert after-insert])
(define/override (after-insert start len)
(super-after-insert start len)
(when delegate
(send delegate begin-edit-sequence)
(send delegate lock #f)
(split-snip start)
(split-snip (+ start len))
(let loop ([snip (find-snip (+ start len) 'before)])
(when snip
(unless ((get-snip-position snip) . < . start)
(send delegate insert (send snip copy) start start)
(loop (send snip previous)))))
(send delegate change-style delegate-style-delta start (+ start len))
(send delegate lock #t)
(send delegate end-edit-sequence)))
(rename [super-after-delete after-delete])
(define/override (after-delete start len)
(super-after-delete start len)
(when delegate
(send delegate lock #f)
(send delegate begin-edit-sequence)
(send delegate delete start (+ start len))
(send delegate end-edit-sequence)
(send delegate lock #t)))
(rename [super-after-change-style after-change-style])
(define/override (after-change-style start len)
(super-after-change-style start len)
(when delegate
(send delegate begin-edit-sequence)
(send delegate lock #f)
(split-snip start)
(let* ([snip (find-snip start 'after)]
[style (send snip get-style)]
[other-style
(send (send delegate get-style-list) find-or-create-style
style delegate-style-delta)])
(send delegate change-style other-style start (+ start len)))
(send delegate lock #f)
(send delegate end-edit-sequence)))
(field (filename #f)
(format #f))
(rename [super-on-load-file on-load-file]
[super-after-load-file after-load-file])
(define/override (on-load-file _filename _format)
(super-on-load-file _filename _format)
(set! filename _filename)
(set! format _format))
(define/override (after-load-file success?)
(super-after-load-file success?)
(when (and delegate success?)
(send delegate begin-edit-sequence)
(send delegate lock #f)
(send delegate load-file filename format)
(send delegate set-filename #f)
(send delegate change-style
delegate-style-delta
0
(send delegate last-position))
(send delegate lock #t)
(send delegate end-edit-sequence)))
(super-instantiate ())))
(define info<%> (interface (basic<%>)))
(define info-mixin
@ -425,7 +543,7 @@
(lambda (x) (send x editor-position-changed))
'framework:editor-position-changed))
(super-instantiate ())))
(define clever-file-format<%> (interface ((class->interface text%))))
(define clever-file-format-mixin
@ -467,6 +585,7 @@
(define basic% (basic-mixin (editor:basic-mixin text%)))
(define hide-caret/selection% (hide-caret/selection-mixin basic%))
(define delegate% (delegate-mixin basic%))
(define -keymap% (editor:keymap-mixin basic%))
(define return% (return-mixin -keymap%))
(define autowrap% (editor:autowrap-mixin -keymap%))