suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

moved the first-line-text stuff into the framework, added docs, added a pref to disable it and made it work a little bit better with check syntax

Browse Source 
svn: r11477

original commit: 6d34eaf3330c9544934334b6c2ca94adc86d495a
This commit is contained in:
Robby Findler 2008-08-29 04:24:34 +00:00
commit fbe1a57f34
3 changed files with 260 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/framework/private/sig.ss
View File

@ -159,6 +159,7 @@
(define-signature text-class^
(basic<%>
first-line<%>
foreground-color<%>
hide-caret/selection<%>
nbsp->space<%>
@ -192,6 +193,7 @@
input-box%
basic-mixin
first-line-mixin
foreground-color-mixin
hide-caret/selection-mixin
nbsp->space-mixin

179
collects/framework/private/text.ss
View File

@ -561,6 +561,185 @@ WARNING: printf is rebound in the body of the unit to always
(super-new)
(set-autowrap-bitmap (initial-autowrap-bitmap))))
(define first-line<%>
(interface ()
highlight-first-line
get-first-line-height
first-line-currently-drawn-specially?
is-special-first-line?))
(define dark-color (make-object color% 50 0 50))
(define dark-wob-color (make-object color% 255 200 255))
(define first-line-mixin
(mixin ((class->interface text%)) (first-line<%>)
(inherit get-text paragraph-end-position get-admin invalidate-bitmap-cache position-location
scroll-to local-to-global get-dc)
(define bx (box 0))
(define by (box 0))
(define bw (box 0))
(define fancy-first-line? #f)
(define first-line "")
(define end-of-first-line 0)
(define first-line-is-lang? #f)
(define/public-final (highlight-first-line on?)
(unless (equal? fancy-first-line? on?)
(set! fancy-first-line? on?)
(invalidate-bitmap-cache)
(let ([canvas (send this get-canvas)])
(when canvas
(send canvas refresh)))))
(define/public-final (get-first-line-height)
(let-values ([(_1 h _2 _3) (send (get-dc) get-text-extent first-line (get-font))])
h))
(define/public-final (first-line-currently-drawn-specially?)
(and (show-first-line?)
(let ([admin (get-admin)])
(and admin
(begin
(send admin get-view #f by #f #f #f)
(not (= (unbox by) 0)))))))
(define/public (is-special-first-line? l) #f)
(define/private (show-first-line?)
(and fancy-first-line? first-line-is-lang?))
(define/private (update-first-line)
(set! end-of-first-line (paragraph-end-position 0))
(set! first-line (get-text 0 end-of-first-line))
(set! first-line-is-lang? (is-special-first-line? first-line)))
(define/augment (after-insert start len)
(when (<= start end-of-first-line)
(update-first-line))
(inner (void) after-insert start len))
(define/augment (after-delete start len)
(when (<= start end-of-first-line)
(update-first-line))
(inner (void) after-delete start len))
(define/override (scroll-editor-to localx localy width height refresh? bias)
(let ([admin (get-admin)])
(cond
[(not admin)
#f]
[(show-first-line?)
(let ([h (get-first-line-height)])
(set-box! by localy)
(local-to-global #f by)
(cond
[(<= (unbox by) h)
;; the max is relevant when we're already scrolled to the top.
(send admin scroll-to localx (max 0 (- localy h)) width height refresh? bias)]
[else
(send admin scroll-to localx localy width height refresh? bias)]))]
[else
(send admin scroll-to localx localy width height refresh? bias)])))
(define/override (on-event event)
(cond
[(or (send event moving?)
(send event leaving?)
(send event entering?))
(super on-event event)]
[else
(let ([y (send event get-y)]
[h (get-first-line-height)]
[admin (get-admin)])
(unless admin (send admin get-view #f by #f #f #f))
(cond
[(and admin
(< y h)
(not (= (unbox by) 0)))
(send admin scroll-to (send event get-x) 0 0 0 #t)
(super on-event event)]
[else
(super on-event event)]))]))
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(unless before?
(when (show-first-line?)
(let ([admin (get-admin)])
(when admin
(send admin get-view bx by bw #f #f)
(unless (= (unbox by) 0)
(let ([first-line (get-text 0 (paragraph-end-position 0))]
[old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[old-smoothing (send dc get-smoothing)]
[old-α (send dc get-alpha)]
[old-font (send dc get-font)]
[old-text-foreground (send dc get-text-foreground)]
[w-o-b? (preferences:get 'framework:white-on-black?)])
(send dc set-font (get-font))
(send dc set-smoothing 'aligned)
(let-values ([(tw th _1 _2) (send dc get-text-extent first-line)])
(let ([line-height (+ (unbox by) dy th 1)]
[line-left (+ (unbox bx) dx)]
[line-right (+ (unbox bx) dx (unbox bw))])
(if w-o-b?
(send dc set-pen "white" 1 'solid)
(send dc set-pen "black" 1 'solid))
(send dc draw-line line-left line-height line-right line-height)
(when (eq? (send dc get-smoothing) 'aligned)
(let ([start (if w-o-b? 6/10 3/10)]
[end 0]
[steps 10])
(send dc set-pen
(if w-o-b? dark-wob-color dark-color)
1
'solid)
(let loop ([i steps])
(unless (zero? i)
(let ([alpha-value (+ start (* (- end start) (/ i steps)))])
(send dc set-alpha alpha-value)
(send dc draw-line
line-left
(+ line-height i)
line-right
(+ line-height i))
(loop (- i 1))))))))
(send dc set-alpha 1)
(send dc set-pen "gray" 1 'transparent)
(send dc set-brush (if w-o-b? "black" "white") 'solid)
(send dc draw-rectangle
(+ (unbox bx) dx)
(+ (unbox by) dy)
(unbox bw)
th)
(send dc set-text-foreground
(send the-color-database find-color
(if w-o-b? "white" "black")))
(send dc draw-text first-line (+ (unbox bx) dx) (+ (unbox by) dy)))
(send dc set-text-foreground old-text-foreground)
(send dc set-font old-font)
(send dc set-pen old-pen)
(send dc set-brush old-brush)
(send dc set-alpha old-α)
(send dc set-smoothing old-smoothing)))))))
(super on-paint before? dc left top right bottom dx dy draw-caret))
(inherit get-style-list)
(define/private (get-font)
(let* ([style-list (get-style-list)]
[std (or (send style-list find-named-style "Standard")
(send style-list find-named-style "Basic"))])
(send std get-font)))
(super-new)))
(define foreground-color<%>
(interface (basic<%> editor:standard-style-list<%>)
))

79
collects/scribblings/framework/text.scrbl
View File

@ -167,9 +167,88 @@
}
}
@definterface[text:first-line<%> (text%)]{
Objects implementing this interface, when
@method[text:first-line<%> highlight-first-line]
is invoked with @scheme[#t], always show their
first line, even with scrolled (as long as
@method[text:first-line<%> first-line-currently-drawn-specially?]
returns @scheme[#t]).
@defmethod[#:mode public-final (highlight-first-line [on? boolean?]) void?]{
Call this method to enable special treatment of the first line in the editor.
}
@defmethod[#:mode public-final (first-line-currently-drawn-specially?) boolean?]{
Returns @scheme[#t] if @method[text:first-line<%> is-special-first-line?]
returned @scheme[#t] for the current first line
and if the buffer is scrolled down so that the first
line would not (ordinarily) be visible.
}
@defmethod[#:mode public-final (get-first-line-height) number?]{
Returns the height, in pixels, of the first line.
}
@defmethod[(is-special-first-line? [line string?]) boolean?]{
Override this method to control when the first line is always
visible. The argument is the first line, as a string.
}
}
@defmixin[text:first-line-mixin (text%) (text:first-line<%>)]{
Provides the implementation of @scheme[text:first-line<%>].
Does so by just painting the text of the first
line over top of what is already there and overriding
@method[text:first-line-mixin scroll-editor-to] to patch
up scrolling and
@method[text:first-line-mixin on-event] to patch up
mouse handling.
@defmethod[#:mode override
(on-paint [before? any/c]
[dc (is-a?/c dc<%>)]
[left real?]
[top real?]
[right real?]
[bottom real?]
[dx real?]
[dy real?]
[draw-caret (one-of/c 'no-caret 'show-inactive-caret 'show-caret)])
void?]{
Based on the various return values of the methods in @scheme[text:first-line],
draws the first actual line of the editor over top of the first
visible line in the editor.
}
@defmethod[#:mode override
(on-event [event (is-a?/c mouse-event%)])
void?]{
Clicks in the first line cause the editor to scroll to the
actual first line.
}
@defmethod[#:mode override
(scroll-editor-to [localx real?]
[localy real?]
[width (and/c real? (not/c negative?))]
[height (and/c real? (not/c negative?))]
[refresh? any/c]
[bias (one-of/c 'start 'end 'none)])
void?]{
Scrolls a little bit more, when a scroll would be requested
that scrolls something so that it is line underneath the first line.
}
}
@definterface[text:foreground-color<%> (text:basic<%> editor:standard-style-list<%>)]{
}
@defmixin[text:foreground-color-mixin (text:basic<%> editor:standard-style-list<%>) (text:foreground-color<%>)]{
This mixin changes the default text style to have
the foreground color controlled by