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

the paren matcher now works for previous interactinos with the REPL and hitting return up above copies the text down to the next prompt

Browse Source 
svn: r8840
This commit is contained in:
Robby Findler 2008-03-01 21:49:31 +00:00
parent bb6c2fba5a
commit 362f16b411
4 changed files with 976 additions and 846 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
collects/drscheme/private/rep.ss
View File

@ -581,6 +581,7 @@ TODO
get-in-box-port get-in-box-port
get-insertion-point get-insertion-point
get-out-port get-out-port
get-regions
get-snip-position get-snip-position
get-start-position get-start-position
get-styles-fixed get-styles-fixed
@ -604,7 +605,7 @@ TODO
position-paragraph position-paragraph
release-snip release-snip
reset-input-box reset-input-box
reset-region reset-regions
run-after-edit-sequence run-after-edit-sequence
scroll-to-position scroll-to-position
send-eof-to-in-port send-eof-to-in-port
@ -847,7 +848,7 @@ TODO
(cond (cond
[(in-edit-sequence?) [(in-edit-sequence?)
(set! had-an-insert (cons (cons start len) had-an-insert))] (set! had-an-insert (cons (cons start len) had-an-insert))]
[else (update-after-insert)])) [else (update-after-insert start len)]))
;; private field ;; private field
(define had-an-insert '()) (define had-an-insert '())
@ -877,8 +878,10 @@ TODO
(when (space . > . max-space) (when (space . > . max-space)
(let ([to-delete-end (+ start (- space max-space))]) (let ([to-delete-end (+ start (- space max-space))])
(delete/io start to-delete-end)))))) (delete/io start to-delete-end))))))
(set! prompt-position (get-unread-start-point)) (set! prompt-position (get-unread-start-point))
(reset-region prompt-position 'end))) (reset-regions (append (all-but-last (get-regions))
(list (list prompt-position 'end))))))
(define/augment (after-delete x y) (define/augment (after-delete x y)
(unless inserting-prompt? (unless inserting-prompt?
@ -1009,12 +1012,15 @@ TODO
(define/augment (on-submit) (define/augment (on-submit)
(inner (void) on-submit) (inner (void) on-submit)
(when (and (get-user-thread) (when (and (get-user-thread)
(thread-running? (get-user-thread))) (thread-running? (get-user-thread)))
;; the -2 drops the last newline from history (why -2 and not -1?!) ;; the -2 drops the last newline from history (why -2 and not -1?!)
(save-interaction-in-history prompt-position (- (last-position) 2)) (save-interaction-in-history prompt-position (- (last-position) 2))
(freeze-colorer)
(let* ([old-regions (get-regions)]
[abl (all-but-last old-regions)]
[lst (car (last-pair old-regions))])
(reset-regions (append abl (list (list (list-ref lst 0) (last-position))))))
(let ([needs-execution (send context needs-execution)]) (let ([needs-execution (send context needs-execution)])
(when (if (preferences:get 'drscheme:execute-warning-once) (when (if (preferences:get 'drscheme:execute-warning-once)
@ -1036,6 +1042,42 @@ TODO
;; clear out the eof object if it wasn't consumed ;; clear out the eof object if it wasn't consumed
(clear-input-port))))) (clear-input-port)))))
(inherit get-backward-sexp)
(define/override (on-local-char key)
(let ([start (get-start-position)]
[end (get-end-position)]
[code (send key get-key-code)])
(cond
[(not (or (eq? code 'numpad-enter)
(equal? code #\return)
(equal? code #\newline)))
(super on-local-char key)]
[(and (< end prompt-position)
(= start end)
(get-backward-sexp end))
=>
(λ (sexp-start)
(copy-down sexp-start end))]
[(and (< end prompt-position)
(not (= start end)))
(copy-down start end)]
[else
(super on-local-char key)])))
(define/private (copy-down start end)
(begin-edit-sequence)
(split-snip start)
(split-snip end)
(let loop ([snip (find-snip start 'after-or-none)])
(when snip
(let ([pos (+ (get-snip-position snip)
(send snip get-count))])
(when (<= pos end)
(insert (send snip copy) (last-position) (last-position))
(loop (send snip next))))))
(set-position (last-position) (last-position))
(end-edit-sequence))
;; prompt-position : (union #f integer) ;; prompt-position : (union #f integer)
;; the position just after the last prompt ;; the position just after the last prompt
(field (prompt-position #f)) (field (prompt-position #f))
@ -1059,8 +1101,7 @@ TODO
(let ([sp (get-unread-start-point)]) (let ([sp (get-unread-start-point)])
(set! prompt-position sp) (set! prompt-position sp)
(reset-region sp 'end) (reset-regions (append (get-regions) (list (list sp 'end))))))
(when (is-frozen?) (thaw-colorer))))
(end-edit-sequence) (end-edit-sequence)
(set! inserting-prompt? #f)) (set! inserting-prompt? #f))
@ -1458,7 +1499,7 @@ TODO
;; clear out repl first before doing any work. ;; clear out repl first before doing any work.
(begin-edit-sequence) (begin-edit-sequence)
(freeze-colorer) (set! prompt-position #f)
(reset-input-box) (reset-input-box)
(delete (paragraph-start-position 1) (last-position)) (delete (paragraph-start-position 1) (last-position))
(end-edit-sequence) (end-edit-sequence)
@ -1504,7 +1545,7 @@ TODO
(set! setting-up-repl? #f) (set! setting-up-repl? #f)
(set! already-warned? #f) (set! already-warned? #f)
(reset-region (last-position) (last-position)) (reset-regions (list (list (last-position) (last-position))))
(set-unread-start-point (last-position)) (set-unread-start-point (last-position))
(set-insertion-point (last-position)) (set-insertion-point (last-position))
(set-allow-edits #f) (set-allow-edits #f)
@ -1654,6 +1695,13 @@ TODO
(inherit set-max-undo-history) (inherit set-max-undo-history)
(set-max-undo-history 'forever))) (set-max-undo-history 'forever)))
(define (all-but-last lst)
(let loop ([o lst])
(cond
[(null? o) null]
[(null? (cdr o)) null]
[else (cons (car o) (loop (cdr o)))])))
(define input-delta (make-object style-delta%)) (define input-delta (make-object style-delta%))
(send input-delta set-delta-foreground (make-object color% 0 150 0)) (send input-delta set-delta-foreground (make-object color% 0 150 0))

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

@ -1,4 +1,11 @@
#lang scheme/unit #lang scheme/unit
#|
update-region-end is now gone
reset-region needs to go
added reset-regions
added get-regions
|#
(require mzlib/class (require mzlib/class
mzlib/thread mzlib/thread
mred mred
@ -37,9 +44,8 @@
freeze-colorer freeze-colorer
thaw-colorer thaw-colorer
reset-region reset-regions
get-region get-regions
update-region-end
skip-whitespace skip-whitespace
backward-match backward-match
@ -77,7 +83,7 @@
;; ---------------------- Lexing state ------------------------------ ;; ---------------------- Lexing state ------------------------------
;; The tree of valid tokens, starting at start-pos ;; The tree of valid tokens, starting at 0
(define tokens (new token-tree%)) (define tokens (new token-tree%))
;; If the tree is completed ;; If the tree is completed
@ -92,7 +98,7 @@
(define invalid-tokens-start +inf.0) (define invalid-tokens-start +inf.0)
;; The position right before the next token to be read ;; The position right before the next token to be read
(define current-pos start-pos) (define current-pos 0)
;; The lexer ;; The lexer
(define get-token #f) (define get-token #f)
@ -105,15 +111,56 @@
;; ---------------------- Interactions state ------------------------ ;; ---------------------- Interactions state ------------------------
;; The positions right before and right after the area to be tokenized ;; regions : (listof (list number (union 'end number)))
(define start-pos 0) ;; The range of editor positions that should be colored in the buffer
(define end-pos 'end) (define regions '((0 end)))
(inherit last-position) (inherit last-position)
(define/public (reset-regions _regions)
(let loop ([regions _regions]
[pos 0])
(cond
[(null? regions) (void)]
[(pair? regions)
(let ([region (car regions)])
(unless (and (list? region)
(= 2 (length region))
(number? (list-ref region 0))
(or (number? (list-ref region 1))
(and (null? (cdr regions))
(eq? 'end (list-ref region 1)))))
(error 'reset-regions "got a region that is not a list of two numbers (or 'end if it is the last region): ~e, all regions ~e" region regions))
(unless (and (<= pos (list-ref region 0))
(or (eq? 'end (list-ref region 1))
(<= (list-ref region 0) (list-ref region 1))))
(error 'reset-regions "found regions with numbers out of order ~e" regions))
(loop (cdr regions) (list-ref region 1)))]
[else
(error 'reset-regions "expected a list of regions, got ~e" regions)]))
(let ([old-regions regions])
(set! regions _regions)
;(reset-tokens)
(let loop ([old old-regions]
[new regions])
(cond
[(and (null? old) (null? new)) (void)]
[(null? old)
(do-insert/delete (list-ref (car new) 0) 0)]
[(null? new)
(do-insert/delete (list-ref (car old) 0) 0)]
[(equal? (car old) (car new))
(loop (cdr old) (cdr new))]
[else
(do-insert/delete (min (list-ref (car old) 0)
(list-ref (car new) 0))
0)]))))
(define/public (get-regions) regions)
;; See docs ;; See docs
(define/public (reset-region start end) (define/public (reset-region start end)
(unless (and (= start start-pos) (eqv? end end-pos))
(unless (<= 0 start (last-position)) (unless (<= 0 start (last-position))
(raise-mismatch-error 'reset-region (raise-mismatch-error 'reset-region
"start position not inside editor: " "start position not inside editor: "
@ -126,16 +173,10 @@
(raise-mismatch-error 'reset-region (raise-mismatch-error 'reset-region
"end position before start position: " "end position before start position: "
(list end start))) (list end start)))
(set! start-pos start)
(set! end-pos end)
(reset-tokens) (reset-tokens)
(do-insert/delete start 0))) (do-insert/delete start 0))
(define/public (get-region) (values start-pos end-pos)) (define/public (get-region) (values 0 'end))
;; Modify the end of the region.
(define/public (update-region-end end)
(set! end-pos end))
;; ---------------------- Preferences ------------------------------- ;; ---------------------- Preferences -------------------------------
(define should-color? #t) (define should-color? #t)
@ -163,7 +204,7 @@
(set! restart-callback #f) (set! restart-callback #f)
(set! force-recolor-after-freeze #f) (set! force-recolor-after-freeze #f)
(set! parens (new paren-tree% (matches pairs))) (set! parens (new paren-tree% (matches pairs)))
(set! current-pos start-pos) (set! current-pos 0)
(set! colors null) (set! colors null)
(when tok-cor (when tok-cor
(coroutine-kill tok-cor)) (coroutine-kill tok-cor))
@ -187,26 +228,45 @@
(set! invalid-tokens-start (+ invalid-tokens-start length))) (set! invalid-tokens-start (+ invalid-tokens-start length)))
(sync-invalid))) (sync-invalid)))
(define/private (re-tokenize in in-start-pos enable-suspend) (define/private (re-tokenize in-start-pos enable-suspend)
(let port-loop ([regions (skip-early-regions in-start-pos)]
[previous-end in-start-pos])
(when previous-end
(let* ([next-start (if (null? regions)
(last-position)
(list-ref (car regions) 0))]
[len (- next-start previous-end)])
(unless (zero? len)
(insert-last-spec! tokens len #f)
(send parens add-token #f len))))
(unless (null? regions)
(let* ([start-pos (list-ref (car regions) 0)]
[end-pos (list-ref (car regions) 1)]
[in (open-input-text-editor this start-pos end-pos (λ (x) #f))])
(let loop ()
(let-values ([(lexeme type data new-token-start new-token-end) (let-values ([(lexeme type data new-token-start new-token-end)
(get-token in)]) (get-token in)])
(unless (eq? 'eof type) (cond
[(eq? 'eof type)
(port-loop (cdr regions)
(if (eq? 'end end-pos)
#f
end-pos))]
[else
(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"
(+ in-start-pos (sub1 new-token-end))) lexeme
(+ start-pos (sub1 new-token-start))
(+ start-pos (sub1 new-token-end)))
(let ((len (- new-token-end new-token-start))) (let ((len (- new-token-end new-token-start)))
(set! current-pos (+ len current-pos)) (set! current-pos (+ len current-pos))
(sync-invalid) (sync-invalid)
(when (and should-color? (should-color-type? type) (not frozen?)) (when (should-color-type? type)
(set! colors
(cons
(let* ([style-name (token-sym->style type)] (let* ([style-name (token-sym->style type)]
(color (send (get-style-list) find-named-style style-name)) [color (send (get-style-list) find-named-style style-name)]
(sp (+ in-start-pos (sub1 new-token-start))) [sp (+ start-pos (sub1 new-token-start))]
(ep (+ in-start-pos (sub1 new-token-end)))) [ep (+ start-pos (sub1 new-token-end))])
(λ () (add-color color sp ep)))
(change-style color sp ep #f)))
colors)))
; Using the non-spec version takes 3 times as long as the spec ; Using the non-spec version takes 3 times as long as the spec
; version. In other words, the new greatly outweighs the tree ; version. In other words, the new greatly outweighs the tree
; operations. ; operations.
@ -214,17 +274,42 @@
(insert-last-spec! tokens len type) (insert-last-spec! tokens len type)
(send parens add-token data len) (send parens add-token data len)
(cond (cond
((and (not (send invalid-tokens is-empty?)) [(and (not (send invalid-tokens is-empty?))
(= invalid-tokens-start current-pos)) (= invalid-tokens-start current-pos))
(send invalid-tokens search-max!) (send invalid-tokens search-max!)
(send parens merge-tree (send parens merge-tree (send invalid-tokens get-root-end-position))
(send invalid-tokens get-root-end-position))
(insert-last! tokens invalid-tokens) (insert-last! tokens invalid-tokens)
(set! invalid-tokens-start +inf.0) (set! invalid-tokens-start +inf.0)
(enable-suspend #t))
(else
(enable-suspend #t) (enable-suspend #t)
(re-tokenize in in-start-pos enable-suspend))))))) (port-loop (cdr regions)
(if (eq? 'end end-pos)
#f
end-pos))]
[else
(enable-suspend #t)
(loop)]))])))))))
(define/private (add-color color sp ep)
(when (and should-color? (not frozen?))
(set! colors
(cons (λ () (change-style color sp ep #f))
colors))))
(define/private (skip-early-regions pos)
(let loop ([regions regions])
(cond
[(null? regions) null]
[else (let ([reg (car regions)])
(cond
[(<= pos
(if (eq? 'end (list-ref reg 1))
(last-position)
(list-ref reg 1)))
(cons (list (max pos (list-ref reg 0))
(list-ref reg 1))
(cdr regions))]
[else
(loop (cdr regions))]))])))
(define/private (do-insert/delete edit-start-pos change-length) (define/private (do-insert/delete edit-start-pos change-length)
(unless (or stopped? force-stop?) (unless (or stopped? force-stop?)
@ -232,22 +317,21 @@
(sync-invalid)) (sync-invalid))
(cond (cond
(up-to-date? (up-to-date?
(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 tokens split edit-start-pos)])
(send tokens split (- edit-start-pos start-pos))))
(send parens split-tree orig-token-start) (send parens split-tree orig-token-start)
(set! invalid-tokens invalid-tree) (set! invalid-tokens invalid-tree)
(set! tokens valid-tree) (set! tokens valid-tree)
(set! invalid-tokens-start (set! invalid-tokens-start
(if (send invalid-tokens is-empty?) (if (send invalid-tokens is-empty?)
+inf.0 +inf.0
(+ start-pos orig-token-end change-length))) (+ orig-token-end change-length)))
(set! current-pos (+ start-pos orig-token-start)) (set! current-pos orig-token-start)
(set! up-to-date? #f) (set! up-to-date? #f)
(queue-callback (λ () (colorer-callback)) #f))) (queue-callback (λ () (colorer-callback)) #f)))
((>= edit-start-pos invalid-tokens-start) ((>= edit-start-pos invalid-tokens-start)
(let-values (((tok-start tok-end valid-tree invalid-tree) (let-values (((tok-start tok-end valid-tree invalid-tree)
(send invalid-tokens split (- edit-start-pos start-pos)))) (send invalid-tokens split edit-start-pos)))
(set! invalid-tokens invalid-tree) (set! invalid-tokens invalid-tree)
(set! invalid-tokens-start (set! invalid-tokens-start
(+ invalid-tokens-start tok-end change-length)))) (+ invalid-tokens-start tok-end change-length))))
@ -255,11 +339,11 @@
(set! invalid-tokens-start (+ change-length invalid-tokens-start))) (set! invalid-tokens-start (+ change-length invalid-tokens-start)))
(else (else
(let-values (((tok-start tok-end valid-tree invalid-tree) (let-values (((tok-start tok-end valid-tree invalid-tree)
(send tokens split (- edit-start-pos start-pos)))) (send tokens split edit-start-pos)))
(send parens truncate tok-start) (send parens truncate tok-start)
(set! tokens valid-tree) (set! tokens valid-tree)
(set! invalid-tokens-start (+ change-length invalid-tokens-start)) (set! invalid-tokens-start (+ change-length invalid-tokens-start))
(set! current-pos (+ start-pos tok-start))))))) (set! current-pos tok-start))))))
(inherit is-locked? get-revision-number) (inherit is-locked? get-revision-number)
@ -274,10 +358,7 @@
(coroutine (coroutine
(λ (enable-suspend) (λ (enable-suspend)
(parameterize ((port-count-lines-enabled #t)) (parameterize ((port-count-lines-enabled #t))
(re-tokenize (open-input-text-editor this current-pos end-pos (re-tokenize current-pos enable-suspend)))))
(λ (x) #f))
current-pos
enable-suspend)))))
(set! rev (get-revision-number))) (set! rev (get-revision-number)))
(with-handlers ((exn:fail? (with-handlers ((exn:fail?
(λ (exn) (λ (exn)
@ -327,22 +408,28 @@
(set! pairs pairs-) (set! pairs pairs-)
(set! parens (new paren-tree% (matches pairs))) (set! parens (new paren-tree% (matches pairs)))
;; (set! timer (current-milliseconds)) ;; (set! timer (current-milliseconds))
(do-insert/delete start-pos 0))) (do-insert/delete 0 0)))
;; See docs ;; See docs
(define/public stop-colorer (define/public stop-colorer
(opt-lambda ((clear-colors #t)) (opt-lambda ((clear-the-colors #t))
(set! stopped? #t) (set! stopped? #t)
(when (and clear-colors (not frozen?)) (when (and clear-the-colors (not frozen?))
(begin-edit-sequence #f #f) (clear-colors))
(change-style (get-fixed-style) start-pos end-pos #f)
(end-edit-sequence))
(match-parens #t) (match-parens #t)
(reset-tokens) (reset-tokens)
(set! pairs null) (set! pairs null)
(set! token-sym->style #f) (set! token-sym->style #f)
(set! get-token #f))) (set! get-token #f)))
(define/private (clear-colors)
(begin-edit-sequence #f #f)
(for-each
(λ (start/end)
(change-style (get-fixed-style) (list-ref start/end 0) (list-ref start/end 1) #f))
regions)
(end-edit-sequence))
(define/public (is-frozen?) frozen?) (define/public (is-frozen?) frozen?)
(define/public (is-stopped?) stopped?) (define/public (is-stopped?) stopped?)
@ -379,8 +466,8 @@
(when (and should-color? (should-color-type? type)) (when (and should-color? (should-color-type? type))
(let ((color (send (get-style-list) find-named-style (let ((color (send (get-style-list) find-named-style
(token-sym->style type))) (token-sym->style type)))
(sp (+ start-pos start)) (sp start)
(ep (+ start-pos (+ start len)))) (ep (+ start len)))
(change-style color sp ep #f))))) (change-style color sp ep #f)))))
(end-edit-sequence)))))))) (end-edit-sequence))))))))
@ -393,12 +480,10 @@
((and (not should-color?) on?) ((and (not should-color?) on?)
(set! should-color? on?) (set! should-color? on?)
(reset-tokens) (reset-tokens)
(do-insert/delete start-pos 0)) (do-insert/delete 0 0))
((and should-color? (not on?)) ((and should-color? (not on?))
(set! should-color? on?) (set! should-color? on?)
(begin-edit-sequence #f #f) (clear-colors))))
(change-style (get-fixed-style) start-pos end-pos #f)
(end-edit-sequence))))
;; see docs ;; see docs
(define/public (force-stop-colorer stop?) (define/public (force-stop-colorer stop?)
@ -420,14 +505,14 @@
;; means the normal paren color and #f means an error color. ;; means the normal paren color and #f means an error color.
;; numbers are expected to have zero be start-pos. ;; numbers are expected to have zero be start-pos.
(define/private (highlight start end caret-pos color) (define/private (highlight start end caret-pos color)
(let ([off (highlight-range (+ start-pos start) (+ start-pos end) (let ([off (highlight-range start end
(if (is-a? color color%) (if (is-a? color color%)
color color
(if color mismatch-color (get-match-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))
(= caret-pos (+ start-pos start)))]) (= caret-pos start))])
(set! clear-old-locations (set! clear-old-locations
(let ([old clear-old-locations]) (let ([old clear-old-locations])
(λ () (λ ()
@ -439,7 +524,7 @@
;; the forward matcher signaled an error because not enough of the ;; the forward matcher signaled an error because not enough of the
;; tree has been built. ;; tree has been built.
(define/private (f-match-false-error start end error) (define/private (f-match-false-error start end error)
(and error (<= (+ start-pos error) current-pos) (not up-to-date?))) (and error (<= error current-pos) (not up-to-date?)))
;; 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,
@ -468,14 +553,14 @@
(let* ((here (get-start-position))) (let* ((here (get-start-position)))
(when (= here (get-end-position)) (when (= here (get-end-position))
(let-values (((start-f end-f error-f) (let-values (((start-f end-f error-f)
(send parens match-forward (- here start-pos)))) (send parens match-forward here)))
(when (and (not (f-match-false-error start-f end-f error-f)) (when (and (not (f-match-false-error start-f end-f error-f))
start-f end-f) start-f end-f)
(if error-f (if error-f
(highlight start-f end-f here error-f) (highlight start-f end-f here error-f)
(highlight-nested-region start-f end-f here)))) (highlight-nested-region start-f end-f here))))
(let-values (((start-b end-b error-b) (let-values (((start-b end-b error-b)
(send parens match-backward (- here start-pos)))) (send parens match-backward here)))
(when (and start-b end-b) (when (and start-b end-b)
(if error-b (if error-b
(highlight start-b end-b here error-b) (highlight start-b end-b here error-b)
@ -496,7 +581,7 @@
(when (< (+ depth 1) (vector-length (get-parenthesis-colors))) (when (< (+ depth 1) (vector-length (get-parenthesis-colors)))
(let seq-loop ([inner-sequence-start (+ start 1)]) (let seq-loop ([inner-sequence-start (+ start 1)])
(when (< inner-sequence-start end) (when (< inner-sequence-start end)
(let ([post-whitespace (- (skip-whitespace (+ inner-sequence-start start-pos) 'forward #t) start-pos)]) (let ([post-whitespace (skip-whitespace inner-sequence-start 'forward #t)])
(let-values ([(start-inner end-inner error-inner) (let-values ([(start-inner end-inner error-inner)
(send parens match-forward post-whitespace)]) (send parens match-forward post-whitespace)])
(cond (cond
@ -520,16 +605,15 @@
(skip-whitespace position 'forward #t) (skip-whitespace position 'forward #t)
position))) position)))
(let-values (((start end error) (let-values (((start end error)
(send parens match-forward (- position start-pos)))) (send parens match-forward position)))
(cond (cond
((f-match-false-error start end error) ((f-match-false-error start end error)
(colorer-driver) (colorer-driver)
(do-forward-match position cutoff #f)) (do-forward-match position cutoff #f))
((and start end (not error)) ((and start end (not error))
(let ((match-pos (+ start-pos end)))
(cond (cond
((<= match-pos cutoff) match-pos) ((<= end cutoff) end)
(else #f)))) (else #f)))
((and start end error) #f) ((and start end error) #f)
(else (else
(skip-past-token position) (skip-past-token position)
@ -551,15 +635,15 @@
(let-values (((tok-start tok-end) (let-values (((tok-start tok-end)
(begin (begin
(tokenize-to-pos position) (tokenize-to-pos position)
(send tokens search! (- position start-pos)) (send tokens search! position)
(values (send tokens get-root-start-position) (values (send tokens get-root-start-position)
(send tokens get-root-end-position))))) (send tokens get-root-end-position)))))
(cond (cond
((or (send parens is-close-pos? tok-start) ((or (send parens is-close-pos? tok-start)
(= (+ start-pos tok-end) position)) (= tok-end position))
#f) #f)
(else (else
(+ start-pos tok-end))))) tok-end))))
;; See docs ;; See docs
@ -574,10 +658,10 @@
(error 'backward-match "called on a color:text<%> whose colorer is stopped.")) (error 'backward-match "called on a color:text<%> whose colorer is stopped."))
(let ((position (skip-whitespace position 'backward #t))) (let ((position (skip-whitespace position 'backward #t)))
(let-values (((start end error) (let-values (((start end error)
(send parens match-backward (- position start-pos)))) (send parens match-backward position)))
(cond (cond
((and start end (not error)) ((and start end (not error))
(let ((match-pos (+ start-pos start))) (let ((match-pos start))
(cond (cond
((>= match-pos cutoff) match-pos) ((>= match-pos cutoff) match-pos)
(else #f)))) (else #f))))
@ -586,17 +670,17 @@
(let-values (((tok-start tok-end) (let-values (((tok-start tok-end)
(begin (begin
(send tokens search! (send tokens search!
(if (> position start-pos) (if (> position 0)
(- position start-pos 1) (- position 1)
0)) 0))
(values (send tokens get-root-start-position) (values (send tokens get-root-start-position)
(send tokens get-root-end-position))))) (send tokens get-root-end-position)))))
(cond (cond
((or (send parens is-open-pos? tok-start) ((or (send parens is-open-pos? tok-start)
(= (+ start-pos tok-start) position)) (= tok-start position))
'open) 'open)
(else (else
(+ start-pos tok-start))))))))) tok-start))))))))
;; See docs ;; See docs
(define/public (backward-containing-sexp position cutoff) (define/public (backward-containing-sexp position cutoff)
@ -614,7 +698,7 @@
(when stopped? (when stopped?
(error 'classify-position "called on a color:text<%> whose colorer is stopped.")) (error 'classify-position "called on a color:text<%> whose colorer is stopped."))
(tokenize-to-pos position) (tokenize-to-pos position)
(send tokens search! (- position start-pos)) (send tokens search! position)
(send tokens get-root-data)) (send tokens get-root-data))
(define/private (tokenize-to-pos position) (define/private (tokenize-to-pos position)
@ -627,25 +711,28 @@
(when stopped? (when stopped?
(error 'skip-whitespace "called on a color:text<%> whose colorer is stopped.")) (error 'skip-whitespace "called on a color:text<%> whose colorer is stopped."))
(cond (cond
((and (eq? direction 'forward) [(not (in-colored-region? position))
(>= position (if (eq? 'end end-pos) (last-position) end-pos))) position]
position) [else
((and (eq? direction 'backward) (<= position start-pos))
position)
(else
(tokenize-to-pos position) (tokenize-to-pos position)
(send tokens search! (- (if (eq? direction 'backward) (sub1 position) position) (send tokens search! (if (eq? direction 'backward) (sub1 position) position))
start-pos))
(cond (cond
((or (eq? 'white-space (send tokens get-root-data)) [(or (eq? 'white-space (send tokens get-root-data))
(and comments? (eq? 'comment (send tokens get-root-data)))) (and comments? (eq? 'comment (send tokens get-root-data))))
(skip-whitespace (+ start-pos (skip-whitespace (if (eq? direction 'forward)
(if (eq? direction 'forward)
(send tokens get-root-end-position) (send tokens get-root-end-position)
(send tokens get-root-start-position))) (send tokens get-root-start-position))
direction direction
comments?)) comments?)]
(else position))))) [else position])]))
(define/private (in-colored-region? position)
(ormap (λ (start/end) (<= (list-ref start/end 0)
position
(if (eq? 'end (list-ref start/end 1))
(last-position)
(list-ref start/end 1))))
regions))
(define/private (get-close-paren pos closers) (define/private (get-close-paren pos closers)
(cond (cond
@ -654,11 +741,11 @@
(let* ((c (car closers)) (let* ((c (car closers))
(l (string-length c))) (l (string-length c)))
(insert c pos) (insert c pos)
(let ((m (backward-match (+ l pos) start-pos))) (let ((m (backward-match (+ l pos) 0)))
(cond (cond
((and m ((and m
(send parens is-open-pos? (- m start-pos)) (send parens is-open-pos? m)
(send parens is-close-pos? (- pos start-pos))) (send parens is-close-pos? pos))
(delete pos (+ l pos)) (delete pos (+ l pos))
c) c)
(else (else
@ -681,8 +768,8 @@
(unless stopped? (unless stopped?
(let ((to-pos (backward-match (+ (string-length insert-str) pos) 0))) (let ((to-pos (backward-match (+ (string-length insert-str) pos) 0)))
(when (and to-pos (when (and to-pos
(send parens is-open-pos? (- to-pos start-pos)) (send parens is-open-pos? to-pos)
(send parens is-close-pos? (- pos start-pos))) (send parens is-close-pos? pos))
(flash-on to-pos (+ 1 to-pos))))))))) (flash-on to-pos (+ 1 to-pos)))))))))
(define/public (debug-printout) (define/public (debug-printout)
@ -693,8 +780,7 @@
(set! x null) (set! x null)
(send invalid-tokens for-each f) (send invalid-tokens for-each f)
(printf "invalid-tokens: ~e~n" (reverse x)) (printf "invalid-tokens: ~e~n" (reverse x))
(printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n" (printf "current-pos: ~a invalid-tokens-start ~a~n" current-pos invalid-tokens-start)
start-pos current-pos invalid-tokens-start)
(printf "parens: ~e~n" (car (send parens test))))) (printf "parens: ~e~n" (car (send parens test)))))
;; ------------------------- Callbacks to Override ---------------------- ;; ------------------------- Callbacks to Override ----------------------

8
collects/framework/private/scheme.ss
View File

@ -431,7 +431,7 @@
(inherit get-styles-fixed) (inherit get-styles-fixed)
(inherit has-focus? find-snip split-snip (inherit has-focus? find-snip split-snip
position-location get-dc get-region) position-location get-dc)
(define/override (get-word-at current-pos) (define/override (get-word-at current-pos)
(let ([no-word ""]) (let ([no-word ""])
@ -447,18 +447,14 @@
[else no-word]))]))) [else no-word]))])))
(define/private (look-for-non-symbol start) (define/private (look-for-non-symbol start)
(let-values ([(region-start region-end) (get-region)])
(let loop ([i start]) (let loop ([i start])
(cond (cond
[(and (number? region-start)
(< i region-start))
region-start]
[(< i 0) [(< i 0)
0] 0]
[(eq? (classify-position i) 'symbol) [(eq? (classify-position i) 'symbol)
(loop (- i 1))] (loop (- i 1))]
[else [else
(+ i 1)])))) (+ i 1)])))
(public tabify-on-return? tabify (public tabify-on-return? tabify
tabify-all insert-return calc-last-para tabify-all insert-return calc-last-para

12
collects/syntax-color/paren-tree.ss
View File

@ -25,13 +25,13 @@
(define (reset-cache) (set! back-cache (make-hash-table))) (define (reset-cache) (set! back-cache (make-hash-table)))
(define/private (is-open? x) (define/private (is-open? x)
(hash-table-get open-matches-table x (lambda () #f))) (hash-table-get open-matches-table x #f))
(define/private (is-close? x) (define/private (is-close? x)
(hash-table-get close-matches-table x (lambda () #f))) (hash-table-get close-matches-table x #f))
(define/private (matches? open close) (define/private (matches? open close)
(equal? (hash-table-get open-matches-table open (lambda () #f)) (equal? (hash-table-get open-matches-table open #f)
close)) close))
(define tree (new token-tree%)) (define tree (new token-tree%))
@ -54,7 +54,7 @@
(data (cons #f 0)))) (data (cons #f 0))))
(values first next))))))) (values first next)))))))
;; split-tree: natural-number -> ;; split-tree: natural-number -> void
;; Everything at and after pos is marked as invalid. ;; Everything at and after pos is marked as invalid.
;; pos must not be a position inside of a token. ;; pos must not be a position inside of a token.
(define/public (split-tree pos) (define/public (split-tree pos)
@ -63,7 +63,7 @@
(set! tree l) (set! tree l)
(set! invalid-tree r))) (set! invalid-tree r)))
;; merget-tree: natural-number -> ;; merget-tree: natural-number -> void
;; Makes the num-to-keep last positions that have been marked ;; Makes the num-to-keep last positions that have been marked
;; invalid valid again. ;; invalid valid again.
(define/public (merge-tree num-to-keep) (define/public (merge-tree num-to-keep)
@ -148,7 +148,7 @@
(define (not-found) (define (not-found)
(send tree search! pos) (send tree search! pos)
(values (- pos (cdr (send tree get-root-data))) pos #t)) (values (- pos (cdr (send tree get-root-data))) pos #t))
(define already (hash-table-get back-cache pos (lambda () 'todo))) (define already (hash-table-get back-cache pos 'todo))
(cond (cond
[(not (eq? 'todo already)) (values already pos #f)] [(not (eq? 'todo already)) (values already pos #f)]
[else [else