text-first-line.rkt
1 #lang racket/base 2 (require racket/unit 3 racket/class 4 mred/mred-sig 5 "text-sig.rkt" 6 "interfaces.rkt" 7 "../preferences.rkt") 8 (provide text-first-line@) 9 10 (define-unit text-first-line@ 11 (import mred^ 12 text-line-numbers^) 13 (export text-first-line^) 14 15 (define first-line<%> 16 (interface () 17 highlight-first-line 18 get-first-line-height 19 first-line-currently-drawn-specially? 20 is-special-first-line?)) 21 22 (define dark-first-line-color (make-object color% 50 0 50)) 23 24 (define first-line-mixin 25 (mixin ((class->interface text%)) (first-line<%>) 26 (inherit get-text paragraph-end-position get-admin invalidate-bitmap-cache position-location 27 scroll-to local-to-global get-dc get-padding) 28 (define bx (box 0)) 29 (define by (box 0)) 30 (define bw (box 0)) 31 32 (define fancy-first-line? #f) 33 34 (define first-line "") 35 (define end-of-first-line 0) 36 (define first-line-is-lang? #f) 37 38 (define/public-final (highlight-first-line on?) 39 (unless (equal? fancy-first-line? on?) 40 (set! fancy-first-line? on?) 41 (invalidate-bitmap-cache) 42 (let ([canvas (send this get-canvas)]) 43 (when canvas 44 (send canvas refresh))))) 45 46 (define/public-final (get-first-line-height) 47 (let-values ([(_1 h _2 _3) (send (get-dc) get-text-extent first-line (get-font))]) 48 h)) 49 50 (define/public-final (first-line-currently-drawn-specially?) 51 (and (show-first-line?) 52 (let ([admin (get-admin)]) 53 (and admin 54 (begin 55 (send admin get-view #f by #f #f #f) 56 (not (= (unbox by) 0))))))) 57 58 (define/public (is-special-first-line? l) #f) 59 60 (define/private (show-first-line?) 61 (and fancy-first-line? first-line-is-lang?)) 62 63 (define/private (update-first-line) 64 (set! end-of-first-line (paragraph-end-position 0)) 65 (set! first-line (get-text 0 end-of-first-line)) 66 (set! first-line-is-lang? (is-special-first-line? first-line))) 67 68 (define/augment (after-insert start len) 69 (when (<= start end-of-first-line) 70 (update-first-line)) 71 (inner (void) after-insert start len)) 72 (define/augment (after-delete start len) 73 (when (<= start end-of-first-line) 74 (update-first-line)) 75 (inner (void) after-delete start len)) 76 77 (define/override (scroll-editor-to localx localy width height refresh? bias) 78 (let ([admin (get-admin)]) 79 (cond 80 [(not admin) 81 #f] 82 [(show-first-line?) 83 (let ([h (get-first-line-height)]) 84 (set-box! by localy) 85 (local-to-global #f by) 86 (cond 87 [(<= (unbox by) h) 88 ;; the max is relevant when we're already scrolled to the top. 89 (super scroll-editor-to localx (max 0 (- localy h)) width height refresh? bias)] 90 [else 91 (super scroll-editor-to localx localy width height refresh? bias)]))] 92 [else 93 (super scroll-editor-to localx localy width height refresh? bias)]))) 94 95 (define/override (on-event event) 96 (cond 97 [(or (send event moving?) 98 (send event leaving?) 99 (send event entering?)) 100 (super on-event event)] 101 [else 102 (let ([y (send event get-y)] 103 [h (get-first-line-height)] 104 [admin (get-admin)]) 105 (unless admin (send admin get-view #f by #f #f #f)) 106 (cond 107 [(and admin 108 (< y h) 109 (not (= (unbox by) 0))) 110 (send admin scroll-to (send event get-x) 0 0 0 #t) 111 (super on-event event)] 112 [else 113 (super on-event event)]))])) 114 115 (define to-invalidate #f) 116 (define/override (on-scroll-to) 117 (super on-scroll-to) 118 (set! to-invalidate (get-region-to-draw))) 119 (define/override (after-scroll-to) 120 (super after-scroll-to) 121 (define (maybe-invalidate) 122 (when to-invalidate 123 (invalidate-bitmap-cache 124 (list-ref to-invalidate 0) 125 (list-ref to-invalidate 1) 126 (list-ref to-invalidate 2) 127 (list-ref to-invalidate 3)) 128 (set! to-invalidate #f))) 129 (maybe-invalidate) 130 (set! to-invalidate (get-region-to-draw)) 131 (maybe-invalidate)) 132 (define/private (get-region-to-draw) 133 (cond 134 [(show-first-line?) 135 (define admin (get-admin)) 136 (cond 137 [admin 138 (send admin get-view bx by bw #f #f) 139 (define first-line (get-text 0 (paragraph-end-position 0))) 140 (define-values (tw th _1 _2) (send (get-dc) get-text-extent first-line (get-font))) 141 (list (unbox bx) (unbox by) (unbox bw) (+ th extra-fade-space))] 142 [else #f])] 143 [else #f])) 144 145 (define extra-fade-space 11) 146 147 (define/override (on-paint before? dc left top right bottom dx dy draw-caret) 148 (unless before? 149 (when (show-first-line?) 150 (define admin (get-admin)) 151 (when admin 152 (send admin get-view bx by bw #f #f) 153 (define y-coord (unbox by)) 154 (unless (= y-coord 0) 155 (define draw-first-line-number? 156 (and (is-a? this line-numbers<%>) 157 (send this showing-line-numbers?))) 158 (define first-line (get-text 0 (paragraph-end-position 0))) 159 (define old-pen (send dc get-pen)) 160 (define old-brush (send dc get-brush)) 161 (define old-smoothing (send dc get-smoothing)) 162 (define old-α (send dc get-alpha)) 163 (define old-font (send dc get-font)) 164 (define old-text-foreground (send dc get-text-foreground)) 165 (define old-text-mode (send dc get-text-mode)) 166 (define w-o-b? (preferences:get 'framework:white-on-black?)) 167 (send dc set-font (get-font)) 168 (send dc set-smoothing 'aligned) 169 (send dc set-text-mode 'transparent) 170 (define-values (tw th _1 _2) (send dc get-text-extent first-line)) 171 (define line-height (+ y-coord dy th 1)) 172 (define line-left (+ (unbox bx) dx)) 173 (define line-right (+ (unbox bx) dx (unbox bw))) 174 175 (if w-o-b? 176 (send dc set-pen "white" 1 'solid) 177 (send dc set-pen "black" 1 'solid)) 178 (send dc draw-line line-left line-height line-right line-height) 179 180 (when (eq? (send dc get-smoothing) 'aligned) 181 (define start (if w-o-b? 6/10 3/10)) 182 (define end 0) 183 (define steps (- extra-fade-space 1)) 184 (send dc set-pen 185 dark-first-line-color 186 1 187 'solid) 188 (let loop ([i steps]) 189 (unless (zero? i) 190 (define alpha-value (+ start (* (- end start) (/ i steps)))) 191 (send dc set-alpha alpha-value) 192 (send dc draw-line 193 line-left 194 (+ line-height i) 195 line-right 196 (+ line-height i)) 197 (loop (- i 1))))) 198 199 (send dc set-alpha 1) 200 (send dc set-pen "gray" 1 'transparent) 201 (send dc set-brush (if w-o-b? "black" "white") 'solid) 202 (send dc draw-rectangle (+ (unbox bx) dx) (+ y-coord dy) (unbox bw) (+ th 1)) 203 (send dc set-text-foreground 204 (send the-color-database find-color 205 (if w-o-b? "white" "black"))) 206 (define x-start 207 (cond 208 [draw-first-line-number? 209 (send this do-draw-single-line dc dx dy 0 y-coord #f #f) 210 (send dc set-pen (if w-o-b? "white" "black") 1 'solid) 211 (send this draw-separator dc y-coord (+ y-coord line-height) dx dy) 212 (define-values (padding-left _1 _2 _3) (get-padding)) 213 padding-left] 214 [else 0])) 215 (send dc draw-text first-line (+ x-start (+ (unbox bx) dx)) (+ y-coord dy)) 216 217 (send dc set-text-foreground old-text-foreground) 218 (send dc set-text-mode old-text-mode) 219 (send dc set-font old-font) 220 (send dc set-pen old-pen) 221 (send dc set-brush old-brush) 222 (send dc set-alpha old-α) 223 (send dc set-smoothing old-smoothing))))) 224 (super on-paint before? dc left top right bottom dx dy draw-caret)) 225 226 (inherit get-style-list) 227 (define/private (get-font) 228 (define style-list (get-style-list)) 229 (define std (or (send style-list find-named-style "Standard") 230 (send style-list basic-style))) 231 (send std get-font)) 232 233 (super-new))))