the paren matcher now works for previous interactinos with the REPL and hitting return up above copies the text down to the next prompt
svn: r8840
This commit is contained in:
Robby Findler
parent
bb6c2fba5a
commit
362f16b411
|
|
@ -581,6 +581,7 @@ TODO
|
|||
get-in-box-port
|
||||
get-insertion-point
|
||||
get-out-port
|
||||
get-regions
|
||||
get-snip-position
|
||||
get-start-position
|
||||
get-styles-fixed
|
||||
|
|
@ -604,7 +605,7 @@ TODO
|
|||
position-paragraph
|
||||
release-snip
|
||||
reset-input-box
|
||||
reset-region
|
||||
reset-regions
|
||||
run-after-edit-sequence
|
||||
scroll-to-position
|
||||
send-eof-to-in-port
|
||||
|
|
@ -847,7 +848,7 @@ TODO
|
|||
(cond
|
||||
[(in-edit-sequence?)
|
||||
(set! had-an-insert (cons (cons start len) had-an-insert))]
|
||||
[else (update-after-insert)]))
|
||||
[else (update-after-insert start len)]))
|
||||
|
||||
;; private field
|
||||
(define had-an-insert '())
|
||||
|
|
@ -877,8 +878,10 @@ TODO
|
|||
(when (space . > . max-space)
|
||||
(let ([to-delete-end (+ start (- space max-space))])
|
||||
(delete/io start to-delete-end))))))
|
||||
|
||||
(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)
|
||||
(unless inserting-prompt?
|
||||
|
|
@ -1009,12 +1012,15 @@ TODO
|
|||
|
||||
(define/augment (on-submit)
|
||||
(inner (void) on-submit)
|
||||
|
||||
(when (and (get-user-thread)
|
||||
(thread-running? (get-user-thread)))
|
||||
;; the -2 drops the last newline from history (why -2 and not -1?!)
|
||||
(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)])
|
||||
(when (if (preferences:get 'drscheme:execute-warning-once)
|
||||
|
|
@ -1036,6 +1042,42 @@ TODO
|
|||
;; clear out the eof object if it wasn't consumed
|
||||
(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)
|
||||
;; the position just after the last prompt
|
||||
(field (prompt-position #f))
|
||||
|
|
@ -1059,8 +1101,7 @@ TODO
|
|||
|
||||
(let ([sp (get-unread-start-point)])
|
||||
(set! prompt-position sp)
|
||||
(reset-region sp 'end)
|
||||
(when (is-frozen?) (thaw-colorer))))
|
||||
(reset-regions (append (get-regions) (list (list sp 'end))))))
|
||||
(end-edit-sequence)
|
||||
(set! inserting-prompt? #f))
|
||||
|
||||
|
|
@ -1458,7 +1499,7 @@ TODO
|
|||
|
||||
;; clear out repl first before doing any work.
|
||||
(begin-edit-sequence)
|
||||
(freeze-colorer)
|
||||
(set! prompt-position #f)
|
||||
(reset-input-box)
|
||||
(delete (paragraph-start-position 1) (last-position))
|
||||
(end-edit-sequence)
|
||||
|
|
@ -1504,7 +1545,7 @@ TODO
|
|||
(set! setting-up-repl? #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-insertion-point (last-position))
|
||||
(set-allow-edits #f)
|
||||
|
|
@ -1654,6 +1695,13 @@ TODO
|
|||
(inherit set-max-undo-history)
|
||||
(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%))
|
||||
(send input-delta set-delta-foreground (make-object color% 0 150 0))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,12 @@
|
|||
#lang scheme/unit
|
||||
(require mzlib/class
|
||||
#|
|
||||
update-region-end is now gone
|
||||
reset-region needs to go
|
||||
added reset-regions
|
||||
added get-regions
|
||||
|#
|
||||
|
||||
(require mzlib/class
|
||||
mzlib/thread
|
||||
mred
|
||||
mzlib/etc
|
||||
|
|
@ -10,23 +17,23 @@
|
|||
"../preferences.ss"
|
||||
"sig.ss")
|
||||
|
||||
(import [prefix icon: framework:icon^]
|
||||
(import [prefix icon: framework:icon^]
|
||||
[prefix mode: framework:mode^]
|
||||
[prefix text: framework:text^]
|
||||
[prefix color-prefs: framework:color-prefs^]
|
||||
[prefix scheme: framework:scheme^])
|
||||
|
||||
(export (rename framework:color^
|
||||
(export (rename framework:color^
|
||||
(-text<%> text<%>)
|
||||
(-text% text%)
|
||||
(-text-mode<%> text-mode<%>)))
|
||||
|
||||
(init-depend framework:text^ framework:mode^)
|
||||
(init-depend framework:text^ framework:mode^)
|
||||
|
||||
(define (should-color-type? type)
|
||||
(define (should-color-type? type)
|
||||
(not (memq type '(white-space no-color))))
|
||||
|
||||
(define -text<%>
|
||||
(define -text<%>
|
||||
(interface (text:basic<%>)
|
||||
start-colorer
|
||||
stop-colorer
|
||||
|
|
@ -37,9 +44,8 @@
|
|||
freeze-colorer
|
||||
thaw-colorer
|
||||
|
||||
reset-region
|
||||
get-region
|
||||
update-region-end
|
||||
reset-regions
|
||||
get-regions
|
||||
|
||||
skip-whitespace
|
||||
backward-match
|
||||
|
|
@ -48,7 +54,7 @@
|
|||
insert-close-paren
|
||||
classify-position))
|
||||
|
||||
(define text-mixin
|
||||
(define text-mixin
|
||||
(mixin (text:basic<%>) (-text<%>)
|
||||
|
||||
;; For profiling
|
||||
|
|
@ -77,7 +83,7 @@
|
|||
|
||||
;; ---------------------- Lexing state ------------------------------
|
||||
|
||||
;; The tree of valid tokens, starting at start-pos
|
||||
;; The tree of valid tokens, starting at 0
|
||||
(define tokens (new token-tree%))
|
||||
|
||||
;; If the tree is completed
|
||||
|
|
@ -92,7 +98,7 @@
|
|||
(define invalid-tokens-start +inf.0)
|
||||
|
||||
;; The position right before the next token to be read
|
||||
(define current-pos start-pos)
|
||||
(define current-pos 0)
|
||||
|
||||
;; The lexer
|
||||
(define get-token #f)
|
||||
|
|
@ -105,15 +111,56 @@
|
|||
|
||||
|
||||
;; ---------------------- Interactions state ------------------------
|
||||
;; The positions right before and right after the area to be tokenized
|
||||
(define start-pos 0)
|
||||
(define end-pos 'end)
|
||||
|
||||
;; regions : (listof (list number (union 'end number)))
|
||||
;; The range of editor positions that should be colored in the buffer
|
||||
(define regions '((0 end)))
|
||||
(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
|
||||
(define/public (reset-region start end)
|
||||
(unless (and (= start start-pos) (eqv? end end-pos))
|
||||
(unless (<= 0 start (last-position))
|
||||
(raise-mismatch-error 'reset-region
|
||||
"start position not inside editor: "
|
||||
|
|
@ -126,16 +173,10 @@
|
|||
(raise-mismatch-error 'reset-region
|
||||
"end position before start position: "
|
||||
(list end start)))
|
||||
(set! start-pos start)
|
||||
(set! end-pos end)
|
||||
(reset-tokens)
|
||||
(do-insert/delete start 0)))
|
||||
(do-insert/delete start 0))
|
||||
|
||||
(define/public (get-region) (values start-pos end-pos))
|
||||
|
||||
;; Modify the end of the region.
|
||||
(define/public (update-region-end end)
|
||||
(set! end-pos end))
|
||||
(define/public (get-region) (values 0 'end))
|
||||
|
||||
;; ---------------------- Preferences -------------------------------
|
||||
(define should-color? #t)
|
||||
|
|
@ -163,7 +204,7 @@
|
|||
(set! restart-callback #f)
|
||||
(set! force-recolor-after-freeze #f)
|
||||
(set! parens (new paren-tree% (matches pairs)))
|
||||
(set! current-pos start-pos)
|
||||
(set! current-pos 0)
|
||||
(set! colors null)
|
||||
(when tok-cor
|
||||
(coroutine-kill tok-cor))
|
||||
|
|
@ -187,26 +228,45 @@
|
|||
(set! invalid-tokens-start (+ invalid-tokens-start length)))
|
||||
(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)
|
||||
(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)
|
||||
#;(printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start))
|
||||
(+ in-start-pos (sub1 new-token-end)))
|
||||
#;(printf "~a at ~a to ~a~n"
|
||||
lexeme
|
||||
(+ start-pos (sub1 new-token-start))
|
||||
(+ start-pos (sub1 new-token-end)))
|
||||
(let ((len (- new-token-end new-token-start)))
|
||||
(set! current-pos (+ len current-pos))
|
||||
(sync-invalid)
|
||||
(when (and should-color? (should-color-type? type) (not frozen?))
|
||||
(set! colors
|
||||
(cons
|
||||
(when (should-color-type? type)
|
||||
(let* ([style-name (token-sym->style type)]
|
||||
(color (send (get-style-list) find-named-style style-name))
|
||||
(sp (+ in-start-pos (sub1 new-token-start)))
|
||||
(ep (+ in-start-pos (sub1 new-token-end))))
|
||||
(λ ()
|
||||
(change-style color sp ep #f)))
|
||||
colors)))
|
||||
[color (send (get-style-list) find-named-style style-name)]
|
||||
[sp (+ start-pos (sub1 new-token-start))]
|
||||
[ep (+ start-pos (sub1 new-token-end))])
|
||||
(add-color color sp ep)))
|
||||
; Using the non-spec version takes 3 times as long as the spec
|
||||
; version. In other words, the new greatly outweighs the tree
|
||||
; operations.
|
||||
|
|
@ -214,17 +274,42 @@
|
|||
(insert-last-spec! tokens len type)
|
||||
(send parens add-token data len)
|
||||
(cond
|
||||
((and (not (send invalid-tokens is-empty?))
|
||||
[(and (not (send invalid-tokens is-empty?))
|
||||
(= invalid-tokens-start current-pos))
|
||||
(send invalid-tokens search-max!)
|
||||
(send parens merge-tree
|
||||
(send invalid-tokens get-root-end-position))
|
||||
(send parens merge-tree (send invalid-tokens get-root-end-position))
|
||||
(insert-last! tokens invalid-tokens)
|
||||
(set! invalid-tokens-start +inf.0)
|
||||
(enable-suspend #t))
|
||||
(else
|
||||
(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)
|
||||
(unless (or stopped? force-stop?)
|
||||
|
|
@ -232,22 +317,21 @@
|
|||
(sync-invalid))
|
||||
(cond
|
||||
(up-to-date?
|
||||
(let-values
|
||||
(((orig-token-start orig-token-end valid-tree invalid-tree)
|
||||
(send tokens split (- edit-start-pos start-pos))))
|
||||
(let-values ([(orig-token-start orig-token-end valid-tree invalid-tree)
|
||||
(send tokens split edit-start-pos)])
|
||||
(send parens split-tree orig-token-start)
|
||||
(set! invalid-tokens invalid-tree)
|
||||
(set! tokens valid-tree)
|
||||
(set! invalid-tokens-start
|
||||
(if (send invalid-tokens is-empty?)
|
||||
+inf.0
|
||||
(+ start-pos orig-token-end change-length)))
|
||||
(set! current-pos (+ start-pos orig-token-start))
|
||||
(+ orig-token-end change-length)))
|
||||
(set! current-pos orig-token-start)
|
||||
(set! up-to-date? #f)
|
||||
(queue-callback (λ () (colorer-callback)) #f)))
|
||||
((>= edit-start-pos invalid-tokens-start)
|
||||
(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-start
|
||||
(+ invalid-tokens-start tok-end change-length))))
|
||||
|
|
@ -255,11 +339,11 @@
|
|||
(set! invalid-tokens-start (+ change-length invalid-tokens-start)))
|
||||
(else
|
||||
(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)
|
||||
(set! tokens valid-tree)
|
||||
(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)
|
||||
|
||||
|
|
@ -274,10 +358,7 @@
|
|||
(coroutine
|
||||
(λ (enable-suspend)
|
||||
(parameterize ((port-count-lines-enabled #t))
|
||||
(re-tokenize (open-input-text-editor this current-pos end-pos
|
||||
(λ (x) #f))
|
||||
current-pos
|
||||
enable-suspend)))))
|
||||
(re-tokenize current-pos enable-suspend)))))
|
||||
(set! rev (get-revision-number)))
|
||||
(with-handlers ((exn:fail?
|
||||
(λ (exn)
|
||||
|
|
@ -327,22 +408,28 @@
|
|||
(set! pairs pairs-)
|
||||
(set! parens (new paren-tree% (matches pairs)))
|
||||
;; (set! timer (current-milliseconds))
|
||||
(do-insert/delete start-pos 0)))
|
||||
(do-insert/delete 0 0)))
|
||||
|
||||
;; See docs
|
||||
(define/public stop-colorer
|
||||
(opt-lambda ((clear-colors #t))
|
||||
(opt-lambda ((clear-the-colors #t))
|
||||
(set! stopped? #t)
|
||||
(when (and clear-colors (not frozen?))
|
||||
(begin-edit-sequence #f #f)
|
||||
(change-style (get-fixed-style) start-pos end-pos #f)
|
||||
(end-edit-sequence))
|
||||
(when (and clear-the-colors (not frozen?))
|
||||
(clear-colors))
|
||||
(match-parens #t)
|
||||
(reset-tokens)
|
||||
(set! pairs null)
|
||||
(set! token-sym->style #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-stopped?) stopped?)
|
||||
|
||||
|
|
@ -379,8 +466,8 @@
|
|||
(when (and should-color? (should-color-type? type))
|
||||
(let ((color (send (get-style-list) find-named-style
|
||||
(token-sym->style type)))
|
||||
(sp (+ start-pos start))
|
||||
(ep (+ start-pos (+ start len))))
|
||||
(sp start)
|
||||
(ep (+ start len)))
|
||||
(change-style color sp ep #f)))))
|
||||
(end-edit-sequence))))))))
|
||||
|
||||
|
|
@ -393,12 +480,10 @@
|
|||
((and (not should-color?) on?)
|
||||
(set! should-color? on?)
|
||||
(reset-tokens)
|
||||
(do-insert/delete start-pos 0))
|
||||
(do-insert/delete 0 0))
|
||||
((and should-color? (not on?))
|
||||
(set! should-color? on?)
|
||||
(begin-edit-sequence #f #f)
|
||||
(change-style (get-fixed-style) start-pos end-pos #f)
|
||||
(end-edit-sequence))))
|
||||
(clear-colors))))
|
||||
|
||||
;; see docs
|
||||
(define/public (force-stop-colorer stop?)
|
||||
|
|
@ -420,14 +505,14 @@
|
|||
;; means the normal paren color and #f means an error color.
|
||||
;; numbers are expected to have zero be start-pos.
|
||||
(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%)
|
||||
color
|
||||
(if color mismatch-color (get-match-color)))
|
||||
(and (send (icon:get-paren-highlight-bitmap)
|
||||
ok?)
|
||||
(icon:get-paren-highlight-bitmap))
|
||||
(= caret-pos (+ start-pos start)))])
|
||||
(= caret-pos start))])
|
||||
(set! clear-old-locations
|
||||
(let ([old clear-old-locations])
|
||||
(λ ()
|
||||
|
|
@ -439,7 +524,7 @@
|
|||
;; the forward matcher signaled an error because not enough of the
|
||||
;; tree has been built.
|
||||
(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,
|
||||
|
|
@ -468,14 +553,14 @@
|
|||
(let* ((here (get-start-position)))
|
||||
(when (= here (get-end-position))
|
||||
(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))
|
||||
start-f end-f)
|
||||
(if error-f
|
||||
(highlight start-f end-f here error-f)
|
||||
(highlight-nested-region start-f end-f here))))
|
||||
(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)
|
||||
(if error-b
|
||||
(highlight start-b end-b here error-b)
|
||||
|
|
@ -496,7 +581,7 @@
|
|||
(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 start-pos) 'forward #t) start-pos)])
|
||||
(let ([post-whitespace (skip-whitespace inner-sequence-start 'forward #t)])
|
||||
(let-values ([(start-inner end-inner error-inner)
|
||||
(send parens match-forward post-whitespace)])
|
||||
(cond
|
||||
|
|
@ -520,16 +605,15 @@
|
|||
(skip-whitespace position 'forward #t)
|
||||
position)))
|
||||
(let-values (((start end error)
|
||||
(send parens match-forward (- position start-pos))))
|
||||
(send parens match-forward position)))
|
||||
(cond
|
||||
((f-match-false-error start end error)
|
||||
(colorer-driver)
|
||||
(do-forward-match position cutoff #f))
|
||||
((and start end (not error))
|
||||
(let ((match-pos (+ start-pos end)))
|
||||
(cond
|
||||
((<= match-pos cutoff) match-pos)
|
||||
(else #f))))
|
||||
((<= end cutoff) end)
|
||||
(else #f)))
|
||||
((and start end error) #f)
|
||||
(else
|
||||
(skip-past-token position)
|
||||
|
|
@ -551,15 +635,15 @@
|
|||
(let-values (((tok-start tok-end)
|
||||
(begin
|
||||
(tokenize-to-pos position)
|
||||
(send tokens search! (- position start-pos))
|
||||
(send tokens search! position)
|
||||
(values (send tokens get-root-start-position)
|
||||
(send tokens get-root-end-position)))))
|
||||
(cond
|
||||
((or (send parens is-close-pos? tok-start)
|
||||
(= (+ start-pos tok-end) position))
|
||||
(= tok-end position))
|
||||
#f)
|
||||
(else
|
||||
(+ start-pos tok-end)))))
|
||||
tok-end))))
|
||||
|
||||
|
||||
;; See docs
|
||||
|
|
@ -574,10 +658,10 @@
|
|||
(error 'backward-match "called on a color:text<%> whose colorer is stopped."))
|
||||
(let ((position (skip-whitespace position 'backward #t)))
|
||||
(let-values (((start end error)
|
||||
(send parens match-backward (- position start-pos))))
|
||||
(send parens match-backward position)))
|
||||
(cond
|
||||
((and start end (not error))
|
||||
(let ((match-pos (+ start-pos start)))
|
||||
(let ((match-pos start))
|
||||
(cond
|
||||
((>= match-pos cutoff) match-pos)
|
||||
(else #f))))
|
||||
|
|
@ -586,17 +670,17 @@
|
|||
(let-values (((tok-start tok-end)
|
||||
(begin
|
||||
(send tokens search!
|
||||
(if (> position start-pos)
|
||||
(- position start-pos 1)
|
||||
(if (> position 0)
|
||||
(- position 1)
|
||||
0))
|
||||
(values (send tokens get-root-start-position)
|
||||
(send tokens get-root-end-position)))))
|
||||
(cond
|
||||
((or (send parens is-open-pos? tok-start)
|
||||
(= (+ start-pos tok-start) position))
|
||||
(= tok-start position))
|
||||
'open)
|
||||
(else
|
||||
(+ start-pos tok-start)))))))))
|
||||
tok-start))))))))
|
||||
|
||||
;; See docs
|
||||
(define/public (backward-containing-sexp position cutoff)
|
||||
|
|
@ -614,7 +698,7 @@
|
|||
(when stopped?
|
||||
(error 'classify-position "called on a color:text<%> whose colorer is stopped."))
|
||||
(tokenize-to-pos position)
|
||||
(send tokens search! (- position start-pos))
|
||||
(send tokens search! position)
|
||||
(send tokens get-root-data))
|
||||
|
||||
(define/private (tokenize-to-pos position)
|
||||
|
|
@ -627,25 +711,28 @@
|
|||
(when stopped?
|
||||
(error 'skip-whitespace "called on a color:text<%> whose colorer is stopped."))
|
||||
(cond
|
||||
((and (eq? direction 'forward)
|
||||
(>= position (if (eq? 'end end-pos) (last-position) end-pos)))
|
||||
position)
|
||||
((and (eq? direction 'backward) (<= position start-pos))
|
||||
position)
|
||||
(else
|
||||
[(not (in-colored-region? position))
|
||||
position]
|
||||
[else
|
||||
(tokenize-to-pos position)
|
||||
(send tokens search! (- (if (eq? direction 'backward) (sub1 position) position)
|
||||
start-pos))
|
||||
(send tokens search! (if (eq? direction 'backward) (sub1 position) position))
|
||||
(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))))
|
||||
(skip-whitespace (+ start-pos
|
||||
(if (eq? direction 'forward)
|
||||
(skip-whitespace (if (eq? direction 'forward)
|
||||
(send tokens get-root-end-position)
|
||||
(send tokens get-root-start-position)))
|
||||
(send tokens get-root-start-position))
|
||||
direction
|
||||
comments?))
|
||||
(else position)))))
|
||||
comments?)]
|
||||
[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)
|
||||
(cond
|
||||
|
|
@ -654,11 +741,11 @@
|
|||
(let* ((c (car closers))
|
||||
(l (string-length c)))
|
||||
(insert c pos)
|
||||
(let ((m (backward-match (+ l pos) start-pos)))
|
||||
(let ((m (backward-match (+ l pos) 0)))
|
||||
(cond
|
||||
((and m
|
||||
(send parens is-open-pos? (- m start-pos))
|
||||
(send parens is-close-pos? (- pos start-pos)))
|
||||
(send parens is-open-pos? m)
|
||||
(send parens is-close-pos? pos))
|
||||
(delete pos (+ l pos))
|
||||
c)
|
||||
(else
|
||||
|
|
@ -681,8 +768,8 @@
|
|||
(unless stopped?
|
||||
(let ((to-pos (backward-match (+ (string-length insert-str) pos) 0)))
|
||||
(when (and to-pos
|
||||
(send parens is-open-pos? (- to-pos start-pos))
|
||||
(send parens is-close-pos? (- pos start-pos)))
|
||||
(send parens is-open-pos? to-pos)
|
||||
(send parens is-close-pos? pos))
|
||||
(flash-on to-pos (+ 1 to-pos)))))))))
|
||||
|
||||
(define/public (debug-printout)
|
||||
|
|
@ -693,8 +780,7 @@
|
|||
(set! x null)
|
||||
(send invalid-tokens for-each f)
|
||||
(printf "invalid-tokens: ~e~n" (reverse x))
|
||||
(printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n"
|
||||
start-pos current-pos invalid-tokens-start)
|
||||
(printf "current-pos: ~a invalid-tokens-start ~a~n" current-pos invalid-tokens-start)
|
||||
(printf "parens: ~e~n" (car (send parens test)))))
|
||||
|
||||
;; ------------------------- Callbacks to Override ----------------------
|
||||
|
|
@ -758,8 +844,8 @@
|
|||
(define (pref-callback k v) (toggle-color v))
|
||||
(preferences:add-callback 'framework:coloring-active pref-callback #t)))
|
||||
|
||||
(define parenthesis-color-table #f)
|
||||
(define (get-parenthesis-colors-table)
|
||||
(define parenthesis-color-table #f)
|
||||
(define (get-parenthesis-colors-table)
|
||||
(unless parenthesis-color-table
|
||||
(set! parenthesis-color-table
|
||||
(list
|
||||
|
|
@ -788,13 +874,13 @@
|
|||
(vector (preferences:get 'framework:paren-match-color)))
|
||||
parenthesis-color-table))
|
||||
|
||||
(define (get-parenthesis-colors)
|
||||
(define (get-parenthesis-colors)
|
||||
(let ([choice (or (assoc (preferences:get 'framework:paren-color-scheme)
|
||||
(get-parenthesis-colors-table))
|
||||
(car (get-parenthesis-colors-table)))])
|
||||
(caddr choice)))
|
||||
|
||||
(define (between start-r start-g start-b end-r end-g end-b)
|
||||
(define (between start-r start-g start-b end-r end-g end-b)
|
||||
(let ([size 4])
|
||||
(build-vector
|
||||
4
|
||||
|
|
@ -805,11 +891,11 @@
|
|||
(between start-g end-g)
|
||||
(between start-b end-b)))))))
|
||||
|
||||
(define -text% (text-mixin text:keymap%))
|
||||
(define -text% (text-mixin text:keymap%))
|
||||
|
||||
(define -text-mode<%> (interface ()))
|
||||
(define -text-mode<%> (interface ()))
|
||||
|
||||
(define text-mode-mixin
|
||||
(define text-mode-mixin
|
||||
(mixin (mode:surrogate-text<%>) (-text-mode<%>)
|
||||
;; The arguments here are only used to be passed to start-colorer. Refer to its
|
||||
;; documentation.
|
||||
|
|
@ -827,4 +913,4 @@
|
|||
|
||||
(super-new)))
|
||||
|
||||
(define text-mode% (text-mode-mixin mode:surrogate-text%))
|
||||
(define text-mode% (text-mode-mixin mode:surrogate-text%))
|
||||
|
|
|
|||
|
|
@ -431,7 +431,7 @@
|
|||
|
||||
(inherit get-styles-fixed)
|
||||
(inherit has-focus? find-snip split-snip
|
||||
position-location get-dc get-region)
|
||||
position-location get-dc)
|
||||
|
||||
(define/override (get-word-at current-pos)
|
||||
(let ([no-word ""])
|
||||
|
|
@ -447,18 +447,14 @@
|
|||
[else no-word]))])))
|
||||
|
||||
(define/private (look-for-non-symbol start)
|
||||
(let-values ([(region-start region-end) (get-region)])
|
||||
(let loop ([i start])
|
||||
(cond
|
||||
[(and (number? region-start)
|
||||
(< i region-start))
|
||||
region-start]
|
||||
[(< i 0)
|
||||
0]
|
||||
[(eq? (classify-position i) 'symbol)
|
||||
(loop (- i 1))]
|
||||
[else
|
||||
(+ i 1)]))))
|
||||
(+ i 1)])))
|
||||
|
||||
(public tabify-on-return? tabify
|
||||
tabify-all insert-return calc-last-para
|
||||
|
|
|
|||
|
|
@ -25,13 +25,13 @@
|
|||
(define (reset-cache) (set! back-cache (make-hash-table)))
|
||||
|
||||
(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)
|
||||
(hash-table-get close-matches-table x (lambda () #f)))
|
||||
(hash-table-get close-matches-table x #f))
|
||||
|
||||
(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))
|
||||
|
||||
(define tree (new token-tree%))
|
||||
|
|
@ -54,7 +54,7 @@
|
|||
(data (cons #f 0))))
|
||||
(values first next)))))))
|
||||
|
||||
;; split-tree: natural-number ->
|
||||
;; split-tree: natural-number -> void
|
||||
;; Everything at and after pos is marked as invalid.
|
||||
;; pos must not be a position inside of a token.
|
||||
(define/public (split-tree pos)
|
||||
|
|
@ -63,7 +63,7 @@
|
|||
(set! tree l)
|
||||
(set! invalid-tree r)))
|
||||
|
||||
;; merget-tree: natural-number ->
|
||||
;; merget-tree: natural-number -> void
|
||||
;; Makes the num-to-keep last positions that have been marked
|
||||
;; invalid valid again.
|
||||
(define/public (merge-tree num-to-keep)
|
||||
|
|
@ -148,7 +148,7 @@
|
|||
(define (not-found)
|
||||
(send tree search! pos)
|
||||
(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
|
||||
[(not (eq? 'todo already)) (values already pos #f)]
|
||||
[else
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user