From cfb303435064747fbb3f067caff4fc95a3dcbb07 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 11 Nov 2002 06:24:51 +0000 Subject: [PATCH] .. original commit: a7c7a9b92554dfa59fda081e1bc9fd29d9d51757 --- collects/framework/decorated-editor-snip.ss | 125 +++++++++----- collects/framework/private/comment-box.ss | 16 +- collects/framework/private/frame.ss | 180 ++++++++++---------- collects/framework/private/scheme.ss | 18 ++ 4 files changed, 209 insertions(+), 130 deletions(-) diff --git a/collects/framework/decorated-editor-snip.ss b/collects/framework/decorated-editor-snip.ss index f42da2be..b916e018 100644 --- a/collects/framework/decorated-editor-snip.ss +++ b/collects/framework/decorated-editor-snip.ss @@ -30,6 +30,13 @@ ;; when clicking in the top part of the snip. (define/public (get-menu) #f) + ;; get-position : -> (union 'top-right 'left-top) + ;; returns the location of the image and the clickable + ;; region. 'top-right indicates top portion is clickable + ;; and icon on right. 'left-top means left portion is + ;; clickable and icon on top. + (define/public (get-position) 'top-right) + [define/private (get-pen) (send the-pen-list find-or-create-pen (get-color) 1 'solid)] [define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)] @@ -49,18 +56,26 @@ [bml (box 0)] [bmt (box 0)] [bmr (box 0)] - [bmb (box 0)]) + [bmb (box 0)] + [menu (get-menu)]) (get-extent dc x y bw bh #f #f #f #f) (get-inset bil bit bir bib) (get-margin bml bmt bmr bmb) - (let ([menu (get-menu)]) + (let ([in-range + (case (get-position) + [(top-right) + (and (<= 0 sx (unbox bw)) + (<= 0 sy (unbox bmt)))] + [(left-top) + (and (<= 0 sx (unbox bml)) + (<= 0 sy (unbox bh)))] + [else #f])]) (cond - [(and menu - (<= 0 sx (unbox bw)) - (<= 0 sy (unbox bmt))) + [(and menu in-range) (let ([admin (get-admin)]) - (send admin popup-menu menu this (+ sx 1) (+ sy 1)))] - [else (super-on-event dc x y editorx editory evt)])))] + (when admin + (send admin popup-menu menu this (+ sx 1) (+ sy 1))))] + [else (super-on-event dc x y editorx editory evt)])))] [else (super-on-event dc x y editorx editory evt)])) @@ -87,11 +102,19 @@ (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent)) (send dc set-brush (send the-brush-list find-or-create-brush "white" 'solid)) - (send dc draw-rectangle - (+ x (unbox bml)) - (+ y (unbox bit)) - (max 0 (- (unbox bw) (unbox bml) (unbox bmr))) - (- (unbox bmt) (unbox bit))) + (case (get-position) + [(top-right) + (send dc draw-rectangle + (+ x (unbox bml)) + (+ y (unbox bit)) + (max 0 (- (unbox bw) (unbox bml) (unbox bmr))) + (- (unbox bmt) (unbox bit)))] + [(left-top) + (send dc draw-rectangle + (+ x (unbox bil)) + (+ y (unbox bmt)) + (- (unbox bml) (unbox bil)) + (max 0 (- (unbox bh) (unbox bmt) (unbox bmb))))]) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) (send dc set-brush (send the-brush-list find-or-create-brush "black" 'solid)) @@ -99,14 +122,22 @@ (when bm (let ([bm-w (send bm get-width)] [bm-h (send bm get-height)]) - (send dc draw-bitmap - bm - (+ x (max 0 - (- (unbox bw) - (unbox bmr) - bm-w))) - ;; leave two pixels above and two below (see super-instantiate below) - (+ y (unbox bit) 2)))) + (case (get-position) + [(top-right) + (send dc draw-bitmap + bm + (+ x (max 0 + (- (unbox bw) + (unbox bmr) + bm-w))) + ;; leave two pixels above and two below (see super-instantiate below) + (+ y (unbox bit) 2))] + [(left-top) + (send dc draw-bitmap + bm + ;; leave two pixels left and two right (see super-instantiate below) + (+ x (unbox bil) 2) + (+ y (unbox bmt)))]))) (send dc set-pen (get-pen)) (send dc set-brush (get-brush)) @@ -129,29 +160,41 @@ (send snip set-style (get-style)) snip)) - (inherit set-min-width get-margin) - (define/public (reset-min-width) - (let ([lib (box 0)] - [rib (box 0)] - [lmb (box 0)] - [rmb (box 0)]) - (get-inset lib (box 0) rib (box 0)) - (get-margin lmb (box 0) rmb (box 0)) - (let ([bm (get-corner-bitmap)]) - (when bm - (set-min-width - (max 0 (send bm get-width))))))) + (inherit set-min-width set-min-height get-margin) + (define/public (reset-min-sizes) + (let ([bm (get-corner-bitmap)]) + (when bm + (case (get-position) + [(top-right) + (set-min-width (+ 4 (send bm get-width)))] + [(left-top) + (set-min-height (+ 4 (send bm get-height)))])))) - (super-instantiate () - (editor (make-editor)) - (with-border? #f) - (top-margin (+ 4 - (let ([bm (get-corner-bitmap)]) - (if bm - (send bm get-height) - 0))))) + (let ([top-margin + (case (get-position) + [(top-right) + (+ 4 + (let ([bm (get-corner-bitmap)]) + (if bm + (send bm get-height) + 0)))] + [else 4])] + [left-margin + (case (get-position) + [(left-top) + (+ 4 + (let ([bm (get-corner-bitmap)]) + (if bm + (send bm get-width) + 0)))] + [else 4])]) + (super-instantiate () + (editor (make-editor)) + (with-border? #f) + (top-margin top-margin) + (left-margin left-margin))) - (reset-min-width))) + (reset-min-sizes))) (define decorated-editor-snipclass% (class snip-class% diff --git a/collects/framework/private/comment-box.ss b/collects/framework/private/comment-box.ss index 82c1a747..c141ae45 100644 --- a/collects/framework/private/comment-box.ss +++ b/collects/framework/private/comment-box.ss @@ -13,8 +13,10 @@ (define comment-box@ (unit/sig framework:comment-box^ (import [text : framework:text^] - [scheme : framework:scheme^]) - (rename [-snip% snip%]) + [scheme : framework:scheme^] + [keymap : framework:keymap^]) + (rename [-snip% snip%] + [-text% text%]) (define snipclass% (class decorated-editor-snipclass% @@ -32,13 +34,21 @@ (and (send bm ok?) bm))))) + (define (editor-keymap-mixin %) + (class % + (rename [super-get-keymaps get-keymaps]) + (define/override (get-keymaps) + (cons (keymap:get-file) (super-get-keymaps))) + (super-instantiate ()))) + (define -snip% (class* decorated-editor-snip% (readable-snip<%>) (inherit get-editor get-style) - (define/override (make-editor) (make-object (scheme:text-mixin text:keymap%))) + (define/override (make-editor) (make-object (scheme:text-mixin (editor-keymap-mixin text:keymap%)))) (define/override (make-snip) (make-object -snip%)) (define/override (get-corner-bitmap) bm) + (define/override (get-position) 'left-top) (rename [super-get-text get-text]) (define/override get-text diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 0b7aaba7..4ddb7558 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1843,89 +1843,97 @@ (send tx get-start-position) (send tx get-end-position)) (send find-edit get-text 0 (send find-edit last-position))))))) - (define replace&search - (lambda () - (let ([text (get-text-to-search)]) - (send text begin-edit-sequence) - (when (replace) - (search-again)) - (send text end-edit-sequence)))) - (define replace-all - (lambda () - (let* ([replacee-edit (get-text-to-search)] - [pos (if (eq? searching-direction 'forward) - (send replacee-edit get-start-position) - (send replacee-edit get-end-position))] - [done? (if (eq? 'forward searching-direction) - (lambda (x) (>= x (send replacee-edit last-position))) - (lambda (x) (<= x 0)))]) - (send* replacee-edit - (begin-edit-sequence) - (set-position pos)) - (when (search-again) - (send replacee-edit set-position pos) - (let loop () - (when (send find-edit search #t #f #f) - (replace) - (loop)))) - (send replacee-edit end-edit-sequence)))) - (define replace - (lambda () - (let* ([search-text (send find-edit get-text)] - [replacee-edit (get-text-to-search)] - [replacee-start (send replacee-edit get-start-position)] - [new-text (send replace-edit get-text)] - [replacee (send replacee-edit get-text - replacee-start - (send replacee-edit get-end-position))]) - (if (string=? replacee search-text) - (begin (send replacee-edit insert new-text) - (send replacee-edit set-position - replacee-start - (+ replacee-start (string-length new-text))) - #t) - #f)))) - (define toggle-search-focus - (lambda () - (set-searching-frame this) - (unhide-search) - (send (cond - [(send find-canvas has-focus?) - replace-canvas] - [(send replace-canvas has-focus?) - (send (get-text-to-search) get-canvas)] - [else - find-canvas]) - focus))) - (define move-to-search-or-search - (lambda () - (set-searching-frame this) - (unhide-search) - (cond - [(preferences:get 'framework:search-using-dialog?) - (search-dialog this)] - [else - (if (or (send find-canvas has-focus?) - (send replace-canvas has-focus?)) - (search-again 'forward) - (send find-canvas focus))]))) - (define move-to-search-or-reverse-search - (lambda () - (set-searching-frame this) - (unhide-search) - (if (or (send find-canvas has-focus?) - (send replace-canvas has-focus?)) - (search-again 'backward) - (send find-canvas focus)))) - (define search-again - (opt-lambda ([direction searching-direction] [beep? #t]) - (set-searching-frame this) - (unhide-search) - (set-search-direction direction) - (send find-edit search #t beep?))) + (define replace&search + (lambda () + (let ([text (get-text-to-search)]) + (send text begin-edit-sequence) + (when (replace) + (search-again)) + (send text end-edit-sequence)))) + (define (replace-all) + (let* ([replacee-edit (get-text-to-search)] + [embeded-replacee-edit (find-embedded-focus-editor replacee-edit)] + [pos (if (eq? searching-direction 'forward) + (send embeded-replacee-edit get-start-position) + (send embeded-replacee-edit get-end-position))] + [done? (if (eq? 'forward searching-direction) + (lambda (x) (>= x (send replacee-edit last-position))) + (lambda (x) (<= x 0)))]) + (send replacee-edit begin-edit-sequence) + (when (search-again) + (send embeded-replacee-edit set-position pos) + (let loop () + (when (send find-edit search #t #f #f) + (replace) + (loop)))) + (send replacee-edit end-edit-sequence))) + (define (replace) + (let* ([search-text (send find-edit get-text)] + [replacee-edit (find-embedded-focus-editor (get-text-to-search))] + [replacee-start (send replacee-edit get-start-position)] + [new-text (send replace-edit get-text)] + [replacee (send replacee-edit get-text + replacee-start + (send replacee-edit get-end-position))]) + (if (string=? replacee search-text) + (begin (send replacee-edit insert new-text) + (send replacee-edit set-position + replacee-start + (+ replacee-start (string-length new-text))) + #t) + #f))) + + (define/private (find-embedded-focus-editor editor) + (let loop ([editor editor]) + (let ([s (send editor get-focus-snip)]) + (cond + [(and s (is-a? s editor-snip%)) + (let ([next-ed (send s get-editor)]) + (if next-ed + (loop next-ed) + editor))] + [else editor])))) + + (define (toggle-search-focus) + (set-searching-frame this) + (unhide-search) + (send (cond + [(send find-canvas has-focus?) + replace-canvas] + [(send replace-canvas has-focus?) + (send (get-text-to-search) get-canvas)] + [else + find-canvas]) + focus)) + (define move-to-search-or-search + (lambda () + (set-searching-frame this) + (unhide-search) + (cond + [(preferences:get 'framework:search-using-dialog?) + (search-dialog this)] + [else + (if (or (send find-canvas has-focus?) + (send replace-canvas has-focus?)) + (search-again 'forward) + (send find-canvas focus))]))) + (define move-to-search-or-reverse-search + (lambda () + (set-searching-frame this) + (unhide-search) + (if (or (send find-canvas has-focus?) + (send replace-canvas has-focus?)) + (search-again 'backward) + (send find-canvas focus)))) + (define search-again + (opt-lambda ([direction searching-direction] [beep? #t]) + (set-searching-frame this) + (unhide-search) + (set-search-direction direction) + (send find-edit search #t beep?))) (super-instantiate ()) - + (define search-panel (make-object horizontal-panel% super-root '(border))) (define left-panel (make-object vertical-panel% search-panel)) @@ -1944,7 +1952,7 @@ (string-constant find) middle-left-panel (lambda args (search-again)))) - + (define replace-button-panel (instantiate vertical-panel% () (parent middle-left-panel) @@ -1959,7 +1967,7 @@ (string-constant replace&find-again) middle-middle-panel (lambda x (replace&search)))) - + (define replace-all-button (make-object button% (string-constant replace-to-end) middle-middle-panel @@ -1978,13 +1986,13 @@ (reset-search-anchor (get-text-to-search)))))) (define hide/undock-pane (make-object horizontal-panel% middle-right-panel)) (define hide-button (make-object button% (string-constant hide) - hide/undock-pane - (lambda args (hide-search)))) + hide/undock-pane + (lambda args (hide-search)))) (define undock-button (make-object button% (string-constant undock) hide/undock-pane (lambda args (undock)))) (define hidden? #f) - + (let ([align (lambda (x y) (let ([m (max (send x get-width) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index e3885038..9402ccd5 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -886,6 +886,24 @@ (end-edit-sequence) #t))) + ;; uncomment-box/selection : -> void + ;; uncomments a comment box, if the focus is inside one. + ;; otherwise, calls uncomment selection to uncomment + ;; something else. + (inherit get-focus-snip) + (define/public (uncomment-box/selection) + (begin-edit-sequence) + (let ([focus-snip (get-focus-snip)]) + (cond + [(not focus-snip) (uncomment-selection)] + [(is-a? focus-snip comment-box:snip%) + (extract-contents + (get-snip-position focus-snip) + focus-snip)] + [else (uncomment-selection)])) + (end-edit-sequence) + #t) + (define uncomment-selection (opt-lambda ([start-pos (get-start-position)] [end-pos (get-end-position)])