From 4f5eb015fd974dd8b72cb64de63ac9c0bbe53ce2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 25 Aug 2008 14:47:41 +0000 Subject: [PATCH] a little more progress on the first line text svn: r11416 --- collects/drscheme/private/first-line-text.ss | 76 +++++++++++----- collects/drscheme/private/unit.ss | 96 +++++++++++--------- 2 files changed, 105 insertions(+), 67 deletions(-) diff --git a/collects/drscheme/private/first-line-text.ss b/collects/drscheme/private/first-line-text.ss index 98bfe5cebd..d7447f272d 100644 --- a/collects/drscheme/private/first-line-text.ss +++ b/collects/drscheme/private/first-line-text.ss @@ -1,40 +1,46 @@ #lang scheme/base - (require scheme/gui/base scheme/class framework) -(provide first-line-text-mixin) +(provide first-line-text-mixin + first-line-text-mixin<%>) -(define (first-line-text-mixin text%) - (class text% +(define first-line-text-mixin<%> + (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 scroll-to local-to-global get-dc) (define bx (box 0)) (define by (box 0)) (define bw (box 0)) - (define first-line #f) - (define end-of-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) - (when end-of-first-line - (when (<= start end-of-first-line) - (set! end-of-first-line #f) - (set! first-line #f)))) + (when (<= start end-of-first-line) + (update-first-line))) (define/augment (after-delete start len) - (when end-of-first-line - (when (<= start end-of-first-line) - (set! end-of-first-line #f) - (set! first-line #f)))) + (when (<= start end-of-first-line) + (update-first-line))) (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))]) h)) @@ -43,7 +49,7 @@ (cond [(not admin) #f] - [fancy-first-line? + [(show-first-line?) (let ([h (fetch-first-line-height)]) (set-box! by localy) (local-to-global #f by) @@ -60,7 +66,7 @@ (set! fancy-first-line? on?) (invalidate-bitmap-cache) (send (send this get-canvas) refresh))) - + (define/override (on-event event) (cond [(or (send event moving?) @@ -80,11 +86,11 @@ (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 fancy-first-line? + (when (show-first-line?) (let ([admin (get-admin)]) (when admin (send admin get-view bx by bw #f #f) @@ -143,6 +149,32 @@ (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 (define f (new frame% [label ""] [width 200] [height 200])) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index dd4f466899..21a541a575 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -27,6 +27,7 @@ module browser threading seems wrong. "drsig.ss" "auto-language.ss" "insert-large-letters.ss" + "first-line-text.ss" mrlib/switchable-button mrlib/cache-image-snip @@ -428,18 +429,19 @@ module browser threading seems wrong. (define (make-definitions-text%) (let ([definitions-super% ((get-program-editor-mixin) - (drscheme:module-language:module-language-put-file-mixin - (scheme:text-mixin - (color:text-mixin - (drscheme:rep:drs-bindings-keymap-mixin - (mode:host-text-mixin - (text:delegate-mixin - (text:foreground-color-mixin - (drscheme:rep:drs-autocomplete-mixin - (λ (x) x) - text:info%)))))))))]) + (values #;first-line-text-mixin + (drscheme:module-language:module-language-put-file-mixin + (scheme:text-mixin + (color:text-mixin + (drscheme:rep:drs-bindings-keymap-mixin + (mode:host-text-mixin + (text:delegate-mixin + (text:foreground-color-mixin + (drscheme:rep:drs-autocomplete-mixin + (λ (x) x) + text:info%))))))))))]) (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/public (set-interactions-text it) @@ -588,40 +590,44 @@ module browser threading seems wrong. (define/pubment (get-next-settings) next-settings) - (define/pubment set-next-settings - (lambda (_next-settings [update-prefs? #t]) - (when (or (send (drscheme:language-configuration:language-settings-language _next-settings) - get-reader-module) - (send (drscheme:language-configuration:language-settings-language next-settings) - get-reader-module)) - (set-modified #t)) - (set! next-settings _next-settings) - (change-mode-to-match) - - (let ([f (get-top-level-window)]) - (when (and f - (is-a? f -frame<%>)) - (send f language-changed))) - - (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? - (preferences:set - drscheme:language-configuration:settings-preferences-symbol - next-settings)) - - (remove-auto-text) - (insert-auto-text) - (after-set-next-settings _next-settings))) + (define/pubment (set-next-settings _next-settings [update-prefs? #t]) + (when (or (send (drscheme:language-configuration:language-settings-language _next-settings) + get-reader-module) + (send (drscheme:language-configuration:language-settings-language next-settings) + get-reader-module)) + (set-modified #t)) + (set! next-settings _next-settings) + (change-mode-to-match) + (let ([f (get-top-level-window)]) + (when (and f + (is-a? f -frame<%>)) + (send f language-changed))) + + #; + (highlight-first-line + (is-a? (drscheme:language-configuration:language-settings-language _next-settings) + 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? + (preferences:set + 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) (inner (void) after-set-next-settings s))