From 955df62409ce23a2d80f967552b4aaf66c3f132f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 13:52:11 -0600 Subject: [PATCH] update hierlist for new selection drawing --- collects/mrlib/hierlist/hierlist-unit.rkt | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/collects/mrlib/hierlist/hierlist-unit.rkt b/collects/mrlib/hierlist/hierlist-unit.rkt index 266efa79a5..5f946b68ed 100644 --- a/collects/mrlib/hierlist/hierlist-unit.rkt +++ b/collects/mrlib/hierlist/hierlist-unit.rkt @@ -27,10 +27,10 @@ (define transparent (make-object brush% "WHITE" 'transparent)) (define transparent-pen (make-object pen% "WHITE" 1 'transparent)) - (define black-xor-pen (make-object pen% "BLACK" 1 'hilite)) + (define black-xor-pen (make-object pen% (get-highlight-background-color) 1 'solid)) (define red (make-object brush% "RED" 'solid)) (define blue (make-object brush% "BLUE" 'solid)) - (define black-xor (make-object brush% "BLACK" 'hilite)) + (define black-xor (make-object brush% (get-highlight-background-color) 'solid)) (define arrow-cursor (make-object cursor% 'arrow)) (define-values (up-bitmap down-bitmap up-click-bitmap down-click-bitmap) @@ -285,9 +285,17 @@ (set-max-width (if (positive? w) w 'none)))))])] + [refresh (lambda (x y width height draw-caret background) + (super refresh x y width height + (if (and selected? + (or (not (send top show-focus)) + (send top has-focus?))) + (cons 0 1) + draw-caret) + background))] [on-paint (lambda (pre? dc left top_ right bottom dx dy caret) - (when (and (not pre?) selected?) + (when (and pre? selected?) (let ([b (send dc get-brush)] [p (send dc get-pen)] [filled? (or (not (send top show-focus)) @@ -652,7 +660,7 @@ (define hierarchical-list% (class100 editor-canvas% (parent [style '(no-hscroll)]) - (inherit min-width min-height allow-tab-exit) + (inherit min-width min-height allow-tab-exit refresh) (rename [super-on-char on-char] [super-on-focus on-focus]) (public