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

restore parenthesis color scheme

Browse Source 
svn: r9826

original commit: 49175b140270dc286ee50a332241c2a8ebc2cd7c
This commit is contained in:
Matthew Flatt 2008-05-13 19:43:42 +00:00
parent ca5edb8849
commit 99f969620f
1 changed files with 64 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
collects/framework/private/color.ss
View File

@ -263,8 +263,8 @@ added get-regions
(get-token in)]) (get-token in)])
(unless (eq? 'eof type) (unless (eq? 'eof type)
(enable-suspend #f) (enable-suspend #f)
#;(printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start)) #; (printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start))
(+ in-start-pos (sub1 new-token-end))) (+ in-start-pos (sub1 new-token-end)))
(let ((len (- new-token-end new-token-start))) (let ((len (- new-token-end new-token-start)))
(set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls)))
(sync-invalid ls) (sync-invalid ls)
@ -304,9 +304,8 @@ added get-regions
(sync-invalid ls)) (sync-invalid ls))
(cond (cond
((lexer-state-up-to-date? ls) ((lexer-state-up-to-date? ls)
(let-values (let-values (((orig-token-start orig-token-end valid-tree invalid-tree)
(((orig-token-start orig-token-end valid-tree invalid-tree) (send (lexer-state-tokens ls) split (- edit-start-pos (lexer-state-start-pos ls)))))
(send (lexer-state-tokens ls) split (- edit-start-pos (lexer-state-start-pos ls)))))
(send (lexer-state-parens ls) split-tree orig-token-start) (send (lexer-state-parens ls) split-tree orig-token-start)
(set-lexer-state-invalid-tokens! ls invalid-tree) (set-lexer-state-invalid-tokens! ls invalid-tree)
(set-lexer-state-tokens! ls valid-tree) (set-lexer-state-tokens! ls valid-tree)
@ -526,10 +525,18 @@ added get-regions
(define mismatch-color (make-object color% "PINK")) (define mismatch-color (make-object color% "PINK"))
(define/private (get-match-color) (preferences:get 'framework:paren-match-color)) (define/private (get-match-color) (preferences:get 'framework:paren-match-color))
(define/private (highlight ls start end caret-pos error?)
;; higlight : number number number (or/c color any)
;; if color is a color, then it uses that color to higlight
;; Otherwise, it treats it like a boolean, where a true value
;; means the normal paren color and #f means an error color.
;; numbers are expected to have zero be start-pos.
(define/private (highlight ls start end caret-pos color)
(let* ([start-pos (lexer-state-start-pos ls)] (let* ([start-pos (lexer-state-start-pos ls)]
[off (highlight-range (+ start-pos start) (+ start-pos end) [off (highlight-range (+ start-pos start) (+ start-pos end)
(if error? mismatch-color (get-match-color)) (if (is-a? color color%)
color
(if color mismatch-color (get-match-color)))
(and (send (icon:get-paren-highlight-bitmap) (and (send (icon:get-paren-highlight-bitmap)
ok?) ok?)
(icon:get-paren-highlight-bitmap)) (icon:get-paren-highlight-bitmap))
@ -550,7 +557,6 @@ added get-regions
(lexer-state-current-pos ls)) (lexer-state-current-pos ls))
(not (lexer-state-up-to-date? ls)))) (not (lexer-state-up-to-date? ls))))
;; If there is no match because the buffer isn't lexed far enough yet, ;; If there is no match because the buffer isn't lexed far enough yet,
;; this will do nothing, but the edit sequence for changing the colors ;; this will do nothing, but the edit sequence for changing the colors
;; will trigger a callback that will call this to try and match again. ;; will trigger a callback that will call this to try and match again.
@ -585,15 +591,46 @@ added get-regions
(- here (lexer-state-start-pos ls))))) (- here (lexer-state-start-pos ls)))))
(when (and (not (f-match-false-error ls start-f end-f error-f)) (when (and (not (f-match-false-error ls start-f end-f error-f))
start-f end-f) start-f end-f)
(highlight ls start-f end-f here error-f))) (if error-f
(highlight ls start-f end-f here error-f)
(highlight-nested-region ls start-f end-f here))))
(let-values (((start-b end-b error-b) (let-values (((start-b end-b error-b)
(send (lexer-state-parens ls) match-backward (send (lexer-state-parens ls) match-backward
(- here (lexer-state-start-pos ls))))) (- here (lexer-state-start-pos ls)))))
(when (and start-b end-b) (when (and start-b end-b)
(highlight ls start-b end-b here error-b)))))))) (if error-b
(highlight ls start-b end-b here error-b)
(highlight-nested-region ls start-b end-b here)))))))))
(end-edit-sequence) (end-edit-sequence)
(set! in-match-parens? #f)))) (set! in-match-parens? #f))))
;; highlight-nested-region : lexer-state number number number -> void
;; colors nested regions of parentheses.
(define/private (highlight-nested-region ls orig-start orig-end here)
(let paren-loop ([start orig-start]
[end orig-end]
[depth 0])
(when (< depth (vector-length (get-parenthesis-colors)))
;; when there is at least one more color in the vector we'll look
;; for regions to color at that next level
(when (< (+ depth 1) (vector-length (get-parenthesis-colors)))
(let seq-loop ([inner-sequence-start (+ start 1)])
(when (< inner-sequence-start end)
(let ([post-whitespace (skip-whitespace inner-sequence-start 'forward #t)])
(let-values ([(start-inner end-inner error-inner)
(send (lexer-state-parens ls) match-forward post-whitespace)])
(cond
[(and start-inner end-inner (not error-inner))
(paren-loop start-inner end-inner (+ depth 1))
(seq-loop end-inner)]
[(skip-past-token ls post-whitespace)
=>
(λ (after-non-paren-thing)
(seq-loop after-non-paren-thing))]))))))
(highlight ls start end here (vector-ref (get-parenthesis-colors) depth)))))
;; See docs ;; See docs
(define/public (forward-match position cutoff) (define/public (forward-match position cutoff)
(do-forward-match position cutoff #t)) (do-forward-match position cutoff #t))
@ -620,20 +657,22 @@ added get-regions
(else #f)))) (else #f))))
((and start end error) #f) ((and start end error) #f)
(else (else
(let-values (((tok-start tok-end) (skip-past-token ls position))))))))
(begin
(tokenize-to-pos ls position)
(send (lexer-state-tokens ls) search!
(- position (lexer-state-start-pos ls)))
(values (send (lexer-state-tokens ls) get-root-start-position)
(send (lexer-state-tokens ls) get-root-end-position)))))
(cond
((or (send (lexer-state-parens ls) is-close-pos? tok-start)
(= (+ (lexer-state-start-pos ls) tok-end) position))
#f)
(else
(+ (lexer-state-start-pos ls) tok-end)))))))))))
(define/private (skip-past-token ls position)
(let-values (((tok-start tok-end)
(begin
(tokenize-to-pos ls position)
(send (lexer-state-tokens ls) search!
(- position (lexer-state-start-pos ls)))
(values (send (lexer-state-tokens ls) get-root-start-position)
(send (lexer-state-tokens ls) get-root-end-position)))))
(cond
((or (send (lexer-state-parens ls) is-close-pos? tok-start)
(= (+ (lexer-state-start-pos ls) tok-end) position))
#f)
(else
(+ (lexer-state-start-pos ls) tok-end)))))
;; See docs ;; See docs
(define/public (backward-match position cutoff) (define/public (backward-match position cutoff)