From bf16591182b1e75086f066f9a29684f8b492ddeb Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 1 Jun 2003 04:19:12 +0000 Subject: [PATCH] .. original commit: 99d4ae8b1373b106a897126bf9a342428531826c --- collects/framework/framework.ss | 28 ++++++++++++ collects/framework/private/keymap.ss | 55 ++++++++++++++++++------ collects/framework/private/mode.ss | 8 ++-- collects/framework/private/scheme.ss | 64 ++++++++++++++-------------- collects/framework/private/sig.ss | 13 ++++-- 5 files changed, 118 insertions(+), 50 deletions(-) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 32435558..de2adff7 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -1195,6 +1195,34 @@ "@link keymap" "with the bindings for searching.") + (keymap:set-chained-keymaps + ((is-a?/c keymap:aug-keymap<%>) + (listof (is-a?/c keymap%)) + . -> . + void?) + (keymap children-keymaps) + "Sets \\var{keymap}'s chained keymaps to \\var{children-keymaps}," + "unchaining any keymaps that are currently chained to \\var{keymap}.") + + (keymap:remove-chained-keymap + ((is-a?/c editor<%>) + (is-a?/c keymap:aug-keymap<%>) + . -> . + void?) + (editor keymap) + "Removes \\var{keymap} from the keymaps chained to \\var{editor}." + "Also (indirectly) removes all keymaps chained to \\var{keymap} from \\var{editor}," + "since they are removed when unchaining \\var{keymap} itself." + "" + "Each of the keymaps chained to \\var{editor} must be an" + "@ilink keymap:aug-keymap" + "and \\var{keymap} cannot be the result of" + "\\begin{schemedisplay}" + "(send editor get-keymap)" + "\\end{schemedisplay}" + "That is, \\var{keymap} must be chained to some keymap attached" + "to the editor.") + (scheme-paren:backward-containing-sexp (opt-> ((is-a?/c text%) diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index b479b297..85d82435 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -2,12 +2,11 @@ (module keymap mzscheme (require (lib "string-constant.ss" "string-constants") (lib "unitsig.ss") - "sig.ss" "../macro.ss" (lib "class.ss") - (lib "class100.ss") (lib "list.ss") - (lib "mred-sig.ss" "mred")) + (lib "mred-sig.ss" "mred") + "sig.ss") (provide keymap@) @@ -22,7 +21,35 @@ [editor : framework:editor^]) (rename [-get-file get-file]) + + (define (remove-chained-keymap ed keymap-to-remove) + (let ([ed-keymap (send ed get-keymap)]) + (when (eq? keymap-to-remove ed-keymap) + (error 'keymap:remove-keymap "cannot remove initial keymap from editor")) + (let p-loop ([parent-keymap ed-keymap]) + (unless (is-a? parent-keymap aug-keymap<%>) + (error 'keymap:remove-keymap + "found a keymap that is not a keymap:aug-keymap<%> ~e" + parent-keymap)) + (let c-loop ([child-keymaps (send parent-keymap get-chained-keymaps)]) + (cond + [(null? child-keymaps) null] + [else + (let ([child-keymap (car child-keymaps)]) + (cond + [(eq? child-keymap keymap-to-remove) + (send parent-keymap remove-chained-keymap child-keymap) + (c-loop (cdr child-keymaps))] + [else + (p-loop child-keymap) + (c-loop (cdr child-keymaps))]))]))))) + (define (set-chained-keymaps parent-keymap children-keymaps) + (for-each (lambda (orig-sub) (send parent-keymap remove-chained-keymap)) + (send parent-keymap get-chained-keymaps)) + (for-each (lambda (new-sub) (send parent-keymap chain-to-keymap new-sub #f)) + children-keymaps)) + (define aug-keymap<%> (interface ((class->interface keymap%)) get-chained-keymaps get-map-function-table @@ -35,16 +62,20 @@ [define get-chained-keymaps (lambda () chained-keymaps)] - (rename [super-chain-to-keymap chain-to-keymap]) - (override chain-to-keymap) - [define chain-to-keymap - (lambda (keymap prefix?) - (super-chain-to-keymap keymap prefix?) - (set! chained-keymaps - (if prefix? - (cons keymap chained-keymaps) - (append chained-keymaps (list keymap)))))] + (rename [super-chain-to-keymap chain-to-keymap]) + (define/override (chain-to-keymap keymap prefix?) + (super-chain-to-keymap keymap prefix?) + (set! chained-keymaps + (if prefix? + (cons keymap chained-keymaps) + (append chained-keymaps (list keymap))))) + + (rename [super-remove-chained-keymap remove-chained-keymap]) + (define/override (remove-chained-keymap keymap) + (super-remove-chained-keymap keymap) + (set! chained-keymaps (remq keymap chained-keymaps))) + [define function-table (make-hash-table)] (public get-function-table) [define get-function-table (lambda () function-table)] diff --git a/collects/framework/private/mode.ss b/collects/framework/private/mode.ss index abbc8adb..9c22c5cc 100644 --- a/collects/framework/private/mode.ss +++ b/collects/framework/private/mode.ss @@ -1,5 +1,5 @@ (module mode mzscheme - (require (lib "delegate.ss") + (require (lib "surrogate.ss") (lib "unitsig.ss") "sig.ss") @@ -9,8 +9,8 @@ (unit/sig framework:mode^ (import) - (define-values (delegating-text-mixin text% text<%>) - (delegate + (define-values (host-text-mixin surrogate-text% surrogate-text<%>) + (surrogate (on-change ()) (on-char (event)) (on-default-char (event)) @@ -48,6 +48,6 @@ (can-delete? (start len)) (can-insert? (start len)) (can-set-size-constraint? ()) - (can-do-edit-operation? (op recursive?)) + (can-do-edit-operation? (op) (op recursive?)) (can-load-file? (filename format)) (can-save-file? (filename format))))))) \ No newline at end of file diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 4f2d60f6..6955f377 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -317,7 +317,7 @@ (send style-list find-named-style "Matching Parenthesis Style"))) (define text-mixin - (mixin (text:basic<%> editor:keymap<%>) (-text<%>) + (mixin (text:basic<%>) (-text<%>) (inherit begin-edit-sequence delete end-edit-sequence @@ -407,12 +407,12 @@ (define/public highlight-parens (opt-lambda ([just-clear? #f]) - (when (preferences:get 'framework:highlight-parens) - (unless in-highlight-parens? - (set! in-highlight-parens? #t) - (begin-edit-sequence) - (clear-old-locations) - (set! clear-old-locations void) + (unless in-highlight-parens? + (set! in-highlight-parens? #t) + (begin-edit-sequence) + (clear-old-locations) + (set! clear-old-locations void) + (when (preferences:get 'framework:highlight-parens) (unless just-clear? (let* ([here (get-start-position)] [there (get-end-position)] @@ -489,9 +489,9 @@ (handle-single before)] [after (handle-single after)] [before (handle-single before)] - [else (void)]))))) - (end-edit-sequence) - (set! in-highlight-parens? #f))))) + [else (void)])))))) + (end-edit-sequence) + (set! in-highlight-parens? #f)))) (public get-limit balance-quotes balance-parens tabify-on-return? tabify tabify-selection tabify-all insert-return calc-last-para @@ -1074,23 +1074,17 @@ [define get-tab-size (lambda () tab-size)] [define set-tab-size (lambda (s) (set! tab-size s))] - (rename [super-get-keymaps get-keymaps]) - (override get-keymaps) - [define get-keymaps - (lambda () - (cons keymap (super-get-keymaps)))] - (rename [super-after-delete after-delete]) (define/override (after-delete start size) (send backward-cache invalidate start) (send forward-cache forward-invalidate (+ start size) (- size)) - ;; must call super after invalidating cache -- super calls delegate object + ;; must call super after invalidating cache -- super calls surrogate object (super-after-delete start size)) (rename [super-after-insert after-insert]) (define/override (after-insert start size) (send backward-cache invalidate start) (send forward-cache forward-invalidate start size) - ;; must call super after invalidating cache -- super calls delegate object + ;; must call super after invalidating cache -- super calls surrogate object (super-after-insert start size)) (super-instantiate ()))) @@ -1100,7 +1094,7 @@ )) (define text-mode-mixin - (mixin (mode:text<%>) (-text-mode<%>) + (mixin (mode:surrogate-text<%>) (-text-mode<%>) (rename [super-on-focus on-focus]) (define/override (on-focus text on?) (super-on-focus text on?) @@ -1117,9 +1111,8 @@ (rename [super-after-edit-sequence after-edit-sequence]) (define/override (after-edit-sequence text) (super-after-edit-sequence text) - (unless (send text local-edit-sequence?) - (when (send text has-focus?) - (send text highlight-parens)))) + (when (send text has-focus?) + (send text highlight-parens))) (rename [super-after-insert after-insert]) (define/override (after-insert text start size) @@ -1132,7 +1125,8 @@ (define/override (after-delete text start size) (unless (send text local-edit-sequence?) (when (send text has-focus?) - (send text highlight-parens)))) + (send text highlight-parens))) + (super-after-delete text start size)) (rename [super-after-set-size-constraint after-set-size-constraint]) (define/override (after-set-size-constraint text) @@ -1148,15 +1142,22 @@ (send text highlight-parens))) (super-after-set-position text)) - (rename [super-on-disable-delegate on-disable-delegate]) - (define/override (on-disable-delegate text) + (rename [super-on-disable-surrogate on-disable-surrogate]) + (define/override (on-disable-surrogate text) + (keymap:remove-chained-keymap text keymap) (send text highlight-parens #t) - (super-on-disable-delegate text)) + (super-on-disable-surrogate text)) - (rename [super-on-enable-delegate on-enable-delegate]) - (define/override (on-enable-delegate text) - (super-on-enable-delegate text) - (send text highlight-parens #t) + (rename [super-on-enable-surrogate on-enable-surrogate]) + (define/override (on-enable-surrogate text) + (super-on-enable-surrogate text) + (send (send text get-keymap) chain-to-keymap keymap #t) + (unless (send text local-edit-sequence?) + (when (send text has-focus?) + (send text highlight-parens))) + + ;; I don't know about these editor flag settings. + ;; maybe they belong in drscheme? (send text set-load-overwrites-styles #f) (send text set-wordbreak-map wordbreak-map) (send text set-tabs null (send text get-tab-size) #f) @@ -1165,7 +1166,8 @@ (super-instantiate ()))) (define -text% (text-mixin text:info%)) - + (define text-mode% (text-mode-mixin mode:surrogate-text%)) + ;; ;; ; ; diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 3257430a..a9a9b6d6 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -463,6 +463,9 @@ get-file get-editor + set-chained-keymaps + remove-chained-keymap + call/text-keymap-initializer)) (define-signature framework:keymap^ ((open framework:keymap-class^) @@ -494,7 +497,11 @@ (text<%> text-mixin text% + + text-mode<%> text-mode-mixin + text-mode% + sexp-snip% sexp-snip<%>)) (define-signature framework:scheme-fun^ @@ -525,9 +532,9 @@ (open framework:main-fun^))) (define-signature framework:mode-class^ - (delegating-text-mixin - text% - text<%>)) + (host-text-mixin + surrogate-text% + surrogate-text<%>)) (define-signature framework:mode-fun^ ()) (define-signature framework:mode^ ((open framework:mode-class^)