From a5a81a079e3b22c6a967ba0b732c73b7a475a3ae Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 9 Nov 2001 03:56:55 +0000 Subject: [PATCH] ... original commit: 1389fe8a579adaeebe66e5501f45334f99bbe239 --- collects/framework/private/frame.ss | 123 +++++++++++++++++++++++++-- collects/framework/private/keymap.ss | 12 ++- collects/framework/private/main.ss | 16 +--- collects/framework/private/sig.ss | 7 ++ collects/framework/private/text.ss | 121 +++++++++++++++++++++++++- 5 files changed, 252 insertions(+), 27 deletions(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 68e203ba..c42ab656 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -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%))))) diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index c3e80c32..419453e4 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -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) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 69f4fb8f..a8e9a59a 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -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 diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 777adf3d..e69447d1 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -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%)) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index c31b47b3..489ede03 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -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%))