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

a little more progress on the first line text

Browse Source 
svn: r11416
This commit is contained in:
Robby Findler 2008-08-25 14:47:41 +00:00
parent 98e597f495
commit 4f5eb015fd
2 changed files with 105 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
collects/drscheme/private/first-line-text.ss
View File

@ -1,40 +1,46 @@
#lang scheme/base #lang scheme/base
(require scheme/gui/base (require scheme/gui/base
scheme/class scheme/class
framework) framework)
(provide first-line-text-mixin) (provide first-line-text-mixin
first-line-text-mixin<%>)
(define (first-line-text-mixin text%) (define first-line-text-mixin<%>
(class text% (interface ()
highlight-first-line))
(define first-line-text-mixin
(mixin ((class->interface text%)) (first-line-text-mixin<%>)
(inherit get-text paragraph-end-position get-admin invalidate-bitmap-cache position-location (inherit get-text paragraph-end-position get-admin invalidate-bitmap-cache position-location
scroll-to local-to-global get-dc) scroll-to local-to-global get-dc)
(define bx (box 0)) (define bx (box 0))
(define by (box 0)) (define by (box 0))
(define bw (box 0)) (define bw (box 0))
(define first-line #f)
(define end-of-first-line #f)
(define fancy-first-line? #f) (define fancy-first-line? #f)
(define first-line "")
(define end-of-first-line 0)
(define first-line-is-lang? #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-lang-line? first-line)))
(define/augment (after-insert start len) (define/augment (after-insert start len)
(when end-of-first-line (when (<= start end-of-first-line)
(when (<= start end-of-first-line) (update-first-line)))
(set! end-of-first-line #f)
(set! first-line #f))))
(define/augment (after-delete start len) (define/augment (after-delete start len)
(when end-of-first-line (when (<= start end-of-first-line)
(when (<= start end-of-first-line) (update-first-line)))
(set! end-of-first-line #f)
(set! first-line #f))))
(define/private (fetch-first-line-height) (define/private (fetch-first-line-height)
(unless first-line
(set! end-of-first-line (paragraph-end-position 0))
(set! first-line (get-text 0 end-of-first-line)))
(let-values ([(_1 h _2 _3) (send (get-dc) get-text-extent first-line (get-font))]) (let-values ([(_1 h _2 _3) (send (get-dc) get-text-extent first-line (get-font))])
h)) h))
@ -43,7 +49,7 @@
(cond (cond
[(not admin) [(not admin)
#f] #f]
[fancy-first-line? [(show-first-line?)
(let ([h (fetch-first-line-height)]) (let ([h (fetch-first-line-height)])
(set-box! by localy) (set-box! by localy)
(local-to-global #f by) (local-to-global #f by)
@ -84,7 +90,7 @@
(define/override (on-paint before? dc left top right bottom dx dy draw-caret) (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(unless before? (unless before?
(when fancy-first-line? (when (show-first-line?)
(let ([admin (get-admin)]) (let ([admin (get-admin)])
(when admin (when admin
(send admin get-view bx by bw #f #f) (send admin get-view bx by bw #f #f)
@ -143,6 +149,32 @@
(super-new))) (super-new)))
;; is-lang-line? : string -> boolean
;; given the first line in the editor, this returns #t if it is a #lang line.
(define (is-lang-line? l)
(let ([m (regexp-match #rx"^#(!|(lang ))([-+_/a-zA-Z0-9]+)(.|$)" l)])
(and m
(let ([lang-name (list-ref m 3)]
[last-char (list-ref m 4)])
(and (not (char=? #\/ (string-ref lang-name 0)))
(not (char=? #\/ (string-ref lang-name (- (string-length lang-name) 1))))
(or (string=? "" last-char)
(char-whitespace? (string-ref last-char 0))))))))
;; test cases for is-lang-line?
#;
(list (is-lang-line? "#lang x")
(is-lang-line? "#lang scheme")
(is-lang-line? "#lang scheme ")
(not (is-lang-line? "#lang schemeα"))
(not (is-lang-line? "#lang scheme/ "))
(not (is-lang-line? "#lang /scheme "))
(is-lang-line? "#lang sch/eme ")
(is-lang-line? "#lang r6rs")
(is-lang-line? "#!r6rs")
(is-lang-line? "#!r6rs ")
(not (is-lang-line? "#!/bin/sh")))
#; #;
(begin (begin
(define f (new frame% [label ""] [width 200] [height 200])) (define f (new frame% [label ""] [width 200] [height 200]))

88
collects/drscheme/private/unit.ss
View File

@ -27,6 +27,7 @@ module browser threading seems wrong.
"drsig.ss" "drsig.ss"
"auto-language.ss" "auto-language.ss"
"insert-large-letters.ss" "insert-large-letters.ss"
"first-line-text.ss"
mrlib/switchable-button mrlib/switchable-button
mrlib/cache-image-snip mrlib/cache-image-snip
@ -428,18 +429,19 @@ module browser threading seems wrong.
(define (make-definitions-text%) (define (make-definitions-text%)
(let ([definitions-super% (let ([definitions-super%
((get-program-editor-mixin) ((get-program-editor-mixin)
(drscheme:module-language:module-language-put-file-mixin (values #;first-line-text-mixin
(scheme:text-mixin (drscheme:module-language:module-language-put-file-mixin
(color:text-mixin (scheme:text-mixin
(drscheme:rep:drs-bindings-keymap-mixin (color:text-mixin
(mode:host-text-mixin (drscheme:rep:drs-bindings-keymap-mixin
(text:delegate-mixin (mode:host-text-mixin
(text:foreground-color-mixin (text:delegate-mixin
(drscheme:rep:drs-autocomplete-mixin (text:foreground-color-mixin
(λ (x) x) (drscheme:rep:drs-autocomplete-mixin
text:info%)))))))))]) (λ (x) x)
text:info%))))))))))])
(class* definitions-super% (definitions-text<%>) (class* definitions-super% (definitions-text<%>)
(inherit get-top-level-window is-locked? lock while-unlocked) (inherit get-top-level-window is-locked? lock while-unlocked #;highlight-first-line)
(define interactions-text #f) (define interactions-text #f)
(define/public (set-interactions-text it) (define/public (set-interactions-text it)
@ -588,40 +590,44 @@ module browser threading seems wrong.
(define/pubment (get-next-settings) next-settings) (define/pubment (get-next-settings) next-settings)
(define/pubment set-next-settings (define/pubment (set-next-settings _next-settings [update-prefs? #t])
(lambda (_next-settings [update-prefs? #t]) (when (or (send (drscheme:language-configuration:language-settings-language _next-settings)
(when (or (send (drscheme:language-configuration:language-settings-language _next-settings) get-reader-module)
get-reader-module) (send (drscheme:language-configuration:language-settings-language next-settings)
(send (drscheme:language-configuration:language-settings-language next-settings) get-reader-module))
get-reader-module)) (set-modified #t))
(set-modified #t)) (set! next-settings _next-settings)
(set! next-settings _next-settings) (change-mode-to-match)
(change-mode-to-match) (let ([f (get-top-level-window)])
(when (and f
(is-a? f -frame<%>))
(send f language-changed)))
(let ([f (get-top-level-window)]) #;
(when (and f (highlight-first-line
(is-a? f -frame<%>)) (is-a? (drscheme:language-configuration:language-settings-language _next-settings)
(send f language-changed))) drscheme:module-language:module-language<%>))
(let ([lang (drscheme:language-configuration:language-settings-language next-settings)]
[sets (drscheme:language-configuration:language-settings-settings next-settings)])
(preferences:set
'drscheme:recent-language-names
(limit-length
(remove-duplicate-languages
(cons (cons (send lang get-language-name)
(send lang marshall-settings sets))
(preferences:get 'drscheme:recent-language-names)))
10)))
(when update-prefs? (let ([lang (drscheme:language-configuration:language-settings-language next-settings)]
(preferences:set [sets (drscheme:language-configuration:language-settings-settings next-settings)])
drscheme:language-configuration:settings-preferences-symbol (preferences:set
next-settings)) 'drscheme:recent-language-names
(limit-length
(remove-duplicate-languages
(cons (cons (send lang get-language-name)
(send lang marshall-settings sets))
(preferences:get 'drscheme:recent-language-names)))
10)))
(remove-auto-text) (when update-prefs?
(insert-auto-text) (preferences:set
(after-set-next-settings _next-settings))) drscheme:language-configuration:settings-preferences-symbol
next-settings))
(remove-auto-text)
(insert-auto-text)
(after-set-next-settings _next-settings))
(define/pubment (after-set-next-settings s) (define/pubment (after-set-next-settings s)
(inner (void) after-set-next-settings s)) (inner (void) after-set-next-settings s))